FTP Server demo with Indy components (Views: 34)
Problem/Question/Abstract: Make FTP server. Answer: uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, IdBaseComponent, IdComponent, IdTCPServer, IdFTPServer,idftplist, IdUserAccounts, StdCtrls; public function WindowsDirFixup(APath:String):String; { Public declarations } end; var Form1: TForm1; pRoot:string; //program directory. implementation uses JCLFileUtils; {$R *.dfm} function TForm1.WindowsDirFixup(APath:String):String; var s:string; function ReplaceStr(const S, Srch, Replace: string): string; var I: Integer; Source: string; begin Source := S; Result := ''; repeat I := Pos(Srch, Source); if I > 0 then begin Result := Result + Copy(Source, 1, I - 1) + Replace; Source := Copy(Source, I + Length(Srch), MaxInt); end else Result := Result + Source; until I <= 0; end; begin s := ReplaceStr(APath,'/','\'); s := ReplaceStr(s,'\\','\'); Result := s; end; procedure TForm1.IdFTPServer1ListDirectory(ASender: TIdFTPServerThread; const APath: String; ADirectoryListing: TIdFTPListItems); var Li :TIdFTPListItem; SRec : TSearchRec; a : word; begin ADirectorylisting.DirectoryName :=Apath; ADirectorylisting.ListFormat:=flfdos; memo1.lines.add(apath); // a := FindFirst(pRoot+APath+'\*.*',$31,Srec); //ignore hidden/system files. a := FindFirst(pRoot+APath+'\*.*',faAnyFile ,Srec); //all files. While a =0 do begin li := ADirectoryListing.Add; li.FileName := SRec.Name; li.Size := SRec.Size; li.ModifiedDate := FileDateToDateTime(SRec.Time); if (SRec.Attr and $10) > 0 then li.ItemType := ditDirectory else li.ItemType := ditFile; a := FindNext(SRec); end; FindClose(SRec); // SysUtils.SetCurrentDir(pRoot+APath+'\..'); //Release dir, so it can be deleted, possibly end; procedure TForm1.IdFTPServer1Disconnect(AThread: TIdPeerThread); begin athread.Terminate; end; procedure TForm1.IdFTPServer1AfterUserLogin(ASender: TIdFTPServerThread); begin asender.CurrentDir:='c:\'; asender.HomeDir:='c:\'; end; procedure TForm1.IdFTPServer1MakeDirectory(ASender: TIdFTPServerThread; var VDirectory: String); begin begin if not ForceDirectories(WindowsDirFixup(pRoot+Vdirectory)) then begin // Raise Exception.Create('Could not create directory'); end; end; end; procedure TForm1.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread; const AFileName: String; var VStream: TStream); begin try VStream := TFileStream.Create(WindowsDirFixup(pRoot+AFilename),fmOpenRead); except end; end; procedure TForm1.IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread; var VDirectory: String); begin //ASender.CurrentDir :=ASender.CurrentDir+Vdirectory;//'/'; if vdirectory='..\' then vdirectory:=ASender.CurrentDir+'\..\'; //if vdirectory='../' then vdirectory:='c:'; ASender.CurrentDir :=Vdirectory;//'/'; memo1.lines.add('Changedir: '+vdirectory); end; procedure TForm1.IdFTPServer1StoreFile(ASender: TIdFTPServerThread; const AFileName: String; AAppend: Boolean; var VStream: TStream); begin if not Aappend then VStream := TFileStream.Create(WindowsDirFixup(pRoot+AFilename),fmCreate) else VStream := TFileStream.Create(WindowsDirFixup(pRoot+AFilename),fmOpenWrite) end; procedure TForm1.IdFTPServer1GetFileSize(ASender: TIdFTPServerThread; const AFilename: String; var VFileSize: Int64); var s:string; begin s := WindowsDirFixup(pRoot+AFilename); try If FileExists(s) then VFileSize := GetSizeofFile(S) else VFileSize := 0; except VFileSize := 0; end; end; procedure TForm1.IdFTPServer1DeleteFile(ASender: TIdFTPServerThread; const APathName: String); begin DeleteFile(WindowsDirFixup(pRoot+ASender.CurrentDir+'\'+APathname)); end; procedure TForm1.IdFTPServer1RemoveDirectory(ASender: TIdFTPServerThread; var VDirectory: String); var s:String; begin s := WindowsDirFixup(pRoot+Vdirectory); if DirectoryExists(s) then begin SetCurrentDir(s+'\..\'); //get out of dir. so it can be deleted. if not DelTree(s) then //dir and all files. if not RemoveDir(s) then ;// begin // Raise Exception.Create('Could not remove directory'); end; end; end; procedure TForm1.IdFTPServer1RenameFile(ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: String); var sf,st:String; begin sf := WindowsDirFixup(pRoot+ASender.CurrentDir+'\'+ARenameFromFile); st := WindowsDirFixup(pRoot+ASender.CurrentDir+'\'+ARenameToFile); if not Renamefile(sf,st) then begin Raise Exception.Create('Could not rename file'); end; end; |