adftp.pas

Async Professional 4.04

{*********************************************************}
{*                    ADFTP.PAS 4.04                     *}
{*      Copyright (C) TurboPower Software 1996-2002      *}
{*                 All rights reserved.                  *}
{*********************************************************}

{Global defines potentially affecting this unit}
{$I AWDEFINE.INC}

{Options required for this unit}
{$G+,X+,F+,B-,J+}
{$C MOVEABLE,DEMANDLOAD,DISCARDABLE}

unit AdFtp;
  {-Delphi internet file transfer protocol (FTP) client component}

interface

uses
  WinTypes,
  WinProcs,
  Classes,
  Messages,
  SysUtils,
  Forms,
  OoMisc,
  AwUser,
  AdSocket,
  AdwUtil,
  AdWnPort,
  AdPort,
  AdPacket,
  AdExcept;                                                          

const {miscellaneous constants}
  MaxBuffer = 32768;
  MaxCmdStack = 32;

type {Ftp mode and status definitions}
  TFtpRetrieveMode  = (rmAppend, rmReplace, rmRestart);
  TFtpStoreMode     = (smAppend, smReplace, smUnique, smRestart);
  TFtpFileType      = (ftAscii, ftBinary);
  TFtpProcessState  = (psClosed, psLogin, psIdle, psDir, psGet, psPut, psRen,
                       psCmd, psMkDir);                                
  TFtpStatusCode    = (scClose, scOpen, scLogout, scLogin, scComplete,
                       scCurrentDir, scDataAvail, scProgress, scTransferOK,
                       scTimeout);
  TFtpLogCode       = (lcClose, lcOpen, lcLogout, lcLogin, lcDelete,
                       lcRename, lcReceive, lcStore, lcComplete,
                       lcRestart, lcTimeout, lcUserAbort);

type {Ftp event definitions}
  TFtpErrorEvent  = procedure(Sender : TObject;
                              ErrorCode : Integer;
                              ErrorText : PChar) of object;
  TFtpLogEvent    = procedure(Sender : TObject;
                              LogCode : TFtpLogCode) of object;
  TFtpReplyEvent  = procedure(Sender : TObject;
                              ReplyCode : Integer;
                              ReplyText : PChar) of object;
  TFtpStatusEvent = procedure(Sender : TObject;
                              StatusCode : TFtpStatusCode;
                              InfoText : PChar) of object;

type {forwards}
  TApdFtpLog = class;

  {custom ftp component}
  TApdCustomFtpClient = class(TApdCustomWinsockPort)
  protected {private}
    AbortXfer       : Boolean;
    CmdStack        : array[0..MaxCmdStack-1] of string;
    CmdsStacked     : Byte;
    DataName        : TSockAddrIn;
    DataSocket      : TSocket;
    hwndFtpEvent    : HWND;
    ReplyPacket     : TApdDataPacket;
    DataBuffer      : array[0..MaxBuffer] of Byte;
    ReplyBuffer     : array[0..MaxBuffer] of Char;
    ListenSocket    : TSocket;
    ListenName      : TSockAddrIn;
    LocalStream     : TFileStream;
    MultiLine       : Boolean;
    MultiLineTerm   : string;
    NoEvents        : Boolean;
    ProcessState    : TFtpProcessState;
    Sock            : TApdSocket;
    Timer           : Integer;

  protected {property variables}
    FAccount          : string;
    FBytesTransferred : Longint;
    FConnectTimeout   : Integer;
    FFileLength       : Longint;
    FFileType         : TFtpFileType;
    FFtpLog           : TApdFtpLog;
    FLocalFile        : string;
    FPassword         : string;
    FPassiveMode      : Boolean;
    FTransferTimeout  : Integer;
    FRemoteFile       : string;
    FRestartAt        : Longint;
    FReplyCode        : Integer;
    FUserLoggedIn     : Boolean;
    FUserName         : string;

  protected {event variables}
    FOnFtpError        : TFtpErrorEvent;
    FOnFtpStatus       : TFtpStatusEvent;
    FOnFtpConnected    : TNotifyEvent;
    FOnFtpDisconnected : TNotifyEvent;
    FOnFtpLog          : TFtpLogEvent;
    FOnFtpReply        : TFtpReplyEvent;

  protected {methods}
    procedure ChangeState(NewState : TFtpProcessState);
    function  DataConnect : Boolean;
    procedure DataConnectPASV(IP : string);
    procedure DataDisconnect(FlushBuffer : Boolean);
    procedure DataShutDown;
    procedure DoConnect; override;
    procedure DoDisconnect; override;
    procedure FtpEventHandler(var Msg : TMessage);
    procedure FtpReplyHandler(ReplyCode : Integer; PData : PChar);
    function  GetConnected : Boolean;
    function  GetData : Integer;
    function  GetInProgress : Boolean;
    procedure Notification(AComponent : TComponent;
                           Operation : TOperation); override;
    function  PopCommand : string;
    procedure PostError(Code : Integer; Info : PChar);
    procedure PostLog(Code : TFtpLogCode);
    procedure PostStatus(Code : TFtpStatusCode; Info : PChar);
    procedure PushCommand(const Cmd : string);
    function  PutData : Integer;
    procedure ReplyPacketHandler(Sender : TObject; Data : string);
    procedure ResetTimer;
    procedure SendCommand(const Cmd : string);
    procedure SetFtpLog(const NewLog : TApdFtpLog);
    procedure StartTimer;
    procedure StopTimer;
    procedure TimerTrigger(Msg, wParam : Cardinal; lParam : Longint);
    procedure WsDataAccept(Sender : TObject; Socket : TSocket);
    procedure WsDataDisconnect(Sender : TObject; Socket : TSocket);
    procedure WsDataError(Sender : TObject; Socket : TSocket; ErrorCode : Integer);
    procedure WsDataRead(Sender : TObject; Socket : TSocket);
    procedure WsDataWrite(Sender : TObject; Socket : TSocket);

  protected {properties}
    property Account  : string
      read FAccount write FAccount;
    property ConnectTimeout : Integer
      read FConnectTimeout write FConnectTimeout;
    property FileType : TFtpFileType
      read FFileType write FFileType;
    property FtpLog : TApdFtpLog
      read FFtpLog write SetFtpLog;
    property Password : string
      read FPassword write FPassword;
    property PassiveMode : Boolean
      read FPassiveMode write FPassiveMode;
    property ServerAddress : string
      read FWsAddress write SetWsAddress;
    property TransferTimeout : Integer
      read FTransferTimeout write FTransferTimeout;
    property UserName : string
      read FUserName write FUserName;
  protected {events}
    property OnFtpError : TFtpErrorEvent
      read FOnFtpError write FOnFtpError;
    property OnFtpLog : TFtpLogEvent
      read FOnFtpLog write FOnFtpLog;
    property OnFtpReply : TFtpReplyEvent
      read FOnFtpReply write FOnFtpReply;
    property OnFtpStatus : TFtpStatusEvent
      read FOnFtpStatus write FOnFtpStatus;

  public {run-time properties}
    property BytesTransferred : Longint
      read FBytesTransferred;
    property Connected : Boolean
      read GetConnected;
    property InProgress : Boolean
      read GetInProgress;
    property FileLength : Longint
      read FFileLength;
    property ReplyCode : Integer
      read FReplyCode;
    property RestartAt : Longint
      read FRestartAt write FRestartAt;
    property UserLoggedIn : Boolean
      read FUserLoggedIn;

  public {methods}
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function  Abort : Boolean;
    function  ChangeDir(const RemotePathName : string) : Boolean;
    function  CurrentDir : Boolean;
    function  Delete(const RemotePathName : string) : Boolean;
    function  ListDir(const RemotePathName : string;
                      FullList : Boolean) : Boolean;
    function  Help(const Command : string) : Boolean;
    function  Login : Boolean;
    function  Logout : Boolean;
    function  MakeDir(const RemotePathName : string) : Boolean;
    function  RemoveDir (const RemotePathName : string) : Boolean;     
    function  Rename(const RemotePathName, NewPathName : string) : Boolean;
    function  Retrieve(const RemotePathName, LocalPathName : string;
                       RetrieveMode : TFtpRetrieveMode) : Boolean;
    function  SendFtpCommand(const FtpCmd : string) : Boolean;
    function  Status(const RemotePathName : string) : Boolean;
    function  Store(const RemotePathName, LocalPathName : string;
                    StoreMode : TFtpStoreMode) : Boolean;
  end;


  {FtpLog component}
  TApdFtpLog = class(TApdBaseComponent)
  protected {properties}
    FEnabled        : Boolean;
    FFtpHistoryName : string;
    FFtpClient      : TApdCustomFtpClient;

  protected {methods}
    procedure Notification(AComponent : TComponent;
                           Operation: TOperation); override;

  public {methods}
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure UpdateLog(const LogCode : TFtpLogCode); virtual;

  published {properties}
    property Enabled : Boolean
      read FEnabled write FEnabled;
    property FtpHistoryName : string
      read FFtpHistoryName write FFtpHistoryName;
    property FtpClient : TApdCustomFtpClient
      read FFtpClient write FFtpClient;
  end;


  {Ftp component}
  TApdFtpClient = class(TApdCustomFtpClient)
  published {properties}
    property Account;
    property ConnectTimeout;
    property FileType;
    property FtpLog;
    property Password;
    property PassiveMode;                                            
    property ServerAddress;
    property TransferTimeout;
    property UserName;
             {events}
    property OnFtpError;
    property OnFtpLog;
    property OnFtpReply;
    property OnFtpStatus;
             {inherited properties}
    property Logging;
    property LogSize;
    property LogName;
    property LogHex;
    property Tracing;
    property TraceSize;
    property TraceName;
    property TraceHex;
    property WsPort;
             {inherited events}
    property OnWsError;                                             
  end;


implementation

{$IFDEF TRIALRUN}
  {$I TRIAL07.INC}
  {$I TRIAL03.INC}
  {$I TRIAL01.INC}
{$ENDIF}

const {file data type constants}
  TypeChar  : array[TFtpFileType] of Char = ('A', 'I');

const {FTP commands}
  fcABOR = 'ABOR';
  fcACCT = 'ACCT';
  fcALLO = 'ALLO';
  fcAPPE = 'APPE';
  fcCDUP = 'CDUP';
  fcCWD  = 'CWD';
  fcDELE = 'DELE';
  fcHELP = 'HELP';
  fcLIST = 'LIST';
  fcMKD  = 'MKD';
  fcMODE = 'MODE';
  fcNLST = 'NLST';
  fcNOOP = 'NOOP';
  fcPASS = 'PASS';
  fcPASV = 'PASV';
  fcPORT = 'PORT';
  fcPWD  = 'PWD';
  fcQUIT = 'QUIT';
  fcREIN = 'REIN';
  fcREST = 'REST';
  fcRETR = 'RETR';
  fcRMD  = 'RMD';
  fcRNFR = 'RNFR';
  fcRNTO = 'RNTO';
  fcSITE = 'SITE';
  fcSIZE = 'SIZE';
  fcSMNT = 'SMNT';
  fcSTAT = 'STAT';
  fcSTOR = 'STOR';
  fcSTOU = 'STOU';
  fcSTRU = 'STRU';
  fcSYST = 'SYST';
  fcTYPE = 'TYPE';
  fcUSER = 'USER';

type {miscellaneous types}
  wParam = Longint;
  lParam = Longint;

const {miscellaneous constants}
  SockNameSize : Integer = SizeOf(TSockAddrIn);
  CRLF = #13 + #10;
  DefFtpHistoryName = 'APROFTP.HIS';
  DefServicePort = 'ftp';
  tmConnectTimer = 1;                                                
  ecFtpConnectTimeout = -1;                                          
  DefTransferTimeout = 1092;                                         

  CM_APDFTPEVENT = CM_APDSOCKETQUIT + 10;                            
  FtpErrorMsg    = CM_APDFTPEVENT + 1;
  FtpLogMsg      = CM_APDFTPEVENT + 2;
  FtpReplyMsg    = CM_APDFTPEVENT + 3;
  FtpStatusMsg   = CM_APDFTPEVENT + 4;
  FtpTimeoutMsg  = CM_APDFTPEVENT + 5;


{.$DEFINE Debugging}
{$IFDEF Debugging}
const
  DebugLogFile = '\FtpLog.Txt';

procedure DebugTxt(const aStr : string);
var
  F : TextFile;
  S : string;
begin
  try
    AssignFile(F, DebugLogFile);
    Append(F);
  except
    on E : EInOutError do
      if (E.ErrorCode = 2) or (E.ErrorCode = 32) then
        Rewrite(F)
      else
        raise;
  end;

  S := DateTimeToStr(Now) + ' : ' + aStr;
  WriteLn(F, S);
  Close(F);
  if IOResult <> 0 then ;
end;
{$ENDIF}




{ TApdCustomFtpClient }
constructor TApdCustomFtpClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPassiveMode := False;                                             
  FDeviceLayer := dlWinsock;
  FWsMode := wsClient;
  FWsPort := DefServicePort;
  AutoOpen := False;
  UseEventWord := False;
  hwndFtpEvent := AllocateHWnd(FtpEventHandler);
  Sock := TApdSocket.Create(Self);
  Sock.OnWsAccept := WsDataAccept;
  Sock.OnWsDisconnect := WsDataDisconnect;
  Sock.OnWsError := WsDataError;
  Sock.OnWsRead := WsDataRead;
  Sock.OnWsWrite := WsDataWrite;
  ListenSocket := Invalid_Socket;
  DataSocket := Invalid_Socket;
  ProcessState := psClosed;
  FTransferTimeout := DefTransferTimeout;
  FConnectTimeout := 0;                                              
  FUserLoggedIn := False;
  FFileType := ftBinary;
  MultiLine := False;
  ReplyPacket := TApdDataPacket.Create(self);
  ReplyPacket.ComPort := Self;
  ReplyPacket.StartCond := scAnyData;
  ReplyPacket.EndString := CRLF;
  ReplyPacket.EndCond := [ecString];
  ReplyPacket.Timeout := 0;                                          
  ReplyPacket.OnStringPacket := ReplyPacketHandler;
  ReplyPacket.Enabled := False;
{$IFDEF Debugging}
  if FileExists(DebugLogFile) then
    DeleteFile(DebugLogFile);
  FileClose(FileCreate(DebugLogFile));
{$ENDIF}
end;

destructor TApdCustomFtpClient.Destroy;
begin
  ReplyPacket.Free;
  NoEvents := True;
  DataShutDown;
  Open := False;
  {$IFDEF APAX}                                                          {!!.04}
  DelayTicks (4, True);
  {$ENDIF}                                                               {!!.04}
  if (hwndFtpEvent <> 0) then
    DeallocateHWnd(hwndFtpEvent);
  Sock.Free;
  inherited Destroy;
end;

function TApdCustomFtpClient.Abort : Boolean;
  {terminate file transfer in progress}
begin
  Result := (ProcessState > psIdle);
  if Result then begin
    AbortXfer := True;
    SendCommand(fcABOR);
    PostLog(lcUserAbort);
  end;
end;

function TApdCustomFtpClient.ChangeDir(const RemotePathName : string) : Boolean;
  {change the current working directory}
begin
  Result := (ProcessState = psIdle);
  if Result then begin
    ChangeState(psCmd);
    if (RemotePathName <> '') then
      SendCommand(fcCWD + ' ' + RemotePathName)
    else
      SendCommand(fcPWD);
  end;
end;

function TApdCustomFtpClient.CurrentDir : Boolean;
  {get the name of the current working directory}
begin
  Result := (ProcessState = psIdle);
  if Result then begin
    ChangeState(psCmd);
    SendCommand(fcPWD);
  end;
end;

function TApdCustomFtpClient.Delete(const RemotePathName : string) : Boolean;
  {delete specified remote file or directory}
begin
  Result := (ProcessState = psIdle) and (RemotePathName <> '');
  if Result then begin
    ChangeState(psCmd);
    FRemoteFile := RemotePathName;
    SendCommand(fcDELE + ' ' + RemotePathName);
    PostLog(lcDelete);
  end;
end;