Indy9/Indy 9/IdFTP.pas

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  10161: IdFTP.pas 
{
{   Rev 1.9    7/23/04 6:06:52 PM  RLebeau
{ Bug fix in Get() for TFileStream access rights
}
{
{   Rev 1.8    7/13/04 6:17:06 PM  RLebeau
{ Renamed DefaultDataPort property to DataPort and added support for new
{ DataPortMin/Max properties
}
{
{   Rev 1.7    7/13/04 5:38:56 PM  RLebeau
{ Added DefaultDataPort property
}
{
{   Rev 1.6    7/9/04 1:49:18 PM  RLebeau
{ Bug fix for OnParseCustomListFormat event handler begin lost whenever List()
{ is called.
}
{
{   Rev 1.5    1/27/2004 10:18:18 PM  JPMugaas
{ Fix from Steve Loft for a server that sends something like this:
{ "227 Passive mode OK (195,92,195,164,4,99 )"
}
{
    Rev 1.4    3/19/2003 2:40:18 PM  BGooijen
  The IOHandler of the datachannel was not freed
}
{
    Rev 1.3    3/19/2003 1:41:26 PM  BGooijen
  Fixed datachannel over socks connection (uploading files)
}
{
    Rev 1.2    3/13/2003 10:54:56 AM  BGooijen
  The transfertype is now set in .login, instead of in .connect, when autologin
  = true
}
{
    Rev 1.1    3/12/2003 12:48:00 PM  BGooijen
  Fixed datachannel over socks connection
}
{
{   Rev 1.0    2002.11.12 10:38:30 PM  czhower
}
unit IdFTP;

{
Change Log:
2002-09-18 - Remy Lebeau
  - added AFromBeginning parameter to InternalPut to correctly honor the AAppend parameter of Put
2002-01-xx - Andrew P.Rybin
  - Proxy support, OnAfterGet (ex:decrypt, set srv timestamp)
  - J.Peter Mugaas: not readonly ProxySettings
  A Neillans - 10/17/2001
    Merged changes submitted by Andrew P.Rybin
    Correct command case problems - some servers expect commands in Uppercase only.
  SP - 06/08/2001
    Added a few more functions
  Doychin - 02/18/2001
    OnAfterLogin event handler and Login method

    OnAfterLogin is executed after successfull login  but before setting up the
      connection properties. This event can be used to provide FTP proxy support
      from the user application. Look at the FTP demo program for more information
      on how to provide such support.

  Doychin - 02/17/2001
    New onFTPStatus event
    New Quote method for executing commands not implemented by the compoent

-CleanDir contributed by Amedeo Lanza

TODO: Chage the FTP demo to demonstrate the use of the new events and add proxy support
}

interface

uses
  Classes,
  IdAssignedNumbers, IdException, IdRFCReply,
  IdSocketHandle, IdTCPConnection, IdTCPClient, IdThread, IdFTPList, IdFTPCommon, IdGlobal;

type
  //Added by SP
  TIdCreateFTPList = procedure(ASender: TObject; Var VFTPList: TIdFTPListItems) of object;
  TIdCheckListFormat = procedure(ASender: TObject; const ALine: String; Var VListFormat: TIdFTPListFormat) of object;
  TOnAfterClientLogin = TNotifyEvent;
  TIdFtpAfterGet = procedure (ASender: TObject; VStream: TStream) of object; //APR

const
  Id_TIdFTP_TransferType = ftBinary;
  Id_TIdFTP_Passive = False;

type
  //APR 011216:
  TIdFtpProxyType = (fpcmNone,//Connect method:
    fpcmUserSite, //Send command USER user@hostname
    fpcmSite, //Send command SITE (with logon)
    fpcmOpen, //Send command OPEN
    fpcmUserPass,//USER user@firewalluser@hostname / PASS pass@firewallpass
    fpcmTransparent, //First use the USER and PASS command with the firewall username and password, and then with the target host username and password.
    fpcmHttpProxyWithFtp //HTTP Proxy with FTP support. Will be supported in Indy 10
  ); //TIdFtpProxyType

  TIdFtpProxySettings = class (TPersistent)
  protected
    FHost, FUserName, FPassword: String;
    FProxyType: TIdFtpProxyType;
    FPort: Integer;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property  ProxyType: TIdFtpProxyType read FProxyType write FProxyType;
    property  Host: String read FHost write FHost;
    property  UserName: String read FUserName write FUserName;
    property  Password: String read FPassword write FPassword;
    property  Port: Integer read FPort write FPort;
  End;//TIdFtpProxySettings

  TIdFTP = class(TIdTCPClient)
  protected
    FCanResume: Boolean;
    FListResult: TStrings;
    FLoginMsg: TIdRFCReply;
    FPassive: boolean;
    FResumeTested: Boolean;
    FSystemDesc: string;
    FTransferType: TIdFTPTransferType;
    FDataChannel: TIdTCPConnection;
    FDataPort: Integer;
    FDataPortMin: Integer;
    FDataPortMax: Integer;
    FDirectoryListing: TIdFTPListItems;
    FOnAfterClientLogin: TNotifyEvent;
    FOnCreateFTPList: TIdCreateFTPList;
    FOnCheckListFormat: TIdCheckListFormat;
    FOnParseCustomListFormat: TIdOnParseCustomListFormat;
    FOnAfterGet: TIdFtpAfterGet; //APR
    FProxySettings: TIdFtpProxySettings;
    //
    procedure ConstructDirListing;
    procedure DoAfterLogin;
    procedure DoFTPList;
    procedure DoCheckListFormat(const ALine: String);
    function GetDirectoryListing: TIdFTPListItems;
    procedure InitDataChannel;
    procedure InternalGet(const ACommand: string; ADest: TStream; AResume: Boolean = false);
    procedure InternalPut(const ACommand: string; ASource: TStream; AFromBeginning: Boolean = true);
    procedure SetOnParseCustomListFormat(const AValue: TIdOnParseCustomListFormat);
    procedure SendPassive(var VIP: string; var VPort: integer);
    procedure SendPort(AHandle: TIdSocketHandle);
    procedure SetProxySettings(const Value: TIdFtpProxySettings);
    procedure SendTransferType;
    procedure SetTransferType(AValue: TIdFTPTransferType);
    procedure DoAfterGet (AStream: TStream); virtual; //APR
  public
    procedure Abort; virtual;
    procedure Account(AInfo: String);
    procedure Allocate(AAllocateBytes: Integer);
    procedure ChangeDir(const ADirName: string);
    procedure ChangeDirUp;
    procedure Connect(AAutoLogin: boolean = True; const ATimeout: Integer = IdTimeoutDefault); reintroduce;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Delete(const AFilename: string);
    procedure FileStructure(AStructure: TIdFTPDataStructure);
    procedure Get(const ASourceFile: string; ADest: TStream; AResume: Boolean = false); overload;
    procedure Get(const ASourceFile, ADestFile: string; const ACanOverwrite: boolean = false; AResume: Boolean = false); overload;
    procedure Help(var AHelpContents: TStringList; ACommand: String = '');
    procedure KillDataChannel; virtual;
    procedure List(ADest: TStrings; const ASpecifier: string = ''; const ADetails: boolean = true);
    procedure Login;
    procedure MakeDir(const ADirName: string);
    procedure Noop;
    procedure Put(const ASource: TStream; const ADestFile: string = '';
     const AAppend: boolean = false); overload;
    procedure Put(const ASourceFile: string; const ADestFile: string = '';
     const AAppend: boolean = false); overload;
    procedure Quit;
    function Quote(const ACommand: String): SmallInt;
    procedure RemoveDir(const ADirName: string);
    procedure Rename(const ASourceFile, ADestFile: string);
    function ResumeSupported: Boolean;
    function RetrieveCurrentDir: string;
    procedure Site(const ACommand: string);
    function Size(const AFileName: String): Integer;
    procedure Status(var AStatusList: TStringList);
    procedure StructureMount(APath: String);
    procedure TransferMode(ATransferMode: TIdFTPTransferMode);
    procedure ReInitialize(ADelay: Cardinal = 10);
    //
    property CanResume: Boolean read ResumeSupported;
    property DirectoryListing: TIdFTPListItems read GetDirectoryListing;// FDirectoryListing;
    property LoginMsg: TIdRFCReply read FLoginMsg;
    property SystemDesc: string read FSystemDesc;
    property ListResult: TStrings read FListResult; //APR
  published
    property DataPort: Integer read FDataPort write FDataPort default 0;
    property DataPortMin: Integer read FDataPortMin write FDataPortMin default 0;
    property DataPortMax: Integer read FDataPortMax write FDataPortMax default 0;
    property Passive: boolean read FPassive write FPassive default Id_TIdFTP_Passive;
    property Password;
    property Port default IDPORT_FTP;
    property ProxySettings: TIdFtpProxySettings read FProxySettings write SetProxySettings;
    property TransferType: TIdFTPTransferType read FTransferType write SetTransferType default Id_TIdFTP_TransferType;
    property Username;

    property OnAfterClientLogin: TOnAfterClientLogin read FOnAfterClientLogin write FOnAfterClientLogin;
    property OnCheckListFormat: TIdCheckListFormat read FOnCheckListFormat write FOnCheckListFormat;
    property OnCreateFTPList: TIdCreateFTPList read FOnCreateFTPList write FOnCreateFTPList;
    property OnParseCustomListFormat: TIdOnParseCustomListFormat read FOnParseCustomListFormat
     write SetOnParseCustomListFormat;
    property OnAfterGet: TIdFtpAfterGet read FOnAfterGet write FOnAfterGet; //APR
  end;
  EIdFTPFileAlreadyExists = class(EIdException);

implementation

uses
  IdComponent, IdResourceStrings, IdStack, IdSimpleServer, IdIOHandlerSocket,
  SysUtils;

function CleanDirName(const APWDReply: string): string;
begin
  Result := APWDReply;
  Delete(result, 1, IndyPos('"', result)); // Remove first doublequote
  Result := Copy(result, 1, IndyPos('"', result) - 1); // Remove anything from second doublequote                                 // to end of line
end;

constructor TIdFTP.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Port := IDPORT_FTP;
  Passive := Id_TIdFTP_Passive;
  FDataPort := 0;
  FDataPortMin := 0;
  FDataPortMax := 0;
  FTransferType := Id_TIdFTP_TransferType;
  FLoginMsg := TIdRFCReply.Create(NIL);
  FListResult := TStringList.Create;
  FCanResume := false;
  FResumeTested := false;
  FProxySettings:= TIdFtpProxySettings.Create; //APR
end;

procedure TIdFTP.Connect(AAutoLogin: boolean = True;
  const ATimeout: Integer = IdTimeoutDefault); 
var
  TmpHost: String;
  TmpPort: Integer;
begin
  try
    //APR 011216: proxy support
    TmpHost:=FHost;
    TmpPort:=FPort;
    try
      if (ProxySettings.ProxyType > fpcmNone) and (Length(ProxySettings.Host) > 0) then begin
        FHost := ProxySettings.Host;
        FPort := ProxySettings.Port;
      end;
      inherited Connect(ATimeout);
    finally
      FHost := TmpHost;
      FPort := TmpPort;
    end;//tryf
    GetResponse([220]);
    Greeting.Assign(LastCmdResult);
    if AAutoLogin then begin
      Login;
      DoAfterLogin;
      // OpenVMS 7.1 replies with 200 instead of 215 - What does the RFC say about this?
      if SendCmd('SYST', [200, 215, 500]) = 500 then begin  {Do not translate}
        FSystemDesc := RSFTPUnknownHost;
      end else begin
        FSystemDesc := LastCmdResult.Text[0];
      end;
      DoStatus(ftpReady, [RSFTPStatusReady]);
    end;
  except
    Disconnect;
    raise;
  end;
end;

procedure TIdFTP.SetTransferType(AValue: TIdFTPTransferType);
begin
  if AValue <> FTransferType then begin
    if not Assigned(FDataChannel) then begin
      FTransferType := AValue;
      if Connected then begin
        SendTransferType;
      end;
    end
  end;
end;

procedure TIdFTP.SendTransferType;
var
  s: string;
begin
  case TransferType of
    ftAscii: s := 'A';      {Do not translate}
    ftBinary: s := 'I';     {Do not translate}
  end;
  SendCmd('TYPE ' + s, 200); {Do not translate}
end;

function TIdFTP.ResumeSupported: Boolean;
begin
  if FResumeTested then result := FCanResume
  else begin
    FResumeTested := true;
    FCanResume := Quote('REST 1') = 350;   {Do not translate}
    result := FCanResume;
    Quote('REST 0');  {Do not translate}
  end;
end;

procedure TIdFTP.Get(const ASourceFile: string; ADest: TStream; AResume: Boolean = false);
begin
  AResume := AResume and CanResume;
  InternalGet('RETR ' + ASourceFile, ADest, AResume);   {Do not translate}
  DoAfterGet(ADest); //APR
end;

procedure TIdFTP.Get(const ASourceFile, ADestFile: string; const ACanOverwrite: boolean = false;
  AResume: Boolean = false);
var
  LDestStream: TFileStream;
begin
  if FileExists(ADestFile) then begin
    AResume := AResume and CanResume;
    if ACanOverwrite and (not AResume) then begin
      LDestStream := TFileStream.Create(ADestFile, fmCreate);
    end
    else begin
      if (not ACanOverwrite) and AResume then begin
        LDestStream := TFileStream.Create(ADestFile, fmOpenReadWrite or fmShareDenyWrite);
        LDestStream.Seek(0, soFromEnd);
      end
      else begin
        raise EIdFTPFileAlreadyExists.Create(RSDestinationFileAlreadyExists);
      end;
    end;
  end
  else begin
    LDestStream := TFileStream.Create(ADestFile, fmCreate);
  end;

  try
    Get(ASourceFile, LDestStream, AResume);
  finally
    FreeAndNil(LDestStream);
  end;
end;

procedure TIdFTP.DoAfterGet (AStream: TStream);//APR
Begin
  if Assigned(FOnAfterGet) then FOnAfterGet(SELF,AStream);
End;//TIdFTP.AtAfterFileGet


procedure TIdFTP.ConstructDirListing;
begin
  if not Assigned(FDirectoryListing) then begin
    if not (csDesigning in ComponentState) then begin
      DoFTPList;
    end;
    if not Assigned(FDirectoryListing) then begin
      FDirectoryListing := TIdFTPListItems.Create;
    end;
    FDirectoryListing.OnParseCustomListFormat := FOnParseCustomListFormat;
  end else begin
    FDirectoryListing.Clear;
  end;
end;

procedure TIdFTP.List(ADest: TStrings; const ASpecifier: string = '';      {Do not translate}
 const ADetails: boolean = true);
var
  LDest: TStringStream;
begin
  LDest := TStringStream.Create(''); try   {Do not translate}
    if ADetails then begin
      InternalGet(trim('LIST ' + ASpecifier), LDest);  {Do not translate}
    end else begin
      InternalGet(trim('NLST ' + ASpecifier), LDest);  {Do not trnalstate}
    end;
    FreeAndNil(FDirectoryListing);
    if Assigned(ADest) then begin //APR: User can use ListResult and DirectoryListing
      ADest.Text := LDest.DataString;
    end;
    FListResult.Text := LDest.DataString;
  finally FreeAndNil(LDest); end;
end;

procedure TIdFTP.InternalGet(const ACommand: string; ADest: TStream; AResume: Boolean = false);
var
  LIP: string;
  LPort: Integer;
  LResponse: Integer;
begin
  DoStatus(ftpTransfer, [RSFTPStatusStartTransfer]); try
    if FPassive then begin
      SendPassive(LIP, LPort);
      FDataChannel := TIdTCPClient.Create(nil); try
        with (FDataChannel as TIdTCPClient) do begin
          if (Self.IOHandler is TIdIOHandlerSocket) then begin
            if not assigned(IOHandler) then begin
              IOHandler:=TIdIOHandlerSocket.create(nil);
            end;
            TIdIOHandlerSocket(IOHandler).SocksInfo.Assign(TIdIOHandlerSocket(Self.IOHandler).SocksInfo);
            TIdIOHandlerSocket(IOHandler).SocksInfo.IOHandler:=IOHandler;
          end;
          InitDataChannel;
          Host := LIP;
          Port := LPort;
          Connect; try
            if AResume then begin
              Self.SendCmd('REST ' + IntToStr(ADest.Position), [350]);   {Do not tranlsate}
            end;
            Self.WriteLn(ACommand);
            Self.GetResponse([125, 150, 154]); //APR: Ericsson Switch FTP
            ReadStream(ADest, -1, True);
          finally Disconnect; end;
        end;
      finally FDataChannel.IOHandler.free; FDataChannel.IOHandler:=nil; FreeAndNil(FDataChannel); end;
    end else begin
      FDataChannel := TIdSimpleServer.Create(nil); try
        with TIdSimpleServer(FDataChannel) do begin
          InitDataChannel;
          BoundIP := (Self.IOHandler as TIdIOHandlerSocket).Binding.IP;
          BoundPort := Self.DataPort;
          BoundPortMin := Self.DataPortMin;
          BoundPortMax := Self.DataPortMax;
          BeginListen;
          SendPort(Binding);
          if AResume then begin
            Self.SendCmd('REST ' + IntToStr(ADest.Position), [350]);  {Do not translate}
          end;
          Self.SendCmd(ACommand, [125, 150, 154]); //APR: Ericsson Switch FTP
          Listen;
          ReadStream(ADest, -1, True);
        end;
      finally
        FreeAndNil(FDataChannel);
      end;
    end;
  finally
    DoStatus(ftpReady, [RSFTPStatusDoneTransfer]);
  end;
  // ToDo: Change that to properly handle response code (not just success or except)
  // 226 = download successful, 225 = Abort successful}
  LResponse := GetResponse([225, 226, 250, 426, 450]);
  if (LResponse = 426) or (LResponse = 450) then begin
    GetResponse([226, 225]);
    DoStatus(ftpAborted, [RSFTPStatusAbortTransfer]);
  end;
end;

procedure TIdFTP.Quit;
begin
  if Connected then begin
    WriteLn('QUIT');      {Do not translate}
  end;
  Disconnect;
end;

procedure TIdFTP.KillDataChannel;
begin
  // Had kill the data channel ()
  if Assigned(FDataChannel) then begin
    FDataChannel.DisconnectSocket;
  end;
end;

procedure TIdFTP.Abort;
begin
  // only send the abort command. The Data channel is supposed to disconnect
  if Connected then begin
    WriteLn('ABOR');                   {Do not translate}
  end;
  // Kill the data channel: usually, the server doesn't close it by itself
  KillDataChannel;
end;

procedure TIdFTP.SendPort(AHandle: TIdSocketHandle);
begin
  SendCmd('PORT ' + StringReplace(AHandle.IP, '.', ',', [rfReplaceAll])   {Do not translate}
   + ',' + IntToStr(AHandle.Port div 256) + ',' + IntToStr(AHandle.Port mod 256), [200]); {Do not translate}
end;

procedure TIdFTP.InternalPut(const ACommand: string; ASource: TStream; AFromBeginning: Boolean = true);
var
  LIP: string;
  LPort: Integer;
  LResponse: Integer;
begin
  DoStatus(ftpTransfer, [RSFTPStatusStartTransfer]); try
    if FPassive then begin
      SendPassive(LIP, LPort);
      WriteLn(ACommand);
      FDataChannel := TIdTCPClient.Create(nil);
      with TIdTCPClient(FDataChannel) do try
        if (Self.IOHandler is TIdIOHandlerSocket) then begin
          if not assigned(IOHandler) then begin
            IOHandler:=TIdIOHandlerSocket.create(nil);
          end;
          TIdIOHandlerSocket(IOHandler).SocksInfo.Assign(TIdIOHandlerSocket(Self.IOHandler).SocksInfo);
          TIdIOHandlerSocket(IOHandler).SocksInfo.IOHandler:=IOHandler;
        end;
        InitDataChannel;
        Host := LIP;
        Port := LPort;
        Connect;
        try
          Self.GetResponse([110, 125, 150]);
          try
            WriteStream(ASource, {false}AFromBeginning);
          except
            on E: EIdSocketError do begin
              // If 10038 - abort was called. Server will return 225
              if E.LastError <> 10038 then begin
                raise;
              end;
            end;
          end;
        finally Disconnect; end;
      finally FDataChannel.IOHandler.free; FDataChannel.IOHandler:=nil; FreeAndNil(FDataChannel); end;
    end else begin
      FDataChannel := TIdSimpleServer.Create(nil); try
        with TIdSimpleServer(FDataChannel) do begin
          InitDataChannel;
          BoundIP := (Self.IOHandler as TIdIOHandlerSocket).Binding.IP;
          BoundPort := Self.DataPort;
          BoundPortMin := Self.DataPortMin;
          BoundPortMax := Self.DataPortMax;
          BeginListen;
          SendPort(Binding);
          Self.SendCmd(ACommand, [125, 150]);
          Listen;
          WriteStream(ASource, AFromBeginning);
        end;
      finally FreeAndNil(FDataChannel); end;
    end;
  finally
    DoStatus(ftpReady, [RSFTPStatusDoneTransfer]);
  end;
  // 226 = download successful, 225 = Abort successful}
  LResponse := GetResponse([225, 226, 250, 426, 450]);
  if (LResponse = 426) or (LResponse = 450) then begin
    // some servers respond with 226 on ABOR
    GetResponse([226, 225]);
    DoStatus(ftpAborted, [RSFTPStatusAbortTransfer]);
  end;
end;

procedure TIdFTP.InitDataChannel;
begin
  FDataChannel.SendBufferSize := SendBufferSize;
  FDataChannel.RecvBufferSize := RecvBufferSize;
  FDataChannel.OnWork := OnWork;
  FDataChannel.OnWorkBegin := OnWorkBegin;
  FDataChannel.OnWorkEnd := OnWorkEnd;
end;

procedure TIdFTP.Put(const ASource: TStream; const ADestFile: string = '';
 const AAppend: boolean = false);
begin
  if length(ADestFile) = 0 then begin
    InternalPut('STOU ' + ADestFile, ASource);  {Do not localize}
  end else if AAppend then begin
    InternalPut('APPE ' + ADestFile, ASource, false);  {Do not localize}
  end else begin
    InternalPut('STOR ' + ADestFile, ASource);  {Do not localize}
  end;
end;

procedure TIdFTP.Put(const ASourceFile: string; const ADestFile: string = '';
 const AAppend: boolean = false);
var
  LSourceStream: TFileStream;
begin
  LSourceStream := TFileStream.Create(ASourceFile, fmOpenRead or fmShareDenyNone); try
    Put(LSourceStream, ADestFile, AAppend);
  finally FreeAndNil(LSourceStream); end;
end;

procedure TIdFTP.SendPassive(var VIP: string; var VPort: integer);
var
  i,bLeft,bRight: integer;
  s: string;
begin
  SendCmd('PASV', 227);      {Do not translate}
  s := Trim(LastCmdResult.Text[0]);
  // Case 1 (Normal)
  // 227 Entering passive mode(100,1,1,1,23,45)
  bLeft := IndyPos('(', s);   {Do not translate}
  bRight := IndyPos(')', s);  {Do not translate}
  if (bLeft = 0) or (bRight = 0) then begin
    // Case 2
    // 227 Entering passive mode on 100,1,1,1,23,45
    bLeft := RPos(#32, s);
    s := Copy(s, bLeft + 1, Length(s) - bLeft);
  end else begin
    s := Copy(s, bLeft + 1, bRight - bLeft - 1);
  end;
  VIP := '';                 {Do not translate}
  for i := 1 to 4 do begin
    VIP := VIP + '.' + Fetch(s, ','); {Do not translate}
  end;
  System.Delete(VIP, 1, 1);
  // Determine port
  VPort := StrToInt(Fetch(s, ',')) shl 8;   {Do not translate}
  //use trim as one server sends something like this:
  //"227 Passive mode OK (195,92,195,164,4,99 )"
  VPort := VPort + StrToInt(Trim(Fetch(s, ','))); {Do not translate}
end;

procedure TIdFTP.Noop;
begin
  SendCmd('NOOP', 200);     {Do not translate}
end;

procedure TIdFTP.MakeDir(const ADirName: string);
begin
  SendCmd('MKD ' + ADirName, 257);  {Do not translate}
end;

function TIdFTP.RetrieveCurrentDir: string;
begin
  SendCmd('PWD', 257);              {Do not translate}
  Result := CleanDirName(LastCmdResult.Text[0]);
end;

procedure TIdFTP.RemoveDir(const ADirName: string);
begin
  SendCmd('RMD ' + ADirName, 250);  {Do not translate}
end;

procedure TIdFTP.Delete(const AFilename: string);
begin
  SendCmd('DELE ' + AFilename, 250);  {Do not translate}
end;

(*
CHANGE WORKING DIRECTORY (CWD)

  This command allows the user to work with a different
  directory or dataset for file storage or retrieval without
  altering his login or accounting information.  Transfer
  parameters are similarly unchanged.  The argument is a
  pathname specifying a directory or other system dependent
  file group designator.

CWD
  250
  500, 501, 502, 421, 530, 550
*)
procedure TIdFTP.ChangeDir(const ADirName: string);
begin
  SendCmd('CWD ' + ADirName, [200, 250]); //APR: Ericsson Switch FTP     {Do not translate}
end;

(*
CHANGE TO PARENT DIRECTORY (CDUP)

  This command is a special case of CWD, and is included to
  simplify the implementation of programs for transferring
  directory trees between operating systems having different
  syntaxes for naming the parent directory.  The reply codes
  shall be identical to the reply codes of CWD.  See
  Appendix II for further details.

CDUP
  200
  500, 501, 502, 421, 530, 550
*)
procedure TIdFTP.ChangeDirUp;
begin
  // RFC lists 200 as the proper response, but in another section says that it can return the
  // same as CWD, which expects 250. That is it contradicts itself.
  // MS in their infinite wisdom chnaged IIS 5 FTP to return 250.
  SendCmd('CDUP', [200, 250]);   {Do not translate}
end;

procedure TIdFTP.Site(const ACommand: string);
begin
  SendCmd('SITE ' + ACommand, 200);   {Do not translate}
end;

procedure TIdFTP.Rename(const ASourceFile, ADestFile: string);
begin
  SendCmd('RNFR ' + ASourceFile, 350);  {Do not translate}
  SendCmd('RNTO ' + ADestFile, 250);    {Do not translate}
end;

function TIdFTP.Size(const AFileName: String): Integer;
var
  SizeStr: String;
begin
  result := -1;
  if SendCmd('SIZE ' + AFileName) = 213 then begin  {Do not translate}
    SizeStr := Trim(LastCmdResult.Text.Text);
    system.delete(SizeStr, 1, IndyPos(' ', SizeStr)); // delete the response   {Do not translate}
    result := StrToIntDef(SizeStr, -1);
  end;
end;

//Added by SP
procedure TIdFTP.ReInitialize(ADelay: Cardinal = 10);
begin
  Sleep(ADelay); //Added
  if SendCmd('REIN', [120, 220, 500]) <> 500 then begin  {Do not translate}
    FLoginMsg.Clear;
    FCanResume := False;
    FDirectoryListing.Clear;
    FUsername := '';                 {Do not translate}
    FPassword := '';                 {Do not translate}
    FPassive := Id_TIdFTP_Passive;
    FCanResume := False;
    FResumeTested := False;
    FSystemDesc := '';
    FTransferType := Id_TIdFTP_TransferType;
  end;
end;

procedure TIdFTP.Allocate(AAllocateBytes: Integer);
begin
  SendCmd('ALLO ' + IntToStr(AAllocateBytes), [200]); {Do not translate}
end;

procedure TIdFTP.Status(var AStatusList: TStringList);
var
  LStrm: TStringStream;
  LList: TStringList;
begin
  if SendCmd('STAT', [211, 212, 213, 500]) <> 500 then   {Do not translate}
  begin
    if not Assigned(FDirectoryListing) then
    begin
      DoFTPList;
    end;
    LStrm := TStringStream.Create('');      {Do not translate}
    LList := TStringList.Create;
    //Read stream through control connection - not data channel
    ReadStream(LStrm, -1, True);
    LList.Text := LStrm.DataString;
    try
      try
        ConstructDirListing;
        FDirectoryListing.Clear;
      except
        on EAccessViolation do ConstructDirListing;
      end;
      // Parse directory listing
      if LList.Count > 0 then
      begin
        FDirectoryListing.ListFormat := FDirectoryListing.CheckListFormat(LList[0], True);
        DoCheckListFormat(LList[0]);
        FDirectoryListing.LoadList(LList);
      end;
    except
      if Assigned(AStatusList) = True then
      begin
        AStatusList.Text := LStrm.DataString;
      end;
    end;
    FreeAndNil(LStrm);
    FreeAndNil(LList);
  end;
end;

procedure TIdFTP.Help(var AHelpContents: TStringList; ACommand: String = ''); {Do not translate}
var
  LStrm: TStringStream;
begin
  LStrm := TStringStream.Create('');    {Do not translate}
  if SendCmd('HELP ' + ACommand, [211, 214, 500]) <> 500 then       {Do not translate}
  begin
    ReadStream(LStrm, -1, True);
    AHelpContents.Text := LStrm.DataString;
  end;
  FreeAndNil(LStrm);
end;

procedure TIdFTP.Account(AInfo: String);
begin
  SendCmd('ACCT ' + AInfo, [202, 230, 500]);   {Do not translate}
end;

procedure TIdFTP.StructureMount(APath: String);
begin
  SendCmd('SMNT ' + APath, [202, 250, 500]);  {Do not translate}
end;

procedure TIdFTP.FileStructure(AStructure: TIdFTPDataStructure);
var
  s: String;
begin
  case AStructure of
    dsFile: s := 'F';         {Do not translate}
    dsRecord: s := 'R';       {Do not translate}
    dsPage: s := 'P';         {Do not translate}
  end;
  SendCmd('STRU ' + s, [200, 500]);  {Do not translate}
  { TODO: Needs to be finished }
end;

procedure TIdFTP.TransferMode(ATransferMode: TIdFTPTransferMode);
var
  s: String;
begin
  case ATransferMode of
    dmBlock: begin
      s := 'B';                {Do not translate}
    end;
    dmCompressed: begin
      s := 'C';                {Do not translate}
    end;
    dmStream: begin
      s := 'S';                {Do not translate}
    end;
  end;
  SendCmd('MODE ' + s, [200, 500]);  {Do not translate}
  { TODO: Needs to be finished }
end;

destructor TIdFTP.Destroy;
begin
  FreeAndNil(FListResult);
  FreeAndNil(FLoginMsg);
  FreeAndNil(FDirectoryListing);
  FreeAndNIL(FProxySettings); //APR
  inherited Destroy;
end;

function TIdFTP.Quote(const ACommand: String): SmallInt;
begin
  result := SendCmd(ACommand);
end;

//APR 011216: ftp proxy support
// TODO: need help - "//?"
procedure TIdFTP.Login;
begin
  case ProxySettings.ProxyType of
  fpcmNone:
    begin
      if SendCmd('USER ' + FUserName, [230, 331]) = 331 then begin   {Do not translate}
        SendCmd('PASS ' + FPassword, 230);                           {Do not translate}
      end;
    end;//fpcmNone
  fpcmUserSite:
    begin
      if (Length(ProxySettings.UserName)>0) then begin
        if SendCmd('USER ' + ProxySettings.UserName, [230, 331]) = 331 then begin  {Do not translate}
          SendCmd('PASS ' + ProxySettings.Password, 230);             {Do not translate}
        end;
      end;//proxy login
      if SendCmd('USER ' + FUserName+'@'+FHost, [230, 331]) = 331 then begin     {Do not translate}
        SendCmd('PASS ' + FPassword, 230);                       {Do not translate}
      end;
    end;//fpcmUserSite
  fpcmSite:
    begin
      if (Length(ProxySettings.UserName)>0) then begin
        if SendCmd('USER ' + ProxySettings.UserName, [230, 331]) = 331 then begin  {Do not translate}
          SendCmd('PASS ' + ProxySettings.Password, 230);  {Do not translate}
        end;
      end;//proxy login
      SendCmd('SITE '+FHost);//? Server Reply? 220?
      if SendCmd('USER ' + FUserName, [230, 331]) = 331 then begin {Do not translate}
        SendCmd('PASS ' + FPassword, 230);    {Do not translate}
      end;
    end;//fpcmSite
  fpcmOpen:
    begin
      if (Length(ProxySettings.UserName)>0) then begin
        if SendCmd('USER ' + ProxySettings.UserName, [230, 331]) = 331 then begin   {Do not translate}
          SendCmd('PASS ' + ProxySettings.Password, 230);   {Do not translate}
        end;
      end;//proxy login
      SendCmd('OPEN '+FHost);//? Server Reply? 220?     {Do not translate}
      if SendCmd('USER ' + FUserName, [230, 331]) = 331 then begin  {Do not translate}
        SendCmd('PASS ' + FPassword, 230);         {Do not translate}
      end;
    end;//fpcmSite
  fpcmUserPass: //USER user@firewalluser@hostname / PASS pass@firewallpass
    begin
      if SendCmd(Format('USER %s@%s@%s',[FUserName,ProxySettings.UserName,FHost]), [230, 331])=331 then begin    {Do not translate}
        if Length(ProxySettings.Password)>0 then begin
          SendCmd('PASS '+FPassword+'@'+ProxySettings.Password, 230); {Do not translate}
        end
        else begin
          SendCmd('PASS '+FPassword, 230); {Do not translate}
        end;//if @
      end;
    end;//fpcmUserPass
  fpcmTransparent: //? +Host
    begin
      if (Length(ProxySettings.UserName)>0) then begin
        if SendCmd('USER ' + ProxySettings.UserName, [230, 331]) = 331 then begin    {Do not translate}
          SendCmd('PASS ' + ProxySettings.Password, 230);     {Do not translate}
        end;
      end;//proxy login
      if SendCmd('USER ' + FUserName, [230, 331]) = 331 then begin   {Do not translate}
        SendCmd('PASS ' + FPassword, 230);  {Do not translate}
      end;
    end;//fpcmTransparent
  fpcmHttpProxyWithFtp:
    begin
{GET ftp://XXX:[email protected]/ HTTP/1.0
Host: indy.nevrona.com
User-Agent: Mozilla/4.0 (compatible; Wincmd; Windows NT)
Proxy-Authorization: Basic B64EncodedUserPass==
Connection: close}
      raise EIdException.Create(RSSocksServerCommandError);
    end;//fpcmHttpProxyWithFtp
  end;//case
  FLoginMsg.Assign(LastCmdResult);
  SendTransferType;
End;//TIdFTP.Login

procedure TIdFTP.DoAfterLogin;
begin
  if Assigned(FOnAfterClientLogin) then begin
    OnAfterClientLogin(self);
  end;
end;

procedure TIdFTP.DoFTPList;
begin
  if Assigned(FOnCreateFTPList) then begin
    FOnCreateFTPList(self, FDirectoryListing);
  end;
end;

procedure TIdFTP.DoCheckListFormat(const ALine: String);
Var
  LListFormat: TIdFTPListFormat;
Begin
  if Assigned(FOnCheckListFormat) then begin //APR: User always right!
    LListFormat := FDirectoryListing.ListFormat; //APR: user MUST see Indy opinion
    OnCheckListFormat(Self, ALine, LListFormat);
    FDirectoryListing.ListFormat := LListFormat;
  end;
End;//TIdFTP.DoCheckListFormat

function TIdFTP.GetDirectoryListing: TIdFTPListItems;
begin
  if not Assigned(FDirectoryListing) then begin
    try
      ConstructDirListing;
    except
      on EAccessViolation do ConstructDirListing;
    end;
    // Parse directory listing
    if FListResult.Count > 0 then begin
      FDirectoryListing.ListFormat := FDirectoryListing.CheckListFormat(FListResult[0],TRUE);//APR: TRUE for IndyCheck, else always Unknown
      DoCheckListFormat(FListResult[0]);
      FDirectoryListing.LoadList(FListResult);
    end;
  end;
  Result := FDirectoryListing;
end;

procedure TIdFTP.SetOnParseCustomListFormat(const AValue: TIdOnParseCustomListFormat);
begin
  FOnParseCustomListFormat := AValue;
  if Assigned(FDirectoryListing) then begin
    FDirectoryListing.OnParseCustomListFormat := AValue;
  end;
end;

procedure TIdFTP.SetProxySettings(const Value: TIdFtpProxySettings);
Begin
  FProxySettings.Assign(Value);
End;//

{ TIdFtpProxySettings }

procedure TIdFtpProxySettings.Assign(Source: TPersistent);
Begin
  if Source is TIdFtpProxySettings then begin
    with TIdFtpProxySettings(Source) do begin
      SELF.FProxyType  := ProxyType;
      SELF.FHost := Host;
      SELF.FUserName := UserName;
      SELF.FPassword := Password;
      SELF.FPort := Port;
    end;
  end
  else begin
    inherited Assign(Source);
  end;
End;//


end.