clftp.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clFtp;

interface

{$I clVer.inc}
{$IFDEF DELPHI7}
  {$WARN UNSAFE_CODE OFF}
  {$WARN UNSAFE_TYPE OFF}
{$ENDIF}

uses
  SysUtils, Classes, clTcpClient, clUtils, clFtpUtils, SyncObjs, clSocket, clCert;

type
  TclDirectoryListingEvent = procedure(Sender: TObject; AFileInfo: TclFtpFileInfo;
    const Source: string) of object;

  TclCustomFtp = class(TclTcpCommandClient)
  private
    FPassiveMode: Boolean;
    FTransferMode: TclFtpTransferMode;
    FTransferStructure: TclFtpTransferStructure;
    FTransferType: TclFtpTransferType;
    FDataConnection: TclSyncConnection;
    FOnCustomFtpProxy : TNotifyEvent;
    FProxySettings: TclFtpProxySettings;
    FOnDirectoryListing: TclDirectoryListingEvent;
    FDataAccessor: TCriticalSection;
    FResourcePos: Int64;
    FDataProtection: Boolean;
    FResponsePos: Integer;
    procedure BeginAccess;
    procedure EndAccess;
    function GetCurrentDir: string;
    procedure SetPassiveMode(const Value: Boolean);
    procedure SetDataProtection(const Value: Boolean);
    procedure SetTransferMode(const Value: TclFtpTransferMode);
    procedure SetTransferStructure(const Value: TclFtpTransferStructure);
    procedure InternalGetData(const ACommand: string; ADestination: TStream;
      AMaxReadSize, ADataSize: Int64);
    procedure InternalPutData(const ACommand: string; ASource: TStream; AMaxWriteSize: Int64);
    procedure SetTransferParams;
    function ParseFileSize: Int64;
    procedure ParsePassiveModeResponse(var AHost: string; var ADataPort: Integer);
    procedure SetTransferType(const Value: TclFtpTransferType);
    procedure SetPositionIfNeed;
    procedure SetProxySettings(const Value: TclFtpProxySettings);
    function GetFtpHost: string;
    function GetLoginPassword: string;
    procedure ParseDirectoryListing(AList: TStrings);
    procedure DoDataProgress(Sender: TObject; ABytesProceed, ATotalBytes: Int64);
    procedure SetDataPortMode(const AServer: string; ADataPort: Integer);
    procedure SetDataPassiveMode(var AHost: string; var ADataPort: Integer);
    procedure InternalFxpOperation(const APutMethod, ASourceFile, ADestinationFile: string;
      ASourceSite, ADestinationSite: TclCustomFtp);
    function GetFileSizeIfNeed(const AFileName: string): Int64;
    procedure ClearResponse;
    procedure WaitingMultipleResponses(const AOkResponses: array of Integer);
  protected
    function GetDefaultPort: Integer; override;
    function GetResponseCode(const AResponse: string): Integer; override;
    procedure OpenConnection(const AServer: string; APort: Integer); override;
    procedure OpenSession; override;
    procedure CloseSession; override;
    procedure SetUseTLS(const Value: TclClientTlsMode); override;
    procedure InternalSendCommandSync(const ACommand: string;
      const AOkResponses: array of Integer); override;
    procedure InitDataConnection(AConnection: TclSyncConnection; ABytesToProceed, ADataSize: Int64); virtual;
    procedure DoCustomFtpProxy; dynamic;
    procedure DoDirectoryListing(AFileInfo: TclFtpFileInfo; const Source: string); dynamic;
    property TransferMode: TclFtpTransferMode read FTransferMode write SetTransferMode default tmStream;
    property TransferStructure: TclFtpTransferStructure read FTransferStructure
      write SetTransferStructure default tsFile;
    property PassiveMode: Boolean read FPassiveMode write SetPassiveMode default False;
    property TransferType: TclFtpTransferType read FTransferType write SetTransferType default ttBinary;
    property DataProtection: Boolean read FDataProtection write SetDataProtection default False;
    property ProxySettings: TclFtpProxySettings read FProxySettings write SetProxySettings;
    property OnCustomFtpProxy: TNotifyEvent read FOnCustomFtpProxy write FOnCustomFtpProxy;
    property OnDirectoryListing: TclDirectoryListingEvent read FOnDirectoryListing write FOnDirectoryListing;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy(); override;
    procedure StartTls; override;
    procedure GetList(AList: TStrings; const AParam: string = ''; ADetails: Boolean = True);
    procedure DirectoryListing(const AParam: string = '');
    procedure GetHelp(AHelp: TStrings; const ACommand: string = '');
    function GetFileSize(const AFileName: string): Int64;
    function FileExists(const AFileName: string): Boolean;

    procedure GetFile(const AFileName: string; ADestination: TStream); overload;
    procedure GetFile(const AFileName: string; ADestination: TStream; APosition, ASize: Int64); overload;
    procedure PutFile(const AFileName: string; ASource: TStream); overload;
    procedure PutFile(const AFileName: string; ASource: TStream; APosition, ASize: Int64); overload;
    procedure AppendFile(const AFileName: string; ASource: TStream);
    procedure PutUniqueFile(ASource: TStream);

    procedure FxpGetFile(const ASourceFile, ADestinationFile: string; ADestinationSite: TclCustomFtp);
    procedure FxpPutFile(const ASourceFile, ADestinationFile: string; ASourceSite: TclCustomFtp);
    procedure FxpAppendFile(const ASourceFile, ADestinationFile: string; ASourceSite: TclCustomFtp);
    procedure FxpPutUniqueFile(const ASourceFile: string; ASourceSite: TclCustomFtp);

    procedure Rename(const ACurrentName, ANewName: string);
    procedure Delete(const AFileName: string);
    procedure SetFilePermissions(const AFileName: string; AOwner, AGroup, AOther: TclFtpFilePermissions);
    procedure ChangeCurrentDir(const ANewDir: string);
    procedure ChangeToParentDir;
    procedure MakeDir(const ANewDir: string);
    procedure RemoveDir(const ADir: string);
    procedure Abort;
    procedure Noop;
    property DataAccessor: TCriticalSection read FDataAccessor write FDataAccessor;
    property CurrentDir: string read GetCurrentDir;
  end;

  TclFtp = class(TclCustomFtp)
  published
    property TransferMode;
    property TransferStructure;
    property PassiveMode;
    property TransferType;
    property DataProtection;
    property BatchSize;
    property UserName;
    property Password;
    property Server;
    property Port default cDefaultFtpPort;
    property TimeOut;
    property UseTLS;
    property CertificateFlags;
    property TLSFlags;
    property BitsPerSec;
    property ProxySettings;
    property OnChanged;
    property OnOpen;
    property OnClose;
    property OnGetCertificate;
    property OnVerifyServer;
    property OnSendCommand;
    property OnReceiveResponse;
    property OnProgress;
    property OnProgress64;
    property OnCustomFtpProxy;
    property OnDirectoryListing;
  end;

resourcestring
  cOnCustomFtpProxyRequired = 'OnCustomFtpProxy required but not assigned';
  
implementation

uses
  clTlsSocket{$IFDEF DEMO}, Forms, Windows{$ENDIF}{$IFDEF LOGGER}, clLogger{$ENDIF};

const
  Modes: array[TclFtpTransferMode] of string = ('B', 'C', 'S', 'Z');
  Structures: array[TclFtpTransferStructure] of string = ('F', 'R', 'P');
  TransferTypes: array[TclFtpTransferType] of string = ('A', 'I');

{ TclCustomFtp }

constructor TclCustomFtp.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FProxySettings := TclFtpProxySettings.Create();
  Port := cDefaultFtpPort;
  FTransferMode := tmStream;
  FTransferStructure := tsFile;
  FPassiveMode := False;
  FTransferType := ttBinary;
  FDataProtection := False;
end;

destructor TclCustomFtp.Destroy();
begin
  FProxySettings.Free();
  inherited Destroy();
end;

function TclCustomFtp.GetResponseCode(const AResponse: string): Integer;
begin
  if (Length(AResponse) > 3) and (AResponse[4] = '-') then
  begin
    Result := SOCKET_WAIT_RESPONSE;
  end else
  if (Length(AResponse) > 2) then
  begin
    Result := StrToIntDef(System.Copy(AResponse, 1, 3), SOCKET_WAIT_RESPONSE);
  end else
  begin
    Result := SOCKET_WAIT_RESPONSE;
  end;
end;

{$IFDEF DEMO}
{$IFNDEF IDEDEMO}
var
  IsDemoDisplayed: Boolean = False;
{$ENDIF}
{$ENDIF}

procedure TclCustomFtp.OpenConnection(const AServer: string; APort: Integer);
begin
  if ((ProxySettings.ProxyType <> ptNone) and (ProxySettings.Server <> '')) then
  begin
    inherited OpenConnection(ProxySettings.Server, ProxySettings.Port);
  end else
  begin
    inherited OpenConnection(AServer, APort);
  end;
end;

procedure TclCustomFtp.StartTls;
begin
  SendCommandSync('AUTH TLS', [234]);
  inherited StartTls();
end;

procedure TclCustomFtp.OpenSession;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsDemoDisplayed) and (not IsCertDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsDemoDisplayed := True;
    IsCertDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}

  WaitingResponse([220]);

  ExplicitStartTls();

  case ProxySettings.ProxyType of
    ptNone:
      begin
        SendCommandSync('USER %s', [230, 232, 331], [UserName]);
        if (LastResponseCode = 331) then
        begin
          SendCommandSync('PASS %s', [230], [Password]);
        end;
      end;
    ptUserSite:
      begin
        if (ProxySettings.UserName <> '') then
        begin
          SendCommandSync('USER %s', [230, 331], [ProxySettings.UserName]);
          if (LastResponseCode = 331) then
          begin
            SendCommandSync('PASS %s', [230], [ProxySettings.Password]);
          end;
        end;
        SendCommandSync('USER %s@%s', [230, 232, 331], [UserName, GetFtpHost()]);
        if (LastResponseCode = 331) then
        begin
          SendCommandSync('PASS %s', [230], [GetLoginPassword()]);
        end;
      end;
    ptSite:
      begin
        if (ProxySettings.UserName <> '') then
        begin
          SendCommandSync('USER %s', [230, 331], [ProxySettings.UserName]);
          if (LastResponseCode = 331) then
          begin
            SendCommandSync('PASS %s', [230], [ProxySettings.Password]);
          end;
        end;
        SendCommandSync('SITE %s', [220], [GetFtpHost()]);
        SendCommandSync('USER %s', [230, 232, 331], [UserName]);
        if (LastResponseCode = 331) then
        begin
          SendCommandSync('PASS %s', [230], [GetLoginPassword()]);
        end;
      end;
    ptOpen:
      begin
        if (ProxySettings.UserName <> '') then
        begin
          SendCommandSync('USER %s', [230, 331], [ProxySettings.UserName]);
          if (LastResponseCode = 331) then
          begin
            SendCommandSync('PASS %s', [230], [GetLoginPassword()]);
          end;
        end;
        SendCommandSync('OPEN %s', [220], [GetFtpHost()]);
        SendCommandSync('USER %s', [230, 232, 331], [UserName]);
        if (LastResponseCode = 331) then
        begin
          SendCommandSync('PASS %s', [230], [GetLoginPassword()]);
        end;
      end;
    ptUserPass:
      begin
        SendCommandSync('USER %s@%s@%s', [230, 232, 331], [UserName, ProxySettings.UserName, GetFtpHost()]);
        if (LastResponseCode = 331) then
        begin
          if (ProxySettings.Password <> '') then
          begin
            SendCommandSync('PASS %s@%s', [230], [GetLoginPassword(), ProxySettings.Password]);
          end else
          begin
             SendCommandSync('PASS %s', [230], [GetLoginPassword()]);
          end;
        end;
      end;
    ptTransparent:
      begin
        if (ProxySettings.UserName <> '') then
        begin
          SendCommandSync('USER %s', [230, 331], [ProxySettings.UserName]);
          if (LastResponseCode = 331) then
          begin
            SendCommandSync('PASS %s', [230], [ProxySettings.Password]);
          end;
        end;
        SendCommandSync('USER %s', [230, 232, 331], [UserName]);
        if (LastResponseCode = 331) then
        begin
          SendCommandSync('PASS %s', [230], [GetLoginPassword()]);
        end;
      end;
    ptCustomProxy:
      begin
        DoCustomFtpProxy();
      end;
  end;
end;

procedure TclCustomFtp.CloseSession;
begin
  SendSilentCommand('QUIT', [220, 221]);
end;

procedure TclCustomFtp.GetHelp(AHelp: TStrings; const ACommand: string);
begin
  SendCommandSync('HELP %s', [211, 214], [ACommand]);
  AHelp.Assign(Response);
  if (AHelp.Count > 0) and (System.Pos('HELP', AHelp[AHelp.Count - 1]) > 0) then
  begin
    AHelp.Delete(AHelp.Count - 1);
  end;
end;

procedure TclCustomFtp.ChangeCurrentDir(const ANewDir: string);