Indy9的TIdFTPServer封装类
在Delphi 7开发下有强大的Indy控件，版本为9，要实现一个FTP服务器，参考自带的例子，发现还要写很多函数，而且不支持中文显示文件列表等等。于是，自己改进封装了下，形成一个TFTPServer类，源码如下：
{*******************************************************} { } { 系统名称 FTP服务器类 } { 版权所有 (C) http://blog.csdn.net/akof1314 } { 单元名称 FTPServer.pas } { 单元功能 在Delphi 7下TIdFTPServer实现FTP服务器 } { } {*******************************************************} unit FTPServer; interface uses Classes, Windows, Sysutils, IdFTPList, IdFTPServer, Idtcpserver, IdSocketHandle, Idglobal, IdHashCRC, IdStack; {------------------------------------------------------------------------------- 功能: 自定义消息，方便与窗体进行消息传递 -------------------------------------------------------------------------------} type TFtpNotifyEvent = procedure (ADatetime: TDateTime;AUserIP, AEventMessage: string) of object; {------------------------------------------------------------------------------- 功能: FTP服务器类 -------------------------------------------------------------------------------} type TFTPServer = class private FUserName,FUserPassword,FBorrowDirectory: string; FBorrowPort: Integer; IdFTPServer: TIdFTPServer; FOnFtpNotifyEvent: TFtpNotifyEvent; procedure IdFTPServer1UserLogin( ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean ) ; procedure IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ; procedure IdFTPServer1RenameFile( ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string ) ; procedure IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ; procedure IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ; procedure IdFTPServer1RemoveDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ; procedure IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ; procedure IdFTPServer1GetFileSize( ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 ) ; procedure IdFTPServer1DeleteFile( ASender: TIdFTPServerThread; const APathname: string ) ; procedure IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ; procedure IdFTPServer1CommandXCRC( ASender: TIdCommand ) ; procedure IdFTPServer1DisConnect( AThread: TIdPeerThread ) ; protected function TransLatePath( const APathname, homeDir: string ) : string; public constructor Create; reintroduce; destructor Destroy; override; procedure Run; procedure Stop; function GetBindingIP():string; property UserName: string read FUserName write FUserName; property UserPassword: string read FUserPassword write FUserPassword; property BorrowDirectory: string read FBorrowDirectory write FBorrowDirectory; property BorrowPort: Integer read FBorrowPort write FBorrowPort; property OnFtpNotifyEvent: TFtpNotifyEvent read FOnFtpNotifyEvent write FOnFtpNotifyEvent; end; implementation {------------------------------------------------------------------------------- 过程名: TFTPServer.Create 功能: 创建函数 参数: 无 返回值: 无 -------------------------------------------------------------------------------} constructor TFTPServer.Create; begin IdFTPServer := tIdFTPServer.create( nil ) ; IdFTPServer.DefaultPort := 21; //默认端口号 IdFTPServer.AllowAnonymousLogin := False; //是否允许匿名登录 IdFTPServer.EmulateSystem := ftpsUNIX; IdFTPServer.HelpReply.text := '帮助还未实现！'; IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory; IdFTPServer.OnGetFileSize := IdFTPServer1GetFileSize; IdFTPServer.OnListDirectory := IdFTPServer1ListDirectory; IdFTPServer.OnUserLogin := IdFTPServer1UserLogin; IdFTPServer.OnRenameFile := IdFTPServer1RenameFile; IdFTPServer.OnDeleteFile := IdFTPServer1DeleteFile; IdFTPServer.OnRetrieveFile := IdFTPServer1RetrieveFile; IdFTPServer.OnStoreFile := IdFTPServer1StoreFile; IdFTPServer.OnMakeDirectory := IdFTPServer1MakeDirectory; IdFTPServer.OnRemoveDirectory := IdFTPServer1RemoveDirectory; IdFTPServer.Greeting.Text.Text := '欢迎进入FTP服务器'; IdFTPServer.Greeting.NumericCode := 220; IdFTPServer.OnDisconnect := IdFTPServer1DisConnect; with IdFTPServer.CommandHandlers.add do begin Command := 'XCRC'; //可以迅速验证所下载的文档是否和源文档一样 OnCommand := IdFTPServer1CommandXCRC; end; end; {------------------------------------------------------------------------------- 过程名: CalculateCRC 功能: 计算CRC 参数: const path: string 返回值: string -------------------------------------------------------------------------------} function CalculateCRC( const path: string ) : string; var f: tfilestream; value: dword; IdHashCRC32: TIdHashCRC32; begin IdHashCRC32 := nil; f := nil; try IdHashCRC32 := TIdHashCRC32.create; f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ; value := IdHashCRC32.HashValue( f ) ; result := inttohex( value, 8 ) ; finally f.free; IdHashCRC32.free; end; end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1CommandXCRC 功能: XCRC命令 参数: ASender: TIdCommand 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1CommandXCRC( ASender: TIdCommand ) ; // note, this is made up, and not defined in any rfc. var s: string; begin with TIdFTPServerThread( ASender.Thread ) do begin if Authenticated then begin try s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ; s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ; ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ; except ASender.Reply.SetReply( 500, 'file error' ) ; end; end; end; end; {------------------------------------------------------------------------------- 过程名: TFTPServer.Destroy 功能: 析构函数 参数: 无 返回值: 无 -------------------------------------------------------------------------------} destructor TFTPServer.Destroy; begin IdFTPServer.free; inherited destroy; end; function StartsWith( const str, substr: string ) : boolean; begin result := copy( str, 1, length( substr ) ) = substr; end; {------------------------------------------------------------------------------- 过程名: TFTPServer.Run 功能: 开启服务 参数: 无 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.Run; begin IdFTPServer.DefaultPort := BorrowPort; IdFTPServer.Active := True; end; {------------------------------------------------------------------------------- 过程名: TFTPServer.Stop 功能: 关闭服务 参数: 无 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.Stop; begin IdFTPServer.Active := False; end; {------------------------------------------------------------------------------- 过程名: TFTPServer.GetBindingIP 功能: 获取绑定的IP地址 参数: 返回值: string -------------------------------------------------------------------------------} function TFTPServer.GetBindingIP():string ; begin Result := GStack.LocalAddress; end; {------------------------------------------------------------------------------- 过程名: BackSlashToSlash 功能: 反斜杠到斜杠 参数: const str: string 返回值: string -------------------------------------------------------------------------------} function BackSlashToSlash( const str: string ) : string; var a: dword; begin result := str; for a := 1 to length( result ) do if result[a] = '/' then result[a] := '/'; end; {------------------------------------------------------------------------------- 过程名: SlashToBackSlash 功能: 斜杠到反斜杠 参数: const str: string 返回值: string -------------------------------------------------------------------------------} function SlashToBackSlash( const str: string ) : string; var a: dword; begin result := str; for a := 1 to length( result ) do if result[a] = '/' then result[a] := '/'; end; {------------------------------------------------------------------------------- 过程名: TFTPServer.TransLatePath 功能: 路径名称翻译 参数: const APathname, homeDir: string 返回值: string -------------------------------------------------------------------------------} function TFTPServer.TransLatePath( const APathname, homeDir: string ) : string; var tmppath: string; begin result := SlashToBackSlash(Utf8ToAnsi(homeDir) ) ; tmppath := SlashToBackSlash( Utf8ToAnsi(APathname) ) ; if homedir = '/' then begin result := tmppath; exit; end; if length( APathname ) = 0 then exit; if result[length( result ) ] = '/' then result := copy( result, 1, length( result ) - 1 ) ; if tmppath[1] <> '/' then result := result + '/'; result := result + tmppath; end; {------------------------------------------------------------------------------- 过程名: GetNewDirectory 功能: 得到新目录 参数: old, action: string 返回值: string -------------------------------------------------------------------------------} function GetNewDirectory( old, action: string ) : string; var a: integer; begin if action = '../' then begin if old = '/' then begin result := old; exit; end; a := length( old ) - 1; while ( old[a] <> '/' ) and ( old[a] <> '/' ) do dec( a ) ; result := copy( old, 1, a ) ; exit; end; if ( action[1] = '/' ) or ( action[1] = '/' ) then result := action else result := old + action; end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1UserLogin 功能: 允许服务器执行一个客户端连接的用户帐户身份验证 参数: ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1UserLogin( ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean ) ; begin AAuthenticated := ( AUsername = UserName ) and ( APassword = UserPassword ) ; if not AAuthenticated then exit; ASender.HomeDir := AnsiToUtf8(BorrowDirectory); asender.currentdir := '/'; if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'用户登录服务器'); end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1ListDirectory 功能: 允许服务器生成格式化的目录列表 参数: ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ; procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ; var listitem: TIdFTPListItem; begin listitem := aDirectoryListing.Add; listitem.ItemType := ItemType; //表示一个文件系统的属性集 listitem.FileName := AnsiToUtf8(Filename); //名称分配给目录中的列表项,这里防止了中文乱码 listitem.OwnerName := 'anonymous';//代表了用户拥有的文件或目录项的名称 listitem.GroupName := 'all'; //指定组名拥有的文件名称或目录条目 listitem.OwnerPermissions := 'rwx'; //拥有者权限，R读W写X执行 listitem.GroupPermissions := 'rwx'; //组拥有者权限 listitem.UserPermissions := 'rwx'; //用户权限，基于用户和组权限 listitem.Size := size; listitem.ModifiedDate := date; end; var f: tsearchrec; a: integer; begin ADirectoryListing.DirectoryName := apath; a := FindFirst( TransLatePath( apath, ASender.HomeDir ) + '*.*', faAnyFile, f ) ; while ( a = 0 ) do begin if ( f.Attr and faDirectory > 0 ) then AddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) ) else AddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ; a := FindNext( f ) ; end; FindClose( f ) ; end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1RenameFile 功能: 允许服务器重命名服务器文件系统中的文件 参数: ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1RenameFile( ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string ) ; begin try if not MoveFile( pchar( TransLatePath( ARenameFromFile, ASender.HomeDir ) ) , pchar( TransLatePath( ARenameToFile, ASender.HomeDir ) ) ) then RaiseLastOSError; except on e:Exception do begin if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'重命名文件[' + Utf8ToAnsi(ARenameFromFile) + ']失败，原因是' + e.Message); Exit; end; end; if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'重命名文件[' + Utf8ToAnsi(ARenameFromFile) + ']为[' + Utf8ToAnsi(ARenameToFile) + ']'); end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1RetrieveFile 功能: 允许从服务器下载文件系统中的文件 参数: ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ; begin VStream := TFileStream.Create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ; if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'下载文件[' + Utf8ToAnsi(AFilename) + ']'); end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1StoreFile 功能: 允许在服务器上传文件系统中的文件 参数: ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ; begin if FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend then begin VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ; VStream.Seek( 0, soFromEnd ) ; end else VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ; if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'上传文件[' + Utf8ToAnsi(AFilename) + ']'); end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1RemoveDirectory 功能: 允许服务器在服务器删除文件系统的目录 参数: ASender: TIdFTPServerThread; var VDirectory: string 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1RemoveDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ; begin try RmDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ; except on e:Exception do begin if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除目录[' + Utf8ToAnsi(VDirectory) + ']失败，原因是' + e.Message); Exit; end; end; if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除目录[' + Utf8ToAnsi(VDirectory) + ']'); end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1MakeDirectory 功能: 允许服务器从服务器中创建一个新的子目录 参数: ASender: TIdFTPServerThread; var VDirectory: string 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ; begin try MkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ; except on e:Exception do begin if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'创建目录[' + Utf8ToAnsi(VDirectory) + ']失败，原因是' + e.Message); Exit; end; end; if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'创建目录[' + Utf8ToAnsi(VDirectory) + ']'); end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1GetFileSize 功能: 允许服务器检索在服务器文件系统的文件的大小 参数: ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1GetFileSize( ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 ) ; begin VFileSize := FileSizeByName( TransLatePath( AFilename, ASender.HomeDir ) ) ; if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'获取文件大小'); end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1DeleteFile 功能: 允许从服务器中删除的文件系统中的文件 参数: ASender: TIdFTPServerThread; const APathname: string 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1DeleteFile( ASender: TIdFTPServerThread; const APathname: string ) ; begin try DeleteFile( pchar( TransLatePath( ASender.CurrentDir + '/' + APathname, ASender.HomeDir ) ) ) ; except on e:Exception do begin if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除文件[' + Utf8ToAnsi(APathname) + ']失败，原因是' + e.Message); Exit; end; end; if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除文件[' + Utf8ToAnsi(APathname) + ']'); end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1ChangeDirectory 功能: 允许服务器选择一个文件系统路径 参数: ASender: TIdFTPServerThread; var VDirectory: string 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ; begin VDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ; if Assigned(FOnFtpNotifyEvent) then OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'进入目录[' + Utf8ToAnsi(VDirectory) + ']'); end; {------------------------------------------------------------------------------- 过程名: TFTPServer.IdFTPServer1DisConnect 功能: 失去网络连接 参数: AThread: TIdPeerThread 返回值: 无 -------------------------------------------------------------------------------} procedure TFTPServer.IdFTPServer1DisConnect( AThread: TIdPeerThread ) ; begin // nothing much here end; end.
使用工程示例：
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, FTPServer;
type
TForm1 = class(TForm)
btn1: TButton;
btn2: TButton;
edt_BorrowDirectory: TEdit;
lbl1: TLabel;
mmo1: TMemo;
lbl2: TLabel;
edt_BorrowPort: TEdit;
lbl3: TLabel;
edt_UserName: TEdit;
lbl4: TLabel;
edt_UserPassword: TEdit;
procedure btn1Click(Sender: TObject);
procedure btn2Click(Sender: TObject);
procedure TFTPServer1FtpNotifyEvent(ADatetime: TDateTime;AUserIP, AEventMessage: string);
private
FFtpServer: TFTPServer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btn1Click(Sender: TObject);
begin
if not Assigned(FFtpServer) then
begin
FFtpServer := TFTPServer.Create;
FFtpServer.UserName := Trim(edt_UserName.Text);
FFtpServer.UserPassword := Trim(edt_UserPassword.Text);
FFtpServer.BorrowDirectory := Trim(edt_BorrowDirectory.Text);
FFtpServer.BorrowPort := StrToInt(Trim(edt_BorrowPort.Text));
FFtpServer.OnFtpNotifyEvent := TFTPServer1FtpNotifyEvent;
FFtpServer.Run;
mmo1.Lines.Add(DateTimeToStr(Now) + # 32 + 'FTP服务器已开启，本机IP地址：' + FFtpServer.GetBindingIP);
end;
end;
procedure TForm1.btn2Click(Sender: TObject);
begin
if Assigned(FFtpServer) then
begin
FFtpServer.Stop;
FreeAndNil(FFtpServer);
mmo1.Lines.Add(DateTimeToStr(Now) + # 32 + 'FTP服务器已关闭');
end;
end;
procedure TForm1.TFTPServer1FtpNotifyEvent(ADatetime: TDateTime;AUserIP, AEventMessage: string);
begin
mmo1.Lines.Add(DateTimeToStr(ADatetime) + # 32 + AUserIP + # 32 + AEventMessage);
SendMessage(mmo1.Handle,WM_VSCROLL,SB_PAGEDOWN, 0);
end;
end.
结果如下图所示：
示例工程源码下载：http://download.csdn.net/source/3236325