idftp.pas

Indy控件的使用源代码

{ $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.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;
    FDirectoryListing: TIdFTPListItems;
    FOnAfterClientLogin: TNotifyEvent;
    FOnCreateFTPList: TIdCreateFTPList;
    FOnCheckListFormat: TIdCheckListFormat;
    FOnAfterGet: TIdFtpAfterGet; //APR
    FProxySettings: TIdFtpProxySettings;
    //
    procedure ConstructDirListing;
    procedure DoAfterLogin;
    procedure DoFTPList;
    procedure DoCheckListFormat(const ALine: String);
    function GetDirectoryListing: TIdFTPListItems;
    function GetOnParseCustomListFormat: TIdOnParseCustomListFormat;
    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 Passive: boolean read FPassive write FPassive default Id_TIdFTP_Passive;
    property Password;
    property TransferType: TIdFTPTransferType read FTransferType write SetTransferType default Id_TIdFTP_TransferType;
    property Username;
    property Port default IDPORT_FTP;
    property ProxySettings: TIdFtpProxySettings read FProxySettings write SetProxySettings;

    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 GetOnParseCustomListFormat
     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;
  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, fmOpenWrite);
        LDestStream.Seek(0, soFromEnd);
      end
      else begin
        raise EIdFTPFileAlreadyExists.Create(RSDestinationFileAlreadyExists);
      end;
    end;
  end
  else begin
    LDestStream := TFileStream.Create(ADestFile, fmCreate);