//客户端
unit Main;
interface
uses
{$IFDEF Linux}
QGraphics, QControls, QForms, QDialogs, QStdCtrls,
{$ELSE}
windows, messages, graphics, controls, forms, dialogs, stdctrls,
{$ENDIF}
SysUtils, Classes, IdBaseComponent, IdComponent, IdUDPBase, IdUDPClient,
IdTrivialFTP;
type
TfrmMain = class(TForm)
edtRemoteFile: TEdit;
btnUpload: TButton;
edtHost: TEdit;
Label1: TLabel;
Label2: TLabel;
edtLocalFile: TEdit;
Label3: TLabel;
btnDownload: TButton;
TrivialFTP: TIdTrivialFTP;
procedure btnUploadClick(Sender: TObject);
procedure btnDownloadClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$IFDEF MSWINDOWS}{$R *.dfm}{$ELSE}{$R *.xfm}{$ENDIF}
procedure TfrmMain.btnUploadClick(Sender: TObject);
var
s: string;
begin
s := edtRemoteFile.Text;
if s = '' then
s := ExtractFileName(edtLocalFile.Text);
with TrivialFTP do
begin
Host := edtHost.Text;
Put(edtLocalFile.Text, s);
end;
end;
procedure TfrmMain.btnDownloadClick(Sender: TObject);
var
strm: TFileStream;
s: string;
begin
s := edtLocalFile.Text;
if s = '' then
s := ExtractFileName(edtRemoteFile.Text);
strm := TFileStream.Create(s, fmCreate);
with TrivialFTP do
try
Host := edtHost.Text;
Get(edtRemoteFile.Text, strm);
finally
strm.Free;
end;
end;
end.
//服务器
unit main;
interface
uses
{$IFDEF Linux}
QForms, QControls, QStdCtrls, QExtCtrls,
{$ELSE}
Forms, Controls, StdCtrls, ExtCtrls,
{$ENDIF}
IdTrivialFTPServer, Classes, transfer;
type
TfrmMain = class(TForm)
memLog: TMemo;
Panel1: TPanel;
edtRootDir: TEdit;
Label1: TLabel;
Label2: TLabel;
lblCount: TLabel;
btnBrowse: TButton;
procedure FormCreate(Sender: TObject);
procedure btnBrowseClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FTransferList: TList;
procedure TFTPReadFile(Sender: TObject; var FileName: string; const
PeerInfo: TPeerInfo;
var GrantAccess: Boolean; var AStream: TStream; var FreeStreamOnComplete:
Boolean);
procedure TFTPWriteFile(Sender: TObject; var FileName: string; const
PeerInfo: TPeerInfo;
var GrantAccess: Boolean; var AStream: TStream; var FreeStreamOnComplete:
Boolean);
procedure TFTPTransferComplete(Sender: TObject; const Success: Boolean;
const PeerInfo: TPeerInfo; AStream: TStream; const WriteOperation:
Boolean);
function CheckAccess(var FileName: string; RootDir: string): Boolean;
procedure AddTransfer(const FileName: string; const FileMode: Word; AStream:
TProgressStream);
public
end;
var
frmMain: TfrmMain;
implementation
{$IFDEF MSWINDOWS}{$R *.dfm}{$ELSE}{$R *.xfm}{$ENDIF}
uses FileCtrl, SysUtils;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
FTransferList := TList.Create;
edtRootDir.Text := GetCurrentDir;
with TIdTrivialFTPServer.Create(self) do
begin
OnReadFile := TFTPReadFile;
OnWriteFile := TFTPWriteFile;
OnTransferComplete := TFTPTransferComplete;
Active := True;
end;
end;
procedure TfrmMain.TFTPReadFile(Sender: TObject; var FileName: string;
const PeerInfo: TPeerInfo; var GrantAccess: Boolean; var AStream: TStream;
var FreeStreamOnComplete: Boolean);
var
s: string;
begin
FreeStreamOnComplete := False;
s := 'denied';
GrantAccess := CheckAccess(FileName, edtRootDir.Text);
try
if GrantAccess then
begin
AStream := TProgressStream.Create(FileName, fmOpenRead or
fmShareDenyWrite);
AddTransfer(FileName, fmOpenRead, TProgressStream(AStream));
s := 'granted';
lblCount.Caption := IntToStr(succ(StrToInt(lblCount.Caption)));
end;
finally
memLog.Lines.Add(Format('%s:%d - Read access to %s %s',
[PeerInfo.PeerIP, PeerInfo.PeerPort, FileName, s]));
end;
end;
procedure TfrmMain.TFTPTransferComplete(Sender: TObject;
const Success: Boolean; const PeerInfo: TPeerInfo; AStream: TStream; const
WriteOperation: Boolean);
var
s: string;
i: integer;
begin
try
if Success then
s := 'completed'
else
s := 'aborted';
memLog.Lines.Add(Format('%s:%d - Transfer %s - %d bytes transferred',
[PeerInfo.PeerIp, PeerInfo.PeerPort, s, AStream.Position]));
finally
for i := FTransferList.Count - 1 downto 0 do
if TfrmTransfer(FTransferList).Stream = AStream then
begin
TfrmTransfer(FTransferList).Free;
FTransferList.Delete(i);
end;
AStream.Free;
lblCount.Caption := IntToStr(pred(StrToInt(lblCount.Caption)));
end;
end;
procedure TfrmMain.TFTPWriteFile(Sender: TObject; var FileName: string;
const PeerInfo: TPeerInfo; var GrantAccess: Boolean; var AStream: TStream;
var FreeStreamOnComplete: Boolean);
var
s: string;
begin
FreeStreamOnComplete := False;
GrantAccess := CheckAccess(FileName, edtRootDir.Text);
s := 'denied';
try
if GrantAccess then
begin
AStream := TProgressStream.Create(FileName, fmCreate);
AddTransfer(FileName, fmCreate, TProgressStream(AStream));
s := 'granted';
lblCount.Caption := IntToStr(StrToInt(lblCount.Caption) + 1);
end;
finally
memLog.Lines.Add(Format('%s:%d - Write access to %s %s',
[PeerInfo.PeerIP, PeerInfo.PeerPort, FileName, s]));
end;
end;
procedure TfrmMain.btnBrowseClick(Sender: TObject);
var
s: string;
begin
s := edtRootDir.Text;
if SelectDirectory(s, [sdAllowCreate, sdPerformCreate, sdPrompt], 0) then
edtRootDir.Text := s;
end;
function TfrmMain.CheckAccess(var FileName: string; RootDir: string): Boolean;
var
s: string;
begin
RootDir := ExtractFileDir(ExpandFileName(IncludeTrailingBackslash(RootDir) +
'a.b'));
FileName := ExpandFileName(IncludeTrailingBackslash(RootDir) + FileName);
s := FileName;
SetLength(s, Length(RootDir));
Result := AnsiCompareText(RootDir, s) = 0;
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
FTransferList.Free;
end;
procedure TfrmMain.AddTransfer(const FileName: string;
const FileMode: Word; AStream: TProgressStream);
begin
with TfrmTransfer(FTransferList[FTransferList.Add(TfrmTransfer.Create(self,
AStream, FileName, FileMode))]) do
begin
Parent := Self;
Show;
end;
end;
end.
unit transfer;
interface
uses
{$IFDEF Linux}
QControls, QForms, QDialogs, QComCtrls, QStdCtrls,
{$ELSE}
Controls, Forms, Dialogs, ComCtrls, StdCtrls,
{$ENDIF}
Classes, SyncObjs;
type
TProgressStream = class(TFileStream) // single way progress anyway
private
FActivity: TEvent;
FProgress: Integer;
public
constructor Create(const FileName: string; Mode: Word);
destructor Destroy; override;
function Read(var Buffer; Count: Integer): Integer; override;
function Write(const Buffer; Count: Integer): Integer; override;
property Progress: Integer read FProgress;
end;
TfrmTransfer = class(TForm)
prgTransfer: TProgressBar;
Label1: TLabel;
lblByteRate: TLabel;
private
FStartTime: Cardinal;
FThread: TThread;
function GetStream: TProgressStream;
public
procedure CheckProgress;
constructor Create(AOwner: TComponent; AStream: TProgressStream; const
FileName: string; const FileMode: Word); reintroduce; virtual;
destructor Destroy; override;
property Stream: TProgressStream read GetStream;
end;
implementation
uses SysUtils, windows;
{$IFDEF MSWINDOWS}{$R *.dfm}{$ELSE}{$R *.xfm}{$ENDIF}
type
TWaitThread = class(TThread)
private
FOwner: TfrmTransfer;
FStream: TProgressStream;
evtFinished: TEvent;
protected
procedure Execute; override;
public
constructor Create(AOwner: TfrmTransfer; AStream: TProgressStream);
destructor Destroy; override;
end;
{ TfrmTransfer }
procedure TfrmTransfer.CheckProgress;
begin
prgTransfer.Position := Stream.Progress;
prgTransfer.Update;
lblByteRate.Caption := IntToStr(Round((Stream.Progress / (GetTickCount -
FStartTime)) * 1000));
end;
constructor TfrmTransfer.Create(AOwner: TComponent; AStream: TProgressStream;
const FileName: string; const FileMode: Word);
var
s: string;
begin
inherited Create(AOwner);
prgTransfer.Max := AStream.Size;
if FileMode = fmOpenRead then
s := 'Reading'
else
s := 'Writing';
Caption := Format('%s %s', [s, ExtractFileName(FileName)]);
FThread := TWaitThread.Create(self, AStream);
FStartTime := GetTickCount;
end;
destructor TfrmTransfer.Destroy;
begin
FThread.Free;
inherited;
end;
function TfrmTransfer.GetStream: TProgressStream;
begin
result := TWaitThread(FThread).FStream;
end;
{ TWaitThread }
constructor TWaitThread.Create(AOwner: TfrmTransfer; AStream: TProgressStream);
begin
FOwner := AOwner;
FStream := AStream;
FreeOnTerminate := False;
evtFinished := TEvent.Create(nil, false, false, '');
inherited Create(False);
end;
destructor TWaitThread.Destroy;
begin
evtFinished.SetEvent;
WaitFor;
evtFinished.Free;
inherited;
end;
procedure TWaitThread.Execute;
var
hndArray: array[0..1] of THandle;
begin
hndArray[0] := FStream.FActivity.Handle;
hndArray[1] := evtFinished.Handle;
while WaitForMultipleObjects(2, @hndArray, false, INFINITE) = WAIT_OBJECT_0 do
Synchronize(FOwner.CheckProgress);
end;
{ TProgressStream }
constructor TProgressStream.Create(const FileName: string; Mode: Word);
begin
inherited Create(FileName, Mode);
FActivity := TEvent.Create(nil, False, False, '');
end;
destructor TProgressStream.Destroy;
begin
FActivity.Free;
sleep(0);
inherited;
end;
function TProgressStream.Read(var Buffer; Count: Integer): Integer;
begin
FProgress := FProgress + Count;
Result := inherited Read(Buffer, Count);
FActivity.SetEvent;
end;
function TProgressStream.Write(const Buffer; Count: Integer): Integer;
begin
FProgress := FProgress + Count;
Result := inherited Write(Buffer, Count);
FActivity.SetEvent;
end;
end.
