idFtpServer

var
a: dword;
begin
result := str;
for a := 1 to length( result ) do
if result[a] = '\' then
result[a] := '/';
end;
function SlashToBackSlash( const str: string ) : string;
procedure IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;
procedure IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ;
public
constructor Create; reintroduce;
destructor Destroy; override;
end;
constructor TFTPServer.Create;
begin
IdFTPServer := tIdFTPServer.create( nil ) ;
exit;
end;
if length( APathname ) = 0 then
exit;
if result[length( result ) ] = '\' then
result := copy( result, 1, length( result ) - 1 ) ;
s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ;
ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ;
except
Disclaimer:
Use it at your own risk, it could contain bugs.
Copyright:
Freeware for all use
*)
{$APPTYPE console}
uses
Classes,
windows,
sysutils,
program FTPServer_console;
(*
Sample of the usage of the TIdFtpServer component.
Also shows how to use Indy in console apps
Created by: Bas Gooijen (bas_gooijen@)
f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ;
value := IdHashCRC32.HashValue( f ) ;
result := inttohex( value, 8 ) ;
finally
var
f: tfilestream;
value: dword;
IdHashCRC32: TIdHashCRC32;
begin
IdHashCRC32 := nil;
f := nil;
try
IdHashCRC32 := TIdHashCRC32.create;
var
s: string;
begin
with TIdFTPServerThread( ASender.Thread ) do
begin
if Authenticated then
begin
try
s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ;
var
tmppath: string;
begin
result := SlashToBackSlash( homeDir ) ;
tmppath := SlashToBackSlash( APathname ) ;
if homedir = '/' then
begin
result := tmppath;
// procedure IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;
// procedure IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;
protected
function TransLatePath( const APathname, homeDir: string ) : string;
end;
function StartsWith( const str, substr: string ) : boolean;
begin
result := copy( str, 1, length( substr ) ) = substr;
end;
function BackSlashToSlash( const str: string ) : string;
// Command := 'XCRC';
// OnCommand := IdFTPServer1CommandXCRC;
// end;
IdFTPServer.Active := true;
end;
{
function CalculateCRC( const path: string ) : string;
begin
result := FileSizeByName( APathname ) ;
end;
}
function GetNewDirectory( old, action: string ) : string;
var
a: integer;
begin
if action = '../' then
var
a: dword;
begin
result := str;
for a := 1 to length( result ) do
if result[a] = '/' then
result[a] := '\';
end;
function TFTPServer.TransLatePath( const APathname, homeDir: string ) : string;
begin
if old = '/' then
begin
procedure IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;
procedure IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;
IdFTPServer.OnListDirectory := IdFTPServer1ListDirectory;
IdFTPServer.OnUserLogin := IdFTPServer1UserLogin;
IdFTPServer.OnRetrieveFile := IdFTPServer1RetrieveFile;
IdFTPServer.OnStoreFile := IdFTPServer1StoreFile;
IdFTPServer.OnMakeDirectory := IdFTPServer1MakeDirectory;
IdFTPServer.Greeting.Text.Text := '欢迎进入FTP服务器！ ';
f.free;
IdHashCRC32.free;
end;
end;
procedure TFTPServer.IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;
// note, this is made up, and not defined in any rfc.
IdFTPList,
IdFTPServer,
idtcpserver,
IdSocketHandle,
idglobal,
IdHashCRC;
type
TFTPServer = class
private
{ Private declarations }
ASender.Reply.SetReply( 500, 'file error' ) ;
end;
end;
end;
end;
}
destructor TFTPServer.Destroy;
begin
IdFTPServer.free;
inherited destroy;
IdFTPServer.DefaultPort := 21;
IdFTPServer.AllowAnonymousLogin := False;