adftp.pas

Async Professional 4.04

function TApdCustomFtpClient.Help(const Command : string) : Boolean;
  {Obtain help for the specified Ftp command}
var
  Cmd : string;
begin
  Result := (ProcessState = psIdle);
  if Result then begin
    ChangeState(psCmd);
    Cmd := fcHELP;
    if (Command <> '') then
      Cmd := Cmd + ' ' + Command;
    SendCommand(Cmd);
  end;
end;

function TApdCustomFtpClient.ListDir(const RemotePathName : string;
                                     FullList : Boolean) : Boolean;
  {list contents of remote directory}
var
  S : string;
begin
  Result := (ProcessState = psIdle);
  if Result then begin
    ChangeState(psDir);
    if FullList then
      S := fcLIST
    else
      S := fcNLST;
    if (RemotePathName <> '') then
      S := S + ' ' + RemotePathName;
    PushCommand(S);
    FillChar(DataBuffer, SizeOf(DataBuffer), #0);
    FBytesTransferred := 0;
    if PassiveMode then                                            
      PushCommand(fcPASV);                                         
    PushCommand(fcType + ' ' + TypeChar[ftAscii]);
    Result := DataConnect;                                         
  end;
end;

function TApdCustomFtpClient.MakeDir(const RemotePathName : string) : Boolean;
  {create specified remote directory}
begin
  Result := (ProcessState = psIdle);
  if Result then begin
    ChangeState(psMkDir);                                              
    SendCommand(fcMKD + ' ' + RemotePathName);
  end;
end;

function TApdCustomFtpClient.RemoveDir (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(fcRMD + ' ' + RemotePathName);                         
    PostLog(lcDelete);                                                 
  end;                                                                 
end;                                                                   

function TApdCustomFtpClient.Rename(const RemotePathName, NewPathName : string) : Boolean;
  {rename specified remote file or directory}
begin
  Result := (ProcessState = psIdle) and
            (RemotePathName <> '') and (NewPathName <> '');
  if Result then begin
    ChangeState(psRen);
    PushCommand(fcRNTO + ' ' + NewPathName);
    FRemoteFile := RemotePathName;
    PostLog(lcRename);
    SendCommand(fcRNFR + ' ' + RemotePathName);
  end;
end;

function TApdCustomFtpClient.Retrieve(const RemotePathName, LocalPathName : string;
                                      RetrieveMode : TFtpRetrieveMode) : Boolean;
  {transfer a file from the server}
var
  FH : Integer;
begin
  Result := (ProcessState = psIdle) and
            (RemotePathName <> '') and (LocalPathName <> '');
  if Result then begin
    ChangeState(psGet);
    PushCommand(fcRETR + ' ' + RemotePathName);
    FRemoteFile := RemotePathName;
    FLocalFile := LocalPathName;
    if not FileExists(LocalPathName) then begin
      FH := FileCreate(LocalPathName);
      FileClose(FH);
    end;
    if (RetrieveMode = rmReplace) then begin
      DeleteFile(LocalPathName);                                         {!!.04}
      LocalStream := TFileStream.Create(LocalPathName, fmCreate);        {!!.04}
      LocalStream.Position := 0;
      PostLog(lcReceive);
    end else if (RetrieveMode = rmAppend) then begin
      LocalStream := TFileStream.Create(LocalPathName, fmOpenReadWrite);
      LocalStream.Position := LocalStream.Size;
      PostLog(lcReceive);
    end else begin {RetrieveMode = rmRestart}
      LocalStream := TFileStream.Create(LocalPathName, fmOpenReadWrite);
      if (FRestartAt > LocalStream.Size) or (FRestartAt < 0) then
        FRestartAt := LocalStream.Size;
      LocalStream.Position := FRestartAt;
      PushCommand(fcREST + ' ' + IntToStr(FRestartAt));
      PostLog(lcRestart);
    end;
    FBytesTransferred := 0;
    AbortXfer := False;
    if PassiveMode then                                           
      PushCommand(fcPASV);                                        
    PushCommand(fcType + ' ' + TypeChar[FFileType]);
    Result := DataConnect;                                        
  end;
end;

function TApdCustomFtpClient.SendFtpCommand(const FtpCmd : string) : Boolean;
  {send any FTP command}
begin
  Result := (ProcessState = psIdle);
  if Result then begin
    ChangeState(psCmd);
    SendCommand(FtpCmd);
  end;
end;

function TApdCustomFtpClient.Status(const RemotePathName : string) : Boolean;
  {obtain status of server or optional directory listing}
var
  Cmd : string;
begin
  Result := (ProcessState = psIdle);
  if Result then begin
    ChangeState(psCmd);
    Cmd := fcSTAT;
    if (RemotePathName <> '') then
      Cmd := Cmd + ' ' + RemotePathName;
    SendCommand(Cmd);
  end;
end;

function TApdCustomFtpClient.Store(const RemotePathName, LocalPathName : string;
                                   StoreMode : TFtpStoreMode) : Boolean;
  {transfer a file to the server}
begin
  Result := (ProcessState = psIdle) and
            (RemotePathName <> '') and FileExists(LocalPathName);
  if Result then begin
    ChangeState(psPut);
    FRemoteFile := RemotePathName;
    FLocalFile := LocalPathName;
    if Assigned(LocalStream) then
      LocalStream.Free;
    LocalStream := TFileStream.Create(LocalPathName, fmOpenRead);
    FFileLength := LocalStream.Size;
    LocalStream.Position := 0;
    if (StoreMode = smAppend) then begin
      PushCommand(fcAPPE + ' ' + RemotePathName);
      PostLog(lcStore);
    end else if (StoreMode = smReplace) then begin
      PushCommand(fcSTOR + ' ' + RemotePathName);
      PostLog(lcStore);
    end else if (StoreMode = smUnique) then begin
      PushCommand(fcSTOU + ' ' + RemotePathName);
      PostLog(lcStore);
    end else begin {StoreMode = smReplace}
      if (FRestartAt > LocalStream.Size) or (FRestartAt < 0) then
        FRestartAt := 0;
      LocalStream.Position := FRestartAt;
      PushCommand(fcSTOR + ' ' + RemotePathName);
      PushCommand(fcREST + ' ' + IntToStr(FRestartAt));
      PostLog(lcRestart);
    end;
    FBytesTransferred := 0;
    AbortXfer := False;
    if PassiveMode then                                           
      PushCommand(fcPASV);                                        
    PushCommand(fcType + ' ' + TypeChar[FFileType]);
    Result := DataConnect;                                      
  end;
end;

function TApdCustomFtpClient.Login : Boolean;
  {log on to ftp server}
{$IFDEF TRIALRUN}
  {$I TRIAL04.INC}
{$ENDIF}
begin
{$IFDEF TRIALRUN}
  TC;
{$ENDIF}
  Result := (ProcessState in [psClosed, psLogin]);
  if Result then begin
    if (FConnectTimeout > 0) then                                        
      SetTimer(hwndFtpEvent, tmConnectTimer, FConnectTimeout * 55, nil); 
    if ProcessState = psClosed then begin
      { port is closed, connect and log in normally }
      try                                                                {!!.02}
        Open := True;
      except                                                             {!!.02}
        { if we got an exception here, the destination address was invalid }
        { if an OnWsError event is around, we'll let that notify the app;  }
        { if it's not there, then we'll let the exception do the notifying }
        if not Assigned(FOnWsError) then                                 {!!.02}
          raise;                                                         {!!.02}
      end;                                                               {!!.02}
      Result := Open;
    end else begin                                                     
      { port is already open, must be trying to re-log in }
      SendCommand(fcUSER + ' ' + FUserName);                           
    end;                                                               
    ChangeState(psLogin);
  end;                                                                 
end;

function TApdCustomFtpClient.Logout : Boolean;
  {log off of ftp server}
begin
  Result := (Open = True);
  if Result then
    //SendCommand(fcQUIT);
    PutString(fcQuit + CRLF);
  while Open do                                                          {!!.02}
    DelayTicks(2, True);                                                 {!!.02}
end;

procedure TApdCustomFtpClient.ChangeState(NewState : TFtpProcessState);
  {change state variables, fire events, and cleanup as necessary}
begin
  case NewState of
    psClosed :
      begin
        StopTimer;
        ReplyPacket.Enabled := False;                                    {!!.02}
        DataShutDown;
        Open := False;
        FUserLoggedIn := False;
        CmdsStacked := 0;
        if (ProcessState > psLogin) then begin
          PostStatus(scLogout, nil);
          PostLog(lcLogout);
        end else
          PostStatus(scClose, nil);
      end;
    psIdle : DataDisconnect(True);
    end;
  ProcessState := NewState;
end;

procedure TApdCustomFtpClient.DataConnectPASV(IP : string);          
  {establish a data connection to specified IP}
var
  DataSocketName : TSockAddrIn;
  wPort : Word;
  strPort : string;
  strPortHi : string;
  strPortLo : string;
  strAddr : string;
  i, j : Integer;
begin
  if not Assigned(Sock) then
    Exit;
  strAddr := IP;
  strPortHi := '';
  strPortLo := '';
  for i := 1 to 3 do
    if Pos(',', strAddr) > 0 then
      strAddr[Pos(',', strAddr)]  := '.';
  i := Pos(',', strAddr);
  if (i > 0) then begin
    strPort := Copy(strAddr, i+1, Length(strAddr));
    System.Delete(strAddr, i, Length(strAddr));
    j := Pos(',', strPort);
    strPortHi := Copy(strPort, 1, j - 1);
    strPortLo := Copy(strPort, j + 1, Length(strPort));
  end;
  wPort := (StrToIntDef(strPortHi, 0) shl 8) + StrToIntDef(strPortLo, 0);
  with DataSocketName do begin
    sin_family := AF_INET;
    sin_addr := Sock.String2NetAddr(strAddr);
    sin_port := Sock.htons(wPort);
  end;
  Sock.ConnectSocket(DataSocket, DataSocketName);
end;

function TApdCustomFtpClient.DataConnect : Boolean;
  {establish a data connection}
var
  LocalIP : string;
begin
  Result := False;
  try
    if PassiveMode then begin                                            
      DataSocket := Sock.CreateSocket;                                   
      Result := (DataSocket <> Invalid_Socket);                          
      Sock.SetAsyncStyles(DataSocket, FD_CLOSE or FD_READ or FD_WRITE);  
      SendCommand(PopCommand);                                           
    end else begin                                                       
      if (SockFuncs.GetSockName(Dispatcher.ComHandle, ListenName, SockNameSize) = 0) then begin
        if (ListenSocket = Invalid_Socket) then
          ListenSocket := Sock.CreateSocket;
        if (ListenSocket <> Invalid_Socket) then begin
          Sock.SetAsyncStyles(ListenSocket, FD_ACCEPT or FD_CLOSE or FD_READ or FD_WRITE);
          ListenName.sin_family := AF_INET;
          ListenName.sin_port := Sock.htons(0);
          if (Sock.BindSocket(ListenSocket, ListenName) = 0) then
            if (SockFuncs.GetSockName(ListenSocket, ListenName, SockNameSize) = 0) then begin
              with ListenName do
                LocalIP := Sock.NetAddr2String(sin_addr) + '.' +
                  IntToStr(Lo(sin_port)) + '.' + IntToStr(Hi(sin_port));
              while Pos('.', LocalIP) > 0 do
                LocalIP[Pos('.', LocalIP)]  := ',';
              SendCommand(fcPORT + ' ' + LocalIP);
              if (Sock.ListenSocket(ListenSocket, 5) = 0) then
                Result := True;
            end;
        end;
      end;
    end;
  except
    DataShutDown;
    CmdsStacked := 0;                                                
  end;
end;

procedure TApdCustomFtpClient.DataDisconnect(FlushBuffer : Boolean);
  {retrieve any remaining data and close the data connection}
begin
  try
    if (DataSocket <> Invalid_Socket) then begin
      Sock.SetAsyncStyles(DataSocket, 0);
      Sock.ShutdownSocket(DataSocket, SD_Send);
      if (ProcessState = psDir) or (ProcessState = psGet) then
        if FlushBuffer then
          repeat until (GetData <= 0);
      Sock.ShutdownSocket(DataSocket, SD_Both);
    end;
  finally
    DataShutDown;
  end;
end;

procedure TApdCustomFtpClient.DataShutDown;
  {shutdown data connection}
begin
  try
    if (DataSocket <> Invalid_Socket) then
      Sock.CloseSocket(DataSocket);
  except
  end;
  try
    if (ListenSocket <> Invalid_Socket) then
      Sock.CloseSocket(ListenSocket);
  except
  end;
  ListenSocket := Invalid_Socket;
  DataSocket := Invalid_Socket;
  if Assigned(LocalStream) then
    LocalStream.Free;
  LocalStream := nil;
  FFileLength := 0;
end;

procedure TApdCustomFtpClient.DoConnect;
  {control connection now established}
begin
  KillTimer(hwndFtpEvent, tmConnectTimer);                           
  ReplyPacket.Enabled := True;
  Dispatcher.RegisterEventTriggerHandler(TimerTrigger);
  ChangeState(psLogin);
end;

procedure TApdCustomFtpClient.DoDisconnect;
  {control connection now closed}
begin
  KillTimer(hwndFtpEvent, tmConnectTimer);
  if Assigned(Dispatcher) then                                           {!!.02}
    Dispatcher.DeRegisterEventTriggerHandler(TimerTrigger);
  ReplyPacket.Enabled := False;
  ChangeState(psClosed);
end;

procedure TApdCustomFtpClient.FtpEventHandler(var Msg : TMessage);
  {message handler to decouple events from the control connection}
var
  PInfo : PChar;
begin
  PInfo := Pointer(Msg.lParam);
  case Msg.Msg of

    WM_TIMER :
      begin                                                          
        ChangeState(psClosed);
        KillTimer(hwndFtpEvent, tmConnectTimer);
        if Assigned(FOnFtpError) then
          FOnFtpError(Self, ecFtpConnectTimeout, nil);
      end;

    FtpErrorMsg :
      if Assigned(FOnFtpError) then
        FOnFtpError(Self, Msg.wParam, PInfo);

    FtpLogMsg :
      if Assigned(FFtpLog) then
        TApdFtpLog(FFtpLog).UpdateLog(TFtpLogCode(Msg.wParam))
      else if Assigned(FOnFtpLog) then
        FOnFtpLog(Self, TFtpLogCode(Msg.wParam));

    FtpReplyMsg :
      begin
        FtpReplyHandler(Msg.wParam, PInfo);
        if Assigned(FOnFtpReply) and (not NoEvents) then
          FOnFtpReply(Self, Msg.wParam, PInfo);
      end;

    FtpStatusMsg :
      if Assigned(FOnFtpStatus) then
        FOnFtpStatus(Self, TFtpStatusCode(Msg.wParam), PInfo);

    FtpTimeoutMsg :
      begin
        AbortXfer := True;
        if (ProcessState > psLogin) then
          ChangeState(psIdle)
        else
          ChangeState(psClosed);
        if Assigned(FOnFtpStatus) then
          FOnFtpStatus(Self, TFtpStatusCode(Msg.wParam), PInfo);
      end;
  else
    Exit;
  end; {case}

  if Assigned(PInfo) then
    StrDispose(PInfo);
end;

procedure TApdCustomFtpClient.FtpReplyHandler(ReplyCode : Integer; PData : PChar);
  { Server reply handler - state machine }
var
  S : string;
  PReply : PChar;

  procedure Error(Code : Integer; PInfo : PChar);
  begin
    CmdsStacked := 0;
    case Code of
      221, 421 : ChangeState(psClosed);
    else
      PostError(Code, PInfo);
    end;
  end;

begin
  if not MultiLine then begin
    FillChar(ReplyBuffer, SizeOf(ReplyBuffer), #0);
    StrCopy(ReplyBuffer, PData);
    if (PData[3] = '-') then begin
      MultiLine := True;
      MultiLineTerm := IntToStr(ReplyCode) + ' ';
      Exit;
    end;
  end else begin
    if (Pos(MultiLineTerm, StrPas(PData)) <> 1) then begin
      StrCat(ReplyBuffer, PData);
      Exit;
    end else
      MultiLine := False
  end;
  PReply := ReplyBuffer;