idFTPserver控件实现的ftp 服务器

program FTPServer_console;(*Sample of the usage of the TIdFtpServer component.Also shows how to use Indy in console appsCreated by: Bas Gooijen (bas_gooijen@yahoo.com)Disclaimer:Use it at your own risk, it could contain bugs.Copyright:Freeware for all use*){$APPTYPE console}usesClasses,windows,sysutils,IdFTPList,IdFTPServer,idtcpserver,IdSocketHandle,idglobal,IdHashCRC;typeTFTPServer = classprivate { Private declarations } IdFTPServer: tIdFTPServer; procedure IdFTPServer1UserLogin( ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean ) ; procedure IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ; procedure IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ; procedure IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ; procedure IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;// procedure IdFTPServer1GetFileSize( ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 ) ; 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;end;constructor TFTPServer.Create;beginIdFTPServer := tIdFTPServer.create( nil ) ;IdFTPServer.DefaultPort := 1000;IdFTPServer.AllowAnonymousLogin := False;IdFTPServer.EmulateSystem := ftpsUNIX;IdFTPServer.HelpReply.text := '帮助还没实现';IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory;IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory;// IdFTPServer.OnGetFileSize := IdFTPServer1GetFileSize;IdFTPServer.OnListDirectory := IdFTPServer1ListDirectory;IdFTPServer.OnUserLogin := IdFTPServer1UserLogin;IdFTPServer.OnRetrieveFile := IdFTPServer1RetrieveFile;IdFTPServer.OnStoreFile := IdFTPServer1StoreFile;IdFTPServer.OnMakeDirectory := IdFTPServer1MakeDirectory;IdFTPServer.Greeting.Text.Text := '欢迎进入FTP服务器！ ';IdFTPServer.Greeting.NumericCode := 220;// IdFTPServer.OnDisconnect := IdFTPServer1DisConnect;// with IdFTPServer.CommandHandlers.add do// begin// Command := 'XCRC';// OnCommand := IdFTPServer1CommandXCRC;// end;IdFTPServer.Active := true;end;{function CalculateCRC( const path: string ) : string;varf: tfilestream;value: dword;IdHashCRC32: TIdHashCRC32;beginIdHashCRC32 := 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;procedure TFTPServer.IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;// note, this is made up, and not defined in any rfc.vars: string;beginwith TIdFTPServerThread( ASender.Thread ) dobegin 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;}destructor TFTPServer.Destroy;beginIdFTPServer.free;inherited destroy;end;function StartsWith( const str, substr: string ) : boolean;beginresult := copy( str, 1, length( substr ) ) = substr;end;function BackSlashToSlash( const str: string ) : string;vara: dword;beginresult := str;for a := 1 to length( result ) do if result[a] = '\' then result[a] := '/';end;function SlashToBackSlash( const str: string ) : string;vara: dword;beginresult := str;for a := 1 to length( result ) do if result[a] = '/' then result[a] := '\';end;function TFTPServer.TransLatePath( const APathname, homeDir: string ) : string;vartmppath: string;beginresult := SlashToBackSlash( homeDir ) ;tmppath := SlashToBackSlash( APathname ) ;if homedir = '/' thenbegin 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;{function GetSizeOfFile( const APathname: string ) : int64;beginresult := FileSizeByName( APathname ) ;end;}function GetNewDirectory( old, action: string ) : string;vara: integer;beginif action = '../' thenbegin 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 := actionelse result := old + action;end;procedure TFTPServer.IdFTPServer1UserLogin( ASender: TIdFTPServerThread;const AUsername, APassword: string; var AAuthenticated: Boolean ) ;beginAAuthenticated := ( AUsername = 'wjh' ) and ( APassword = 'jhw' ) ;if not AAuthenticated then exit;ASender.HomeDir := './';asender.currentdir := '/';end;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 := Filename; listitem.OwnerName := 'anonymous'; listitem.GroupName := 'all'; listitem.OwnerPermissions := 'rwx'; listitem.GroupPermissions := 'rwx'; listitem.UserPermissions := 'rwx'; listitem.Size := size; listitem.ModifiedDate := date;end;varf: tsearchrec;a: integer;beginADirectoryListing.DirectoryName := APath;a := FindFirst( TransLatePath( APath, ASender.HomeDir ) + '*.*', faAnyFile, f ) ;while ( a = 0 ) dobegin 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;procedure TFTPServer.IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread;const AFilename: string; var VStream: TStream ) ;beginVStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ;end;procedure TFTPServer.IdFTPServer1StoreFile( ASender: TIdFTPServerThread;const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;beginif FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend then begin VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ; VStream.Seek( 0, soFromEnd ) ; endelse VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ;end;procedure TFTPServer.IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread;var VDirectory: string ) ;beginMkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;end;{procedure TFTPServer.IdFTPServer1GetFileSize( ASender: TIdFTPServerThread;const AFilename: string; var VFileSize: Int64 ) ;begin// VFileSize := GetSizeOfFile( TransLatePath( AFilename, ASender.HomeDir ) ) ;end; }procedure TFTPServer.IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread;var VDirectory: string ) ;beginVDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ;end;{procedure TFTPServer.IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;begin// nothing much hereend;}beginwith TFTPServer.Create dotry writeln( '程序正在运行， 按 [enter]键退出。' ) ; readln;finally free;end;end.