src/synapse/ftpsend.pas

{==============================================================================|
| Project : Ararat Synapse                                       | 004.000.000 |
|==============================================================================|
| Content: FTP client                                                          |
|==============================================================================|
| Copyright (c)1999-2011, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010.               |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|   Petr Esner <petr.esner@atlas.cz>                                           |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

{: @abstract(FTP client protocol)

Used RFC: RFC-959, RFC-2228, RFC-2428
}

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$H+}
{$TYPEINFO ON}// Borland changed defualt Visibility from Public to Published
                // and it requires RTTI to be generated $M+
{$M+}

{$IFDEF UNICODE}
  {$WARN IMPLICIT_STRING_CAST OFF}
  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}

unit ftpsend;

interface

uses
  SysUtils, Classes,
  blcksock, synautil, synaip, synsock;

const
  cFtpProtocol = '21';
  cFtpDataProtocol = '20';

  {:Terminating value for TLogonActions}
  FTP_OK = 255;
  {:Terminating value for TLogonActions}
  FTP_ERR = 254;

type
  {:Array for holding definition of logon sequence.}
  TLogonActions = array [0..17] of byte;

  {:Procedural type for OnStatus event. Sender is calling @link(TFTPSend) object.
   Value is FTP command or reply to this comand. (if it is reply, Response
   is @True).}
  TFTPStatus = procedure(Sender: TObject; Response: Boolean;
    const Value: string) of object;

  {: @abstract(Object for holding file information) parsed from directory
   listing of FTP server.}
  TFTPListRec = class(TObject)
  private
    FFileName: String;
    FDirectory: Boolean;
    FReadable: Boolean;
    FFileSize: int64;
    FFileTime: TDateTime;
    FOriginalLine: string;
    FMask: string;
    FPermission: String;
  public
    {: You can assign another TFTPListRec to this object.}
    procedure Assign(Value: TFTPListRec); virtual;
    {:name of file}
    property FileName: string read FFileName write FFileName;
    {:if name is subdirectory not file.}
    property Directory: Boolean read FDirectory write FDirectory;
    {:if you have rights to read}
    property Readable: Boolean read FReadable write FReadable;
    {:size of file in bytes}
    property FileSize: int64 read FFileSize write FFileSize;
    {:date and time of file. Local server timezone is used. Any timezone
     conversions was not done!}
    property FileTime: TDateTime read FFileTime write FFileTime;
    {:original unparsed line}
    property OriginalLine: string read FOriginalLine write FOriginalLine;
    {:mask what was used for parsing}
    property Mask: string read FMask write FMask;
    {:permission string (depending on used mask!)}
    property Permission: string read FPermission write FPermission;
  end;

  {:@abstract(This is TList of TFTPListRec objects.)
   This object is used for holding lististing of all files information in listed
   directory on FTP server.}
  TFTPList = class(TObject)
  protected
    FList: TList;
    FLines: TStringList;
    FMasks: TStringList;
    FUnparsedLines: TStringList;
    Monthnames: string;
    BlockSize: string;
    DirFlagValue: string;
    FileName: string;
    VMSFileName: string;
    Day: string;
    Month: string;
    ThreeMonth: string;
    YearTime: string;
    Year: string;
    Hours: string;
    HoursModif: Ansistring;
    Minutes: string;
    Seconds: string;
    Size: Ansistring;
    Permissions: Ansistring;
    DirFlag: string;
    function GetListItem(Index: integer): TFTPListRec; virtual;
    function ParseEPLF(Value: string): Boolean; virtual;
    procedure ClearStore; virtual;
    function ParseByMask(Value, NextValue, Mask: ansistring): Integer; virtual;
    function CheckValues: Boolean; virtual;
    procedure FillRecord(const Value: TFTPListRec); virtual;
  public
    {:Constructor. You not need create this object, it is created by TFTPSend
     class as their property.}
    constructor Create;
    destructor Destroy; override;

    {:Clear list.}
    procedure Clear; virtual;

    {:count of holded @link(TFTPListRec) objects}
    function Count: integer; virtual;

    {:Assigns one list to another}
    procedure Assign(Value: TFTPList); virtual;

    {:try to parse raw directory listing in @link(lines) to list of
     @link(TFTPListRec).}
    procedure ParseLines; virtual;

    {:By this property you have access to list of @link(TFTPListRec).
     This is for compatibility only. Please, use @link(Items) instead.}
    property List: TList read FList;

    {:By this property you have access to list of @link(TFTPListRec).}
    property Items[Index: Integer]: TFTPListRec read GetListItem; default;

    {:Set of lines with RAW directory listing for @link(parseLines)}
    property Lines: TStringList read FLines;

    {:Set of masks for directory listing parser. It is predefined by default,
    however you can modify it as you need. (for example, you can add your own
    definition mask.) Mask is same as mask used in TotalCommander.}
    property Masks: TStringList read FMasks;

    {:After @link(ParseLines) it holding lines what was not sucessfully parsed.}
    property UnparsedLines: TStringList read FUnparsedLines;
  end;

  {:@abstract(Implementation of FTP protocol.)
   Note: Are you missing properties for setting Username and Password? Look to
   parent @link(TSynaClient) object! (Username and Password have default values
   for "anonymous" FTP login)

   Are you missing properties for specify server address and port? Look to
   parent @link(TSynaClient) too!}
  TFTPSend = class(TSynaClient)
  protected
    FOnStatus: TFTPStatus;
    FSock: TTCPBlockSocket;
    FDSock: TTCPBlockSocket;
    FResultCode: Integer;
    FResultString: string;
    FFullResult: TStringList;
    FAccount: string;
    FFWHost: string;
    FFWPort: string;
    FFWUsername: string;
    FFWPassword: string;
    FFWMode: integer;
    FDataStream: TMemoryStream;
    FDataIP: string;
    FDataPort: string;
    FDirectFile: Boolean;
    FDirectFileName: string;
    FCanResume: Boolean;
    FPassiveMode: Boolean;
    FForceDefaultPort: Boolean;
    FForceOldPort: Boolean;
    FFtpList: TFTPList;
    FBinaryMode: Boolean;
    FAutoTLS: Boolean;
    FIsTLS: Boolean;
    FIsDataTLS: Boolean;
    FTLSonData: Boolean;
    FFullSSL: Boolean;
    function Auth(Mode: integer): Boolean; virtual;
    function Connect: Boolean; virtual;
    function InternalStor(const Command: string; RestoreAt: int64): Boolean; virtual;
    function DataSocket: Boolean; virtual;
    function AcceptDataSocket: Boolean; virtual;
    procedure DoStatus(Response: Boolean; const Value: string); virtual;
  public
    {:Custom definition of login sequence. You can use this when you set
     @link(FWMode) to value -1.}
    CustomLogon: TLogonActions;

    constructor Create;
    destructor Destroy; override;

    {:Waits and read FTP server response. You need this only in special cases!}
    function ReadResult: Integer; virtual;

    {:Parse remote side information of data channel from value string (returned
     by PASV command). This function you need only in special cases!}
    procedure ParseRemote(Value: string); virtual;

    {:Parse remote side information of data channel from value string (returned
     by EPSV command). This function you need only in special cases!}
    procedure ParseRemoteEPSV(Value: string); virtual;

    {:Send Value as FTP command to FTP server. Returned result code is result of
     this function.
     This command is good for sending site specific command, or non-standard
     commands.}
    function FTPCommand(const Value: string): integer; virtual;

    {:Connect and logon to FTP server. If you specify any FireWall, connect to
     firewall and throw them connect to FTP server. Login sequence depending on
     @link(FWMode).}
    function Login: Boolean; virtual;

    {:Logoff and disconnect from FTP server.}
    function Logout: Boolean; virtual;

    {:Break current transmission of data. (You can call this method from
     Sock.OnStatus event, or from another thread.)}
    procedure Abort; virtual;

    {:Break current transmission of data. It is same as Abort, but it send abort
     telnet commands prior ABOR FTP command. Some servers need it. (You can call
     this method from Sock.OnStatus event, or from another thread.)}
    procedure TelnetAbort; virtual;

    {:Download directory listing of Directory on FTP server. If Directory is
     empty string, download listing of current working directory.
     If NameList is @true, download only names of files in directory.
     (internally use NLST command instead LIST command)
     If NameList is @false, returned list is also parsed to @link(FTPList)
     property.}
    function List(Directory: string; NameList: Boolean): Boolean; virtual;

    {:Read data from FileName on FTP server. If Restore is @true and server
     supports resume dowloads, download is resumed. (received is only rest
     of file)}
    function RetrieveFile(const FileName: string; Restore: Boolean): Boolean; virtual;

    {:Send data to FileName on FTP server. If Restore is @true and server
     supports resume upload, upload is resumed. (send only rest of file)
     In this case if remote file is same length as local file, nothing will be
     done. If remote file is larger then local, resume is disabled and file is
     transfered from begin!}
    function StoreFile(const FileName: string; Restore: Boolean): Boolean; virtual;

    {:Send data to FTP server and assing unique name for this file.}
    function StoreUniqueFile: Boolean; virtual;

    {:Append data to FileName on FTP server.}
    function AppendFile(const FileName: string): Boolean; virtual;

    {:Rename on FTP server file with OldName to NewName.}
    function RenameFile(const OldName, NewName: string): Boolean; virtual;

    {:Delete file FileName on FTP server.}
    function DeleteFile(const FileName: string): Boolean; virtual;

    {:Return size of Filename file on FTP server. If command failed (i.e. not
     implemented), return -1.}
    function FileSize(const FileName: string): int64; virtual;

    {:Send NOOP command to FTP server for preserve of disconnect by inactivity
     timeout.}
    function NoOp: Boolean; virtual;

    {:Change currect working directory to Directory on FTP server.}
    function ChangeWorkingDir(const Directory: string): Boolean; virtual;

    {:walk to upper directory on FTP server.}
    function ChangeToParentDir: Boolean; virtual;

    {:walk to root directory on FTP server. (May not work with all servers properly!)}
    function ChangeToRootDir: Boolean; virtual;

    {:Delete Directory on FTP server.}
    function DeleteDir(const Directory: string): Boolean; virtual;

    {:Create Directory on FTP server.}
    function CreateDir(const Directory: string): Boolean; virtual;

    {:Return current working directory on FTP server.}
    function GetCurrentDir: String; virtual;

    {:Establish data channel to FTP server and retrieve data.
     This function you need only in special cases, i.e. when you need to implement
     some special unsupported FTP command!}
    function DataRead(const DestStream: TStream): Boolean; virtual;

    {:Establish data channel to FTP server and send data.
     This function you need only in special cases, i.e. when you need to implement
     some special unsupported FTP command.}
    function DataWrite(const SourceStream: TStream): Boolean; virtual;
  published
    {:After FTP command contains result number of this operation.}
    property ResultCode: Integer read FResultCode;

    {:After FTP command contains main line of result.}
    property ResultString: string read FResultString;

    {:After any FTP command it contains all lines of FTP server reply.}
    property FullResult: TStringList read FFullResult;

    {:Account information used in some cases inside login sequence.}
    property Account: string read FAccount Write FAccount;

    {:Address of firewall. If empty string (default), firewall not used.}
    property FWHost: string read FFWHost Write FFWHost;

    {:port of firewall. standard value is same port as ftp server used. (21)}
    property FWPort: string read FFWPort Write FFWPort;

    {:Username for login to firewall. (if needed)}
    property FWUsername: string read FFWUsername Write FFWUsername;

    {:password for login to firewall. (if needed)}
    property FWPassword: string read FFWPassword Write FFWPassword;

    {:Type of Firewall. Used only if you set some firewall address. Supported
     predefined firewall login sequences are described by comments in source
     file where you can see pseudocode decribing each sequence.}
    property FWMode: integer read FFWMode Write FFWMode;

    {:Socket object used for TCP/IP operation on control channel. Good for
     seting OnStatus hook, etc.}
    property Sock: TTCPBlockSocket read FSock;

    {:Socket object used for TCP/IP operation on data channel. Good for seting
     OnStatus hook, etc.}
    property DSock: TTCPBlockSocket read FDSock;

    {:If you not use @link(DirectFile) mode, all data transfers is made to or
     from this stream.}
    property DataStream: TMemoryStream read FDataStream;

    {:After data connection is established, contains remote side IP of this
     connection.}
    property DataIP: string read FDataIP;

    {:After data connection is established, contains remote side port of this
     connection.}
    property DataPort: string read FDataPort;

    {:Mode of data handling by data connection. If @False, all data operations
     are made to or from @link(DataStream) TMemoryStream.
     If @true, data operations is made directly to file in your disk. (filename
     is specified by @link(DirectFileName) property.) Dafault is @False!}
    property DirectFile: Boolean read FDirectFile Write FDirectFile;

    {:Filename for direct disk data operations.}
    property DirectFileName: string read FDirectFileName Write FDirectFileName;

    {:Indicate after @link(Login) if remote server support resume downloads and
     uploads.}
    property CanResume: Boolean read FCanResume;

    {:If true (default value), all transfers is made by passive method.
     It is safer method for various firewalls.}
    property PassiveMode: Boolean read FPassiveMode Write FPassiveMode;

    {:Force to listen for dataconnection on standard port (20). Default is @false,
     dataconnections will be made to any non-standard port reported by PORT FTP
     command. This setting is not used, if you use passive mode.}
    property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort;

    {:When is @true, then is disabled EPSV and EPRT support. However without this
     commands you cannot use IPv6! (Disabling of this commands is needed only
     when you are behind some crap firewall/NAT.}
    property ForceOldPort: Boolean read FForceOldPort Write FForceOldPort;

    {:You may set this hook for monitoring FTP commands and replies.}
    property OnStatus: TFTPStatus read FOnStatus write FOnStatus;

    {:After LIST command is here parsed list of files in given directory.}
    property FtpList: TFTPList read FFtpList;

    {:if @true (default), then data transfers is in binary mode. If this is set
     to @false, then ASCII mode is used.}
    property BinaryMode: Boolean read FBinaryMode Write FBinaryMode;

    {:if is true, then if server support upgrade to SSL/TLS mode, then use them.}
    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;

    {:if server listen on SSL/TLS port, then you set this to true.}
    property FullSSL: Boolean read FFullSSL Write FFullSSL;

    {:Signalise, if control channel is in SSL/TLS mode.}
    property IsTLS: Boolean read FIsTLS;

    {:Signalise, if data transfers is in SSL/TLS mode.}
    property IsDataTLS: Boolean read FIsDataTLS;

    {:If @true (default), then try to use SSL/TLS on data transfers too.
     If @false, then SSL/TLS is used only for control connection.}
    property TLSonData: Boolean read FTLSonData write FTLSonData;
  end;

{:A very useful function, and example of use can be found in the TFtpSend object.
 Dowload specified file from FTP server to LocalFile.}
function FtpGetFile(const IP, Port, FileName, LocalFile,
  User, Pass: string): Boolean;

{:A very useful function, and example of use can be found in the TFtpSend object.
 Upload specified LocalFile to FTP server.}
function FtpPutFile(const IP, Port, FileName, LocalFile,
  User, Pass: string): Boolean;

{:A very useful function, and example of use can be found in the TFtpSend object.
 Initiate transfer of file between two FTP servers.}
function FtpInterServerTransfer(
  const FromIP, FromPort, FromFile, FromUser, FromPass: string;
  const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean;

implementation

constructor TFTPSend.Create;
begin
  inherited Create;
  FFullResult := TStringList.Create;
  FDataStream := TMemoryStream.Create;
  FSock := TTCPBlockSocket.Create;
  FSock.Owner := self;
  FSock.ConvertLineEnd := True;
  FDSock := TTCPBlockSocket.Create;
  FDSock.Owner := self;
  FFtpList := TFTPList.Create;
  FTimeout := 300000;
  FTargetPort := cFtpProtocol;
  FUsername := 'anonymous';
  FPassword := 'anonymous@' + FSock.LocalName;
  FDirectFile := False;
  FPassiveMode := True;
  FForceDefaultPort := False;
  FForceOldPort := false;
  FAccount := '';
  FFWHost := '';
  FFWPort := cFtpProtocol;
  FFWUsername := '';
  FFWPassword := '';
  FFWMode := 0;
  FBinaryMode := True;
  FAutoTLS := False;
  FFullSSL := False;
  FIsTLS := False;
  FIsDataTLS := False;
  FTLSonData := True;
end;

destructor TFTPSend.Destroy;
begin
  FDSock.Free;
  FSock.Free;
  FFTPList.Free;
  FDataStream.Free;
  FFullResult.Free;
  inherited Destroy;
end;

procedure TFTPSend.DoStatus(Response: Boolean; const Value: string);
begin
  if assigned(OnStatus) then
    OnStatus(Self, Response, Value);
end;

function TFTPSend.ReadResult: Integer;
var
  s, c: AnsiString;
begin
  FFullResult.Clear;
  c := '';
  repeat
    s := FSock.RecvString(FTimeout);
    if c = '' then
      if length(s) > 3 then
        if s[4] in [' ', '-'] then
          c :=Copy(s, 1, 3);
    FResultString := s;
    FFullResult.Add(s);
    DoStatus(True, s);
    if FSock.LastError <> 0 then
      Break;
  until (c <> '') and (Pos(c + ' ', s) = 1);
  Result := StrToIntDef(c, 0);
  FResultCode := Result;
end;

function TFTPSend.FTPCommand(const Value: string): integer;
begin
  FSock.Purge;
  FSock.SendString(Value + CRLF);
  DoStatus(False, Value);
  Result := ReadResult;
end;

// based on idea by Petr Esner <petr.esner@atlas.cz>
function TFTPSend.Auth(Mode: integer): Boolean;
const
  //if not USER <username> then
  //  if not PASS <password> then
  //    if not ACCT <account> then ERROR!
  //OK!
  Action0: TLogonActions =
    (0, FTP_OK, 3,
     1, FTP_OK, 6,
     2, FTP_OK, FTP_ERR,
     0, 0, 0, 0, 0, 0, 0, 0, 0);

  //if not USER <FWusername> then
  //  if not PASS <FWPassword> then ERROR!
  //if SITE <FTPServer> then ERROR!
  //if not USER <username> then
  //  if not PASS <password> then
  //    if not ACCT <account> then ERROR!
  //OK!
  Action1: TLogonActions =
    (3, 6, 3,
     4, 6, FTP_ERR,
     5, FTP_ERR, 9,
     0, FTP_OK, 12,
     1, FTP_OK, 15,
     2, FTP_OK, FTP_ERR);

  //if not USER <FWusername> then
  //  if not PASS <FWPassword> then ERROR!
  //if USER <UserName>'@'<FTPServer> then OK!
  //if not PASS <password> then
  //  if not ACCT <account> then ERROR!
  //OK!
  Action2: TLogonActions =
    (3, 6, 3,
     4, 6, FTP_ERR,
     6, FTP_OK, 9,
     1, FTP_OK, 12,
     2, FTP_OK, FTP_ERR,
     0, 0, 0);

  //if not USER <FWusername> then
  //  if not PASS <FWPassword> then ERROR!
  //if not USER <username> then
  //  if not PASS <password> then
  //    if not ACCT <account> then ERROR!
  //OK!
  Action3: TLogonActions =
    (3, 6, 3,
     4, 6, FTP_ERR,
     0, FTP_OK, 9,
     1, FTP_OK, 12,
     2, FTP_OK, FTP_ERR,
     0, 0, 0);

  //OPEN <FTPserver>
  //if not USER <username> then
  //  if not PASS <password> then
  //    if not ACCT <account> then ERROR!
  //OK!
  Action4: TLogonActions =
    (7, 3, 3,
     0, FTP_OK, 6,
     1, FTP_OK, 9,
     2, FTP_OK, FTP_ERR,
     0, 0, 0, 0, 0, 0);

  //if USER <UserName>'@'<FTPServer> then OK!
  //if not PASS <password> then
  //  if not ACCT <account> then ERROR!
  //OK!
  Action5: TLogonActions =
    (6, FTP_OK, 3,
     1, FTP_OK, 6,
     2, FTP_OK, FTP_ERR,
     0, 0, 0, 0, 0, 0, 0, 0, 0);

  //if not USER <FWUserName>@<FTPServer> then
  //  if not PASS <FWPassword> then ERROR!
  //if not USER <username> then
  //  if not PASS <password> then
  //    if not ACCT <account> then ERROR!
  //OK!
  Action6: TLogonActions =
    (8, 6, 3,
     4, 6, FTP_ERR,
     0, FTP_OK, 9,
     1, FTP_OK, 12,
     2, FTP_OK, FTP_ERR,
     0, 0, 0);

  //if USER <UserName>@<FTPServer> <FWUserName> then ERROR!
  //if not PASS <password> then
  //  if not ACCT <account> then ERROR!
  //OK!
  Action7: TLogonActions =
    (9, FTP_ERR, 3,
     1, FTP_OK, 6,
     2, FTP_OK, FTP_ERR,
     0, 0, 0, 0, 0, 0, 0, 0, 0);

  //if not USER <UserName>@<FWUserName>@<FTPServer> then
  //  if not PASS <Password>@<FWPassword> then
  //    if not ACCT <account> then ERROR!
  //OK!
  Action8: TLogonActions =
    (10, FTP_OK, 3,
     11, FTP_OK, 6,
     2, FTP_OK, FTP_ERR,
     0, 0, 0, 0, 0, 0, 0, 0, 0);
var
  FTPServer: string;
  LogonActions: TLogonActions;
  i: integer;
  s: string;
  x: integer;
begin
  Result := False;
  if FFWHost = '' then
    Mode := 0;
  if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then
    FTPServer := FTargetHost
  else
    FTPServer := FTargetHost + ':' + FTargetPort;
  case Mode of
    -1:
      LogonActions := CustomLogon;
    1:
      LogonActions := Action1;
    2:
      LogonActions := Action2;
    3:
      LogonActions := Action3;
    4:
      LogonActions := Action4;
    5:
      LogonActions := Action5;
    6:
      LogonActions := Action6;
    7:
      LogonActions := Action7;
    8:
      LogonActions := Action8;
  else
    LogonActions := Action0;
  end;
  i := 0;
  repeat
    case LogonActions[i] of
      0:  s := 'USER ' + FUserName;
      1:  s := 'PASS ' + FPassword;
      2:  s := 'ACCT ' + FAccount;
      3:  s := 'USER ' + FFWUserName;
      4:  s := 'PASS ' + FFWPassword;
      5:  s := 'SITE ' + FTPServer;
      6:  s := 'USER ' + FUserName + '@' + FTPServer;
      7:  s := 'OPEN ' + FTPServer;
      8:  s := 'USER ' + FFWUserName + '@' + FTPServer;
      9:  s := 'USER ' + FUserName + '@' + FTPServer + ' ' + FFWUserName;
      10: s := 'USER ' + FUserName + '@' + FFWUserName + '@' + FTPServer;
      11: s := 'PASS ' + FPassword + '@' + FFWPassword;
    end;
    x := FTPCommand(s);
    x := x div 100;
    if (x <> 2) and (x <> 3) then
      Exit;
    i := LogonActions[i + x - 1];
    case i of
      FTP_ERR:
        Exit;
      FTP_OK:
        begin
          Result := True;
          Exit;
        end;
    end;
  until False;
end;


function TFTPSend.Connect: Boolean;
begin
  FSock.CloseSocket;
  FSock.Bind(FIPInterface, cAnyPort);
  if FSock.LastError = 0 then
    if FFWHost = '' then
      FSock.Connect(FTargetHost, FTargetPort)
    else
      FSock.Connect(FFWHost, FFWPort);
  if FSock.LastError = 0 then
    if FFullSSL then
      FSock.SSLDoConnect;
  Result := FSock.LastError = 0;
end;

function TFTPSend.Login: Boolean;
var
  x: integer;
begin
  Result := False;
  FCanResume := False;
  if not Connect then
    Exit;
  FIsTLS := FFullSSL;
  FIsDataTLS := False;
  repeat
    x := ReadResult div 100;
  until x <> 1;
  if x <> 2 then
    Exit;
  if FAutoTLS and not(FIsTLS) then
    if (FTPCommand('AUTH TLS') div 100) = 2 then
    begin
      FSock.SSLDoConnect;
      FIsTLS := FSock.LastError = 0;
      if not FIsTLS then
      begin
        Result := False;
        Exit;
      end;
    end;
  if not Auth(FFWMode) then
    Exit;
  if FIsTLS then
  begin
    FTPCommand('PBSZ 0');
    if FTLSonData then
      FIsDataTLS := (FTPCommand('PROT P') div 100) = 2;
    if not FIsDataTLS then
      FTPCommand('PROT C');
  end;
  FTPCommand('TYPE I');
  FTPCommand('STRU F');
  FTPCommand('MODE S');
  if FTPCommand('REST 0') = 350 then
    if FTPCommand('REST 1') = 350 then
    begin
      FTPCommand('REST 0');
      FCanResume := True;
    end;
  Result := True;
end;

function TFTPSend.Logout: Boolean;
begin
  Result := (FTPCommand('QUIT') div 100) = 2;
  FSock.CloseSocket;
end;

procedure TFTPSend.ParseRemote(Value: string);
var
  n: integer;
  nb, ne: integer;
  s: string;
  x: integer;
begin
  Value := trim(Value);
  nb := Pos('(',Value);
  ne := Pos(')',Value);
  if (nb = 0) or (ne = 0) then
  begin
    nb:=RPos(' ',Value);
    s:=Copy(Value, nb + 1, Length(Value) - nb);
  end
  else
  begin
    s:=Copy(Value,nb+1,ne-nb-1);
  end;
  for n := 1 to 4 do
    if n = 1 then
      FDataIP := Fetch(s, ',')
    else
      FDataIP := FDataIP + '.' + Fetch(s, ',');
  x := StrToIntDef(Fetch(s, ','), 0) * 256;
  x := x + StrToIntDef(Fetch(s, ','), 0);
  FDataPort := IntToStr(x);
end;

procedure TFTPSend.ParseRemoteEPSV(Value: string);
var
  n: integer;
  s, v: AnsiString;
begin
  s := SeparateRight(Value, '(');
  s := Trim(SeparateLeft(s, ')'));
  Delete(s, Length(s), 1);
  v := '';
  for n := Length(s) downto 1 do
    if s[n] in ['0'..'9'] then
      v := s[n] + v
    else
      Break;
  FDataPort := v;
  FDataIP := FTargetHost;
end;

function TFTPSend.DataSocket: boolean;
var
  s: string;
begin
  Result := False;
  if FIsDataTLS then
    FPassiveMode := True;
  if FPassiveMode then
  begin
    if FSock.IP6used then
      s := '2'
    else
      s := '1';
    if FSock.IP6used and not(FForceOldPort) and ((FTPCommand('EPSV ' + s) div 100) = 2) then
    begin
      ParseRemoteEPSV(FResultString);
    end
    else
      if FSock.IP6used then
        Exit
      else
      begin
        if (FTPCommand('PASV') div 100) <> 2 then
          Exit;
        ParseRemote(FResultString);
      end;
    FDSock.CloseSocket;
    FDSock.Bind(FIPInterface, cAnyPort);
    FDSock.Connect(FDataIP, FDataPort);
    Result := FDSock.LastError = 0;
  end
  else
  begin
    FDSock.CloseSocket;
    if FForceDefaultPort then
      s := cFtpDataProtocol
    else
      s := '0';
    //data conection from same interface as command connection
    FDSock.Bind(FSock.GetLocalSinIP, s);
    if FDSock.LastError <> 0 then
      Exit;
    FDSock.SetLinger(True, 10000);
    FDSock.Listen;
    FDSock.GetSins;
    FDataIP := FDSock.GetLocalSinIP;
    FDataIP := FDSock.ResolveName(FDataIP);
    FDataPort := IntToStr(FDSock.GetLocalSinPort);
    if FSock.IP6used and (not FForceOldPort) then
    begin
      if IsIp6(FDataIP) then
        s := '2'
      else
        s := '1';
      s := 'EPRT |' + s +'|' + FDataIP + '|' + FDataPort + '|';
      Result := (FTPCommand(s) div 100) = 2;
    end;
    if not Result and IsIP(FDataIP) then
    begin
      s := ReplaceString(FDataIP, '.', ',');
      s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256)
        + ',' + IntToStr(FDSock.GetLocalSinPort mod 256);
      Result := (FTPCommand(s) div 100) = 2;
    end;
  end;
end;

function TFTPSend.AcceptDataSocket: Boolean;
var
  x: TSocket;
begin
  if FPassiveMode then
    Result := True
  else
  begin
    Result := False;
    if FDSock.CanRead(FTimeout) then
    begin
      x := FDSock.Accept;
      if not FDSock.UsingSocks then
        FDSock.CloseSocket;
      FDSock.Socket := x;
      Result := True;
    end;
  end;
  if Result and FIsDataTLS then
  begin
    FDSock.SSL.Assign(FSock.SSL);
    FDSock.SSLDoConnect;
    Result := FDSock.LastError = 0;
  end;
end;

function TFTPSend.DataRead(const DestStream: TStream): Boolean;
var
  x: integer;
begin
  Result := False;
  try
    if not AcceptDataSocket then
      Exit;
    FDSock.RecvStreamRaw(DestStream, FTimeout);
    FDSock.CloseSocket;
    x := ReadResult;
    Result := (x div 100) = 2;
  finally
    FDSock.CloseSocket;
  end;
end;

function TFTPSend.DataWrite(const SourceStream: TStream): Boolean;
var
  x: integer;
  b: Boolean;
begin
  Result := False;
  try
    if not AcceptDataSocket then
      Exit;
    FDSock.SendStreamRaw(SourceStream);
    b := FDSock.LastError = 0;
    FDSock.CloseSocket;
    x := ReadResult;
    Result := b and ((x div 100) = 2);
  finally
    FDSock.CloseSocket;
  end;
end;

function TFTPSend.List(Directory: string; NameList: Boolean): Boolean;
var
  x: integer;
begin
  Result := False;
  FDataStream.Clear;
  FFTPList.Clear;
  if Directory <> '' then
    Directory := ' ' + Directory;
  FTPCommand('TYPE A');
  if not DataSocket then
    Exit;
  if NameList then
    x := FTPCommand('NLST' + Directory)
  else
    x := FTPCommand('LIST' + Directory);
  if (x div 100) <> 1 then
    Exit;
  Result := DataRead(FDataStream);
  if (not NameList) and Result then
  begin
    FDataStream.Position := 0;
    FFTPList.Lines.LoadFromStream(FDataStream);
    FFTPList.ParseLines;
  end;
  FDataStream.Position := 0;
end;

function TFTPSend.RetrieveFile(const FileName: string; Restore: Boolean): Boolean;
var
  RetrStream: TStream;
begin
  Result := False;
  if FileName = '' then
    Exit;
  if not DataSocket then
    Exit;
  Restore := Restore and FCanResume;
  if FDirectFile then
    if Restore and FileExists(FDirectFileName) then
      RetrStream := TFileStream.Create(FDirectFileName,
        fmOpenReadWrite  or fmShareExclusive)
    else
      RetrStream := TFileStream.Create(FDirectFileName,
        fmCreate or fmShareDenyWrite)
  else
    RetrStream := FDataStream;
  try
    if FBinaryMode then
      FTPCommand('TYPE I')
    else
      FTPCommand('TYPE A');
    if Restore then
    begin
      RetrStream.Position := RetrStream.Size;
      if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then
        Exit;
    end
    else
      if RetrStream is TMemoryStream then
        TMemoryStream(RetrStream).Clear;
    if (FTPCommand('RETR ' + FileName) div 100) <> 1 then
      Exit;
    Result := DataRead(RetrStream);
    if not FDirectFile then
      RetrStream.Position := 0;
  finally
    if FDirectFile then
      RetrStream.Free;
  end;
end;

function TFTPSend.InternalStor(const Command: string; RestoreAt: int64): Boolean;
var
  SendStream: TStream;
  StorSize: int64;
begin
  Result := False;
  if FDirectFile then
    if not FileExists(FDirectFileName) then
      Exit
    else
      SendStream := TFileStream.Create(FDirectFileName,
        fmOpenRead or fmShareDenyWrite)
  else
    SendStream := FDataStream;
  try
    if not DataSocket then
      Exit;
    if FBinaryMode then
      FTPCommand('TYPE I')
    else
      FTPCommand('TYPE A');
    StorSize := SendStream.Size;
    if not FCanResume then
      RestoreAt := 0;
    if (StorSize > 0) and (RestoreAt = StorSize) then
    begin
      Result := True;
      Exit;
    end;
    if RestoreAt > StorSize then
      RestoreAt := 0;
    FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt));
    if FCanResume then
      if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then
        Exit;
    SendStream.Position := RestoreAt;
    if (FTPCommand(Command) div 100) <> 1 then
      Exit;
    Result := DataWrite(SendStream);
  finally
    if FDirectFile then
      SendStream.Free;
  end;
end;

function TFTPSend.StoreFile(const FileName: string; Restore: Boolean): Boolean;
var
  RestoreAt: int64;
begin
  Result := False;
  if FileName = '' then
    Exit;
  RestoreAt := 0;
  Restore := Restore and FCanResume;
  if Restore then
  begin
    RestoreAt := Self.FileSize(FileName);
    if RestoreAt < 0 then
      RestoreAt := 0;
  end;
  Result := InternalStor('STOR ' + FileName, RestoreAt);
end;

function TFTPSend.StoreUniqueFile: Boolean;
begin
  Result := InternalStor('STOU', 0);
end;

function TFTPSend.AppendFile(const FileName: string): Boolean;
begin
  Result := False;
  if FileName = '' then
    Exit;
  Result := InternalStor('APPE ' + FileName, 0);
end;

function TFTPSend.NoOp: Boolean;
begin
  Result := (FTPCommand('NOOP') div 100) = 2;
end;

function TFTPSend.RenameFile(const OldName, NewName: string): Boolean;
begin
  Result := False;
  if (FTPCommand('RNFR ' + OldName) div 100) <> 3  then
    Exit;
  Result := (FTPCommand('RNTO ' + NewName) div 100) = 2;
end;

function TFTPSend.DeleteFile(const FileName: string): Boolean;
begin
  Result := (FTPCommand('DELE ' + FileName) div 100) = 2;
end;

function TFTPSend.FileSize(const FileName: string): int64;
var
  s: string;
begin
  Result := -1;
  if (FTPCommand('SIZE ' + FileName) div 100) = 2 then
  begin
    s := Trim(SeparateRight(ResultString, ' '));
    s := Trim(SeparateLeft(s, ' '));
    {$IFDEF VER100}
      Result := StrToIntDef(s, -1);
    {$ELSE}
      Result := StrToInt64Def(s, -1);
    {$ENDIF}
  end;
end;

function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean;
begin
  Result := (FTPCommand('CWD ' + Directory) div 100) = 2;
end;

function TFTPSend.ChangeToParentDir: Boolean;
begin
  Result := (FTPCommand('CDUP') div 100) = 2;
end;

function TFTPSend.ChangeToRootDir: Boolean;
begin
  Result := ChangeWorkingDir('/');
end;

function TFTPSend.DeleteDir(const Directory: string): Boolean;
begin
  Result := (FTPCommand('RMD ' + Directory) div 100) = 2;
end;

function TFTPSend.CreateDir(const Directory: string): Boolean;
begin
  Result := (FTPCommand('MKD ' + Directory) div 100) = 2;
end;

function TFTPSend.GetCurrentDir: String;
begin
  Result := '';
  if (FTPCommand('PWD') div 100) = 2 then
  begin
    Result := SeparateRight(FResultString, '"');
    Result := Trim(Separateleft(Result, '"'));
  end;
end;

procedure TFTPSend.Abort;
begin
  FSock.SendString('ABOR' + CRLF);
  FDSock.StopFlag := True;
end;

procedure TFTPSend.TelnetAbort;
begin
  FSock.SendString(#$FF + #$F4 + #$FF + #$F2);
  Abort;
end;

{==============================================================================}

procedure TFTPListRec.Assign(Value: TFTPListRec);
begin
  FFileName := Value.FileName;
  FDirectory := Value.Directory;
  FReadable := Value.Readable;
  FFileSize := Value.FileSize;
  FFileTime := Value.FileTime;
  FOriginalLine := Value.OriginalLine;
  FMask := Value.Mask;
end;

constructor TFTPList.Create;
begin
  inherited Create;
  FList := TList.Create;
  FLines := TStringList.Create;
  FMasks := TStringList.Create;
  FUnparsedLines := TStringList.Create;
  //various UNIX
  FMasks.add('pppppppppp $!!!S*$TTT$DD$hh mm ss$YYYY$n*');
  FMasks.add('pppppppppp $!!!S*$DD$TTT$hh mm ss$YYYY$n*');
  FMasks.add('pppppppppp $!!!S*$TTT$DD$UUUUU$n*');  //mostly used UNIX format
  FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*');
  //MacOS
  FMasks.add('pppppppppp $!!S*$TTT$DD$UUUUU$n*');
  FMasks.add('pppppppppp $!S*$TTT$DD$UUUUU$n*');
  //Novell
  FMasks.add('d            $!S*$TTT$DD$UUUUU$n*');
  //Windows
  FMasks.add('MM DD YY  hh mmH !S* n*');
  FMasks.add('MM DD YY  hh mmH $ d!n*');
  FMasks.add('MM DD YYYY  hh mmH !S* n*');
  FMasks.add('MM DD YYYY  hh mmH $ d!n*');
  FMasks.add('DD MM YYYY  hh mmH !S* n*');
  FMasks.add('DD MM YYYY  hh mmH $ d!n*');
  //VMS
  FMasks.add('v*$  DD TTT YYYY hh mm');
  FMasks.add('v*$!DD TTT YYYY hh mm');
  FMasks.add('n*$                 YYYY MM DD hh mm$S*');
  //AS400
  FMasks.add('!S*$MM DD YY hh mm ss !n*');
  FMasks.add('!S*$DD MM YY hh mm ss !n*');
  FMasks.add('n*!S*$MM DD YY hh mm ss d');
  FMasks.add('n*!S*$DD MM YY hh mm ss d');
  //VxWorks
  FMasks.add('$S*    TTT DD YYYY  hh mm ss $n* $ d');
  FMasks.add('$S*    TTT DD YYYY  hh mm ss $n*');
  //Distinct
  FMasks.add('d    $S*$TTT DD YYYY  hh mm$n*');
  FMasks.add('d    $S*$TTT DD$hh mm$n*');
  //PC-NFSD
  FMasks.add('nnnnnnnn.nnn  dSSSSSSSSSSS MM DD YY  hh mmH');
  //VOS
  FMasks.add('-   SSSSS            YY MM DD hh mm ss  n*');
  FMasks.add('- d=  SSSSS  YY MM DD hh mm ss  n*');
  //Unissys ClearPath
  FMasks.add('nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn               SSSSSSSSS MM DD YYYY hh mm');
  FMasks.add('n*\x                                               SSSSSSSSS MM DD YYYY hh mm');
  //IBM
  FMasks.add('-     SSSSSSSSSSSS           d   MM DD YYYY   hh mm  n*');
  //OS9
  FMasks.add('-         YY MM DD hhmm d                        SSSSSSSSS n*');
  //tandem
  FMasks.add('nnnnnnnn                   SSSSSSS DD TTT YY hh mm ss');
  //MVS
  FMasks.add('-             YYYY MM DD                     SSSSS   d=O n*');
  //BullGCOS8
  FMasks.add('             $S* MM DD YY hh mm ss  !n*');
  FMasks.add('d            $S* MM DD YY           !n*');
  //BullGCOS7
  FMasks.add('                                         TTT DD  YYYY n*');
  FMasks.add('  d                                                   n*');
end;

destructor TFTPList.Destroy;
begin
  Clear;
  FList.Free;
  FLines.Free;
  FMasks.Free;
  FUnparsedLines.Free;
  inherited Destroy;
end;

procedure TFTPList.Clear;
var
  n:integer;
begin
  for n := 0 to FList.Count - 1 do
    if Assigned(FList[n]) then
      TFTPListRec(FList[n]).Free;
  FList.Clear;
  FLines.Clear;
  FUnparsedLines.Clear;
end;

function TFTPList.Count: integer;
begin
  Result := FList.Count;
end;

function TFTPList.GetListItem(Index: integer): TFTPListRec;
begin
  Result := nil;
  if Index < Count then
    Result := TFTPListRec(FList[Index]);
end;

procedure TFTPList.Assign(Value: TFTPList);
var
  flr: TFTPListRec;
  n: integer;
begin
  Clear;
  for n := 0 to Value.Count - 1 do
  begin
    flr := TFTPListRec.Create;
    flr.Assign(Value[n]);
    Flist.Add(flr);
  end;
  Lines.Assign(Value.Lines);
  Masks.Assign(Value.Masks);
  UnparsedLines.Assign(Value.UnparsedLines);
end;

procedure TFTPList.ClearStore;
begin
  Monthnames := '';
  BlockSize := '';
  DirFlagValue := '';
  FileName := '';
  VMSFileName := '';
  Day := '';
  Month := '';
  ThreeMonth := '';
  YearTime := '';
  Year := '';
  Hours := '';
  HoursModif := '';
  Minutes := '';
  Seconds := '';
  Size := '';
  Permissions := '';
  DirFlag := '';
end;

function TFTPList.ParseByMask(Value, NextValue, Mask: AnsiString): Integer;
var
  Ivalue, IMask: integer;
  MaskC, LastMaskC: AnsiChar;
  c: AnsiChar;
  s: string;
begin
  ClearStore;
  Result := 0;
  if Value = '' then
    Exit;
  if Mask = '' then
    Exit;
  Ivalue := 1;
  IMask := 1;
  Result := 1;
  LastMaskC := ' ';
  while Imask <= Length(mask) do
  begin
    if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then
    begin
      Result := 0;
      Exit;
    end;
    MaskC := Mask[Imask];
    if Ivalue > Length(Value) then
      Exit;
    c := Value[Ivalue];
    case MaskC of
      'n':
        FileName := FileName + c;
      'v':
        VMSFileName := VMSFileName + c;
      '.':
        begin
          if c in ['.', ' '] then
            FileName := TrimSP(FileName) + '.'
          else
          begin
            Result := 0;
            Exit;
          end;
        end;
      'D':
        Day := Day + c;
      'M':
        Month := Month + c;
      'T':
        ThreeMonth := ThreeMonth + c;
      'U':
        YearTime := YearTime + c;
      'Y':
        Year := Year + c;
      'h':
        Hours := Hours + c;
      'H':
        HoursModif := HoursModif + c;
      'm':
        Minutes := Minutes + c;
      's':
        Seconds := Seconds + c;
      'S':
        Size := Size + c;
      'p':
        Permissions := Permissions + c;
      'd':
        DirFlag := DirFlag + c;
      'x':
        if c <> ' ' then
          begin
            Result := 0;
            Exit;
          end;
      '*':
        begin
          s := '';
          if LastMaskC in ['n', 'v'] then
          begin
            if Imask = Length(Mask) then
              s := Copy(Value, IValue, Maxint)
            else
              while IValue <= Length(Value) do
              begin
                if Value[Ivalue] = ' ' then
                  break;
                s := s + Value[Ivalue];
                Inc(Ivalue);
              end;
            if LastMaskC = 'n' then
              FileName := FileName + s
            else
              VMSFileName := VMSFileName + s;
          end
          else
          begin
            while IValue <= Length(Value) do
            begin
              if not(Value[Ivalue] in ['0'..'9']) then
                break;
              s := s + Value[Ivalue];
              Inc(Ivalue);
            end;
            case LastMaskC of
              'S':
                Size := Size + s;
            end;
          end;
          Dec(IValue);
        end;
      '!':
        begin
          while IValue <= Length(Value) do
          begin
            if Value[Ivalue] = ' ' then
              break;
            Inc(Ivalue);
          end;
          while IValue <= Length(Value) do
          begin
            if Value[Ivalue] <> ' ' then
              break;
            Inc(Ivalue);
          end;
          Dec(IValue);
        end;
      '$':
        begin
          while IValue <= Length(Value) do
          begin
            if not(Value[Ivalue] in [' ', #9]) then
              break;
            Inc(Ivalue);
          end;
          Dec(IValue);
        end;
      '=':
        begin
          s := '';
          case LastmaskC of
            'S':
              begin
                while Imask <= Length(Mask) do
                begin
                  if not(Mask[Imask] in ['0'..'9']) then
                    break;
                  s := s + Mask[Imask];
                  Inc(Imask);
                end;
                Dec(Imask);
                BlockSize := s;
              end;
            'T':
              begin
                Monthnames := Copy(Mask, IMask, 12 * 3);
                Inc(IMask, 12 * 3);
              end;
            'd':
              begin
                Inc(Imask);
                DirFlagValue := Mask[Imask];
              end;
          end;
        end;
      '\':
        begin
          Value := NextValue;
          IValue := 0;
          Result := 2;
        end;
    end;
    Inc(Ivalue);
    Inc(Imask);
    LastMaskC := MaskC;
  end;
end;

function TFTPList.CheckValues: Boolean;
var
  x, n: integer;
begin
  Result := false;
  if FileName <> '' then
  begin
    if pos('?', VMSFilename) > 0 then
      Exit;
    if pos('*', VMSFilename) > 0 then
      Exit;
  end;
  if VMSFileName <> '' then
    if pos(';', VMSFilename) <= 0 then
      Exit;
  if (FileName = '') and (VMSFileName = '') then
    Exit;
  if Permissions <> '' then
  begin
    if length(Permissions) <> 10 then
      Exit;
    for n := 1 to 10 do
      if not(Permissions[n] in
        ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 't', 'w', 'x', 'y', '-']) then
        Exit;
  end;
  if Day <> '' then
  begin
    Day := TrimSP(Day);
    x := StrToIntDef(day, -1);
    if (x < 1) or (x > 31) then
      Exit;
  end;
  if Month <> '' then
  begin
    Month := TrimSP(Month);
    x := StrToIntDef(Month, -1);
    if (x < 1) or (x > 12) then
      Exit;
  end;
  if Hours <> '' then
  begin
    Hours := TrimSP(Hours);
    x := StrToIntDef(Hours, -1);
    if (x < 0) or (x > 24) then
      Exit;
  end;
  if HoursModif <> '' then
  begin
    if not (HoursModif[1] in ['a', 'A', 'p', 'P']) then
      Exit;
  end;
  if Minutes <> '' then
  begin
    Minutes := TrimSP(Minutes);
    x := StrToIntDef(Minutes, -1);
    if (x < 0) or (x > 59) then
      Exit;
  end;
  if Seconds <> '' then
  begin
    Seconds := TrimSP(Seconds);
    x := StrToIntDef(Seconds, -1);
    if (x < 0) or (x > 59) then
      Exit;
  end;
  if Size <> '' then
  begin
    Size := TrimSP(Size);
    for n := 1 to Length(Size) do
      if not (Size[n] in ['0'..'9']) then
        Exit;
  end;

  if length(Monthnames) = (12 * 3) then
    for n := 1 to 12 do
      CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3);
  if ThreeMonth <> '' then
  begin
    x := GetMonthNumber(ThreeMonth);
    if (x = 0) then
      Exit;
  end;
  if YearTime <> '' then
  begin
    YearTime := ReplaceString(YearTime, '-', ':');
    if pos(':', YearTime) > 0 then
    begin
      if (GetTimeFromstr(YearTime) = -1) then
        Exit;
    end
    else
    begin
      YearTime := TrimSP(YearTime);
      x := StrToIntDef(YearTime, -1);
      if (x = -1) then
        Exit;
      if (x < 1900) or (x > 2100) then
        Exit;
    end;
  end;
  if Year <> '' then
  begin
    Year := TrimSP(Year);
    x := StrToIntDef(Year, -1);
    if (x = -1) then
      Exit;
    if Length(Year) = 4 then
    begin
      if not((x > 1900) and (x < 2100)) then
        Exit;
    end
    else
      if Length(Year) = 2 then
      begin
        if not((x >= 0) and (x <= 99)) then
          Exit;
      end
      else
        if Length(Year) = 3 then
        begin
          if not((x >= 100) and (x <= 110)) then
            Exit;
        end
        else
          Exit;
  end;
  Result := True;
end;

procedure TFTPList.FillRecord(const Value: TFTPListRec);
var
  s: string;
  x: integer;
  myear: Word;
  mmonth: Word;
  mday: Word;
  mhours, mminutes, mseconds: word;
  n: integer;
begin
  s := DirFlagValue;
  if s = '' then
    s := 'D';
  s := Uppercase(s);
  Value.Directory :=  s = Uppercase(DirFlag);
  if FileName <> '' then
    Value.FileName := SeparateLeft(Filename, ' -> ');
  if VMSFileName <> '' then
  begin
    Value.FileName := VMSFilename;
    Value.Directory := Pos('.DIR;',VMSFilename) > 0;
  end;
  Value.FileName := TrimSPRight(Value.FileName);
  Value.Readable := not Value.Directory;
  if BlockSize <> '' then
    x := StrToIntDef(BlockSize, 1)
  else
    x := 1;
  {$IFDEF VER100}
  Value.FileSize := x * StrToIntDef(Size, 0);
  {$ELSE}
  Value.FileSize := x * StrToInt64Def(Size, 0);
  {$ENDIF}

  DecodeDate(Date,myear,mmonth,mday);
  mhours := 0;
  mminutes := 0;
  mseconds := 0;

  if Day <> '' then
    mday := StrToIntDef(day, 1);
  if Month <> '' then
    mmonth := StrToIntDef(Month, 1);
  if length(Monthnames) = (12 * 3) then
    for n := 1 to 12 do
      CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3);
  if ThreeMonth <> '' then
    mmonth := GetMonthNumber(ThreeMonth);
  if Year <> '' then
  begin
    myear := StrToIntDef(Year, 0);
    if (myear <= 99) and (myear > 50) then
      myear := myear + 1900;
    if myear <= 50 then
      myear := myear + 2000;
  end;
  if YearTime <> '' then
  begin
    if pos(':', YearTime) > 0 then
    begin
      YearTime := TrimSP(YearTime);
      mhours := StrToIntDef(Separateleft(YearTime, ':'), 0);
      mminutes := StrToIntDef(SeparateRight(YearTime, ':'), 0);
      if (Encodedate(myear, mmonth, mday)
        + EncodeTime(mHours, mminutes, 0, 0)) > now then
        Dec(mYear);
    end
    else
      myear := StrToIntDef(YearTime, 0);
  end;
  if Minutes <> '' then
    mminutes := StrToIntDef(Minutes, 0);
  if Seconds <> '' then
    mseconds := StrToIntDef(Seconds, 0);
  if Hours <> '' then
  begin
    mHours := StrToIntDef(Hours, 0);
    if HoursModif <> '' then
      if Uppercase(HoursModif[1]) = 'P' then
        if mHours <> 12 then
          mHours := MHours + 12;
  end;
  Value.FileTime := Encodedate(myear, mmonth, mday)
    + EncodeTime(mHours, mminutes, mseconds, 0);
  if Permissions <> '' then
  begin
    Value.Permission := Permissions;
    Value.Readable := Uppercase(permissions)[2] = 'R';
    if Uppercase(permissions)[1] = 'D' then
    begin
      Value.Directory := True;
      Value.Readable := false;
    end
    else
      if Uppercase(permissions)[1] = 'L' then
        Value.Directory := True;
  end;
end;

function TFTPList.ParseEPLF(Value: string): Boolean;
var
  s, os: string;
  flr: TFTPListRec;
begin
  Result := False;
  if Value <> '' then
    if Value[1] = '+' then
    begin
      os := Value;
      Delete(Value, 1, 1);
      flr := TFTPListRec.create;
      flr.FileName := SeparateRight(Value, #9);
      s := Fetch(Value, ',');
      while s <> '' do
      begin
        if s[1] = #9 then
          Break;
        case s[1] of
          '/':
            flr.Directory := true;
          'r':
            flr.Readable := true;
          's':
            {$IFDEF VER100}
            flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0);
            {$ELSE}
            flr.FileSize := StrToInt64Def(Copy(s, 2, Length(s) - 1), 0);
            {$ENDIF}
          'm':
            flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400)
              + 25569;
        end;
        s := Fetch(Value, ',');
      end;
      if flr.FileName <> '' then
      if (flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')))
        or (flr.FileName = '') then
        flr.free
      else
      begin
        flr.OriginalLine := os;
        flr.Mask := 'EPLF';
        Flist.Add(flr);
        Result := True;
      end;
    end;
end;

procedure TFTPList.ParseLines;
var
  flr: TFTPListRec;
  n, m: Integer;
  S: string;
  x: integer;
  b: Boolean;
begin
  n := 0;
  while n < Lines.Count do
  begin
    if n = Lines.Count - 1 then
      s := ''
    else
      s := Lines[n + 1];
    b := False;
    x := 0;
    if ParseEPLF(Lines[n]) then
    begin
      b := True;
      x := 1;
    end
    else
      for m := 0 to Masks.Count - 1 do
      begin
        x := ParseByMask(Lines[n], s, Masks[m]);
        if x > 0 then
          if CheckValues then
          begin
            flr := TFTPListRec.create;
            FillRecord(flr);
            flr.OriginalLine := Lines[n];
            flr.Mask := Masks[m];
            if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then
              flr.free
            else
              Flist.Add(flr);
            b := True;
            Break;
          end;
      end;
    if not b then
      FUnparsedLines.Add(Lines[n]);
    Inc(n);
    if x > 1 then
      Inc(n, x - 1);
  end;
end;

{==============================================================================}

function FtpGetFile(const IP, Port, FileName, LocalFile,
  User, Pass: string): Boolean;
begin
  Result := False;
  with TFTPSend.Create do
  try
    if User <> '' then
    begin
      Username := User;
      Password := Pass;
    end;
    TargetHost := IP;
    TargetPort := Port;
    if not Login then
      Exit;
    DirectFileName := LocalFile;
    DirectFile:=True;
    Result := RetrieveFile(FileName, False);
    Logout;
  finally
    Free;
  end;
end;

function FtpPutFile(const IP, Port, FileName, LocalFile,
  User, Pass: string): Boolean;
begin
  Result := False;
  with TFTPSend.Create do
  try
    if User <> '' then
    begin
      Username := User;
      Password := Pass;
    end;
    TargetHost := IP;
    TargetPort := Port;
    if not Login then
      Exit;
    DirectFileName := LocalFile;
    DirectFile:=True;
    Result := StoreFile(FileName, False);
    Logout;
  finally
    Free;
  end;
end;

function FtpInterServerTransfer(
  const FromIP, FromPort, FromFile, FromUser, FromPass: string;
  const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean;
var
  FromFTP, ToFTP: TFTPSend;
  s: string;
  x: integer;
begin
  Result := False;
  FromFTP := TFTPSend.Create;
  toFTP := TFTPSend.Create;
  try
    if FromUser <> '' then
    begin
      FromFTP.Username := FromUser;
      FromFTP.Password := FromPass;
    end;
    if ToUser <> '' then
    begin
      ToFTP.Username := ToUser;
      ToFTP.Password := ToPass;
    end;
    FromFTP.TargetHost := FromIP;
    FromFTP.TargetPort := FromPort;
    ToFTP.TargetHost := ToIP;
    ToFTP.TargetPort := ToPort;
    if not FromFTP.Login then
      Exit;
    if not ToFTP.Login then
      Exit;
    if (FromFTP.FTPCommand('PASV') div 100) <> 2 then
      Exit;
    FromFTP.ParseRemote(FromFTP.ResultString);
    s := ReplaceString(FromFTP.DataIP, '.', ',');
    s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256)
      + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256);
    if (ToFTP.FTPCommand(s) div 100) <> 2 then
      Exit;
    x := ToFTP.FTPCommand('RETR ' + FromFile);
    if (x div 100) <> 1 then
      Exit;
    x := FromFTP.FTPCommand('STOR ' + ToFile);
    if (x div 100) <> 1 then
      Exit;
    FromFTP.Timeout := 21600000;
    x := FromFTP.ReadResult;
    if (x  div 100) <> 2 then
      Exit;
    ToFTP.Timeout := 21600000;
    x := ToFTP.ReadResult;
    if (x div 100) <> 2 then
      Exit;
    Result := True;
  finally
    ToFTP.Free;
    FromFTP.Free;
  end;
end;

end.