nmftp.pas

来自「DELPHI里面一些常用的控件」· PAS 代码 · 共 1,630 行 · 第 1/5 页

unit NMFtp;
{$X+}
{$R-}

{$IFDEF VER100}
{$DEFINE NMF3}
{$ENDIF}
{$IFDEF VER110}
{$DEFINE NMF3}
{$ENDIF}
{$IFDEF VER120}
{$DEFINE NMF3}
{$ENDIF}
{$IFDEF VER125}
{$DEFINE NMF3}
{$ENDIF}

interface

uses
  SysUtils, WinProcs, Classes, PSock, Forms, WinSock, NMConst;
{$IFDEF VER110}
{$OBJEXPORTALL On}
{$ENDIF}
{$IFDEF VER120}
{$OBJEXPORTALL On}
{$ENDIF}
{$IFDEF VER125}
{$OBJEXPORTALL On}
{$ENDIF}

const

   {Transmission Type}
  MODE_ASCII = 1;
  MODE_IMAGE = 2;
  MODE_BYTE = 3;

   //  CompName     ='NMFTP';
   //  Major_Version='4';
   //  Minor_Version='02';
   //  Date_Version ='012798';

const {protocol}
  Cont_Quit = 'QUIT';
  Cont_User = 'USER ';
  Cont_Pass = 'PASS ';
  Cont_Cwd = 'CWD ';
  Cont_Rnfr = 'RNFR ';
  Cont_Rnto = 'RNTO ';
  Cont_Dele = 'DELE ';
  Cont_Mkd = 'MKD ';
  Cont_Rmd = 'RMD ';
  Cont_Port = 'PORT ';
  Cont_List = 'LIST';
  Cont_Nlst = 'NLST';
  Cont_Retr = 'RETR ';
  Cont_Stou = 'STOU';
  Cont_Stor = 'STOR ';
  Cont_Pwd = 'PWD';
  Cont_Typ = 'TYPE ';
  No_Byte = 'BYTE';
  Cont_Rein = 'REIN';
  Cont_Allo = 'ALLO ';
  Cont_Appe = 'APPE ';
  Cont_Rest = 'REST ';



const
  NMOS_UNKNOWN = -1;
  NMOS_FIRST = 2400;
  NMOS_UNIX = 2400;
  NMOS_WINDOWS = 2401;
  NMOS_VM = 2402;
  NMOS_BULL = 2403;
  NMOS_MAC = 2404;
  NMOS_TOPS20 = 2405;
  NMOS_VMS = 2406;
  NMOS_OS2 = 2407;
  NMOS_MVS_IBM = 2408;
  NMOS_MVS_INTERLINK = 2409;
  NMOS_OTHER = 2410;
  NMOS_AUTO = 2411;
  NMOS_NT = 2412;
  NMOS_TANDEM = 2413;
  NMOS_AS400 = 2414;
  NMOS_OS9 = 2415;
  NMOS_NETWARE = 2416;

type
  TFirewallType = (FTUser, FtOpen, FtSite);

  TFTPDirectoryList = class(TObject)
  private
    FAttribute, FName, FModifDate, FSize: TStringList;
    tokens: array[1..25] of shortstring;
    NoTokens: integer;
  protected
  public
    constructor Create;
    destructor Destroy; override;
    procedure ParseLine(Line: string); virtual;
    procedure Clear;
    property Attribute: TStringList read FAttribute;
    property Name: TStringList read FName;
    property Size: TStringList read FSize;
    property ModifDate: TStringList read FModifDate;
  published

  end; {_ TFTPDirectoryList = class(TObject) _}

  TFTPUnixList = class(TFTPDirectoryList)
  public
    procedure ParseLine(Line: string); override;
  end; {_ TFTPUnixList = class(TFTPDirectoryList) _}

  TFTPNETWAREList = class(TFTPDirectoryList)
  public
    procedure ParseLine(Line: string); override;
  end; {_ TFTPNETWAREList = class(TFTPDirectoryList) _}

  TFTPDOSList = class(TFTPDirectoryList)
  public
    procedure ParseLine(Line: string); override;
  end; {_ TFTPDOSList = class(TFTPDirectoryList) _}
  TFTPVMSList = class(TFTPDirectoryList)
  public
    procedure ParseLine(Line: string); override;
  end; {_ TFTPVMSList = class(TFTPDirectoryList) _}
  TFTPMVSList = class(TFTPDirectoryList)
  public
    procedure ParseLine(Line: string); override;
  end; {_ TFTPMVSList = class(TFTPDirectoryList) _}
  TFTPVMList = class(TFTPDirectoryList)
  public
    procedure ParseLine(Line: string); override;
  end; {_ TFTPVMList = class(TFTPDirectoryList) _}
  TFTPMACOSList = class(TFTPDirectoryList)
  public
    procedure ParseLine(Line: string); override;
  end; {_ TFTPMACOSList = class(TFTPDirectoryList) _}
  TFTPAS400List = class(TFTPDirectoryList)
  public
    procedure ParseLine(Line: string); override;
  end; {_ TFTPAS400List = class(TFTPDirectoryList) _}
  TFTPOTHERList = class(TFTPDirectoryList)
  public
    procedure ParseLine(Line: string); override;
  end; {_ TFTPOTHERList = class(TFTPDirectoryList) _}

type


  TCmdType = (cmdChangeDir,
    cmdMakeDir,
    cmdDelete,
    cmdRemoveDir,
    cmdList,
    cmdRename,
    cmdUpRestore,
    cmdDownRestore,
    cmdDownload,
    cmdUpload,
    cmdAppend,
    cmdReInit,
    cmdAllocate,
    cmdNList,
    cmdDoCommand,
    cmdCurrentDir);

  FTPException = class(Exception); {FTP Exceptions}
  TFailureEvent = procedure(var Handled: Boolean; Trans_Type: TCmdType) of object;
  TSuccessEvent = procedure(Trans_Type: TCmdType) of object;
  TUnsupportedEvent = procedure(Trans_Type: TCmdType) of object;
  TNMListItem = procedure(Listing: string) of object;

   {*******************************************************************************************
   FTP Class Definition
   ********************************************************************************************}

  TNMFTP = class(TPowersock)
  private
    ProcessLock: TRTLCriticalSection;
    FUserID, FPassword: string; {Password and User ID strings}
    FPassive: Boolean;
    DataSocket: TPowersock; {Socket for Data Transfers}
    FTransactionStart, FTransactionStop: TNotifyEvent; {Handler after each packet received for progress reports etc}
    FOnSuccess: TSuccessEvent;
    FOnFailure: TFailureEvent;
    FOnAuthenticationNeeded: THandlerEvent;
    FOnAuthenticationFailed: THandlerEvent;
    FOnListItem: TNMListItem;
    FOnConnect: TNotifyEvent;
    FOnUnSupportedFunction: TUnsupportedEvent;
    FVendor: integer;
    FFTPDirectoryList: TFTPDirectoryList;
    FParseList: Boolean;
    FFirewallType: TFirewallType;
      // Added these 2 property containers to support user ID and password
      // with firewalls
    FFWUserID, FFWPassword: string;
      // Added FFWAuth property container for optional firewall authentication

    FFWAuth: Boolean;
    FListMask: string;
    function GetBytesRcvd: Longint;
    function GetBytesSent: Longint;
    function GetBytesTotal(Replymess: string): Longint;
    function Transaction(const CommandString: string): string; override;
    procedure CheckRead(Sender: TObject);
    function GetCurrentDir: string;
    procedure ReadExtraLines(Replymess: string);
    procedure Flush;
      { FTPStatus:TStringEvent ;  }
  protected
      { Protected declarations }
  public
    constructor Create(AOwner: TComponent); override;
    procedure Connect; override;
    destructor Destroy; override;
    procedure Disconnect; override;
    procedure DoCommand(CommandStr: string);
    procedure ChangeDir(DirName: string);
    procedure Mode(TheMode: integer);
    procedure Delete(Filename: string);
    procedure MakeDirectory(DirectoryName: string);
    procedure RemoveDir(DirectoryName: string);
    procedure List;
    procedure Rename(Filename, FileName2: string);
    procedure Download(RemoteFile, LocalFile: string);
    procedure DownloadRestore(RemoteFile, LocalFile: string);
    procedure Upload(LocalFile, RemoteFile: string);
    procedure UploadUnique(LocalFile: string);
    procedure UploadAppend(LocalFile, RemoteFile: string);
    procedure UploadRestore(LocalFile, RemoteFile: string; Position: integer);
    procedure Reinitialize;
    procedure Allocate(FileSize: integer);
    procedure Nlist;
    procedure Abort; override;
    property CurrentDir: string read GetCurrentDir;
    property BytesSent: Longint read GetBytesSent;
    property BytesRecvd: Longint read GetBytesRcvd;
    property FTPDirectoryList: TFTPDirectoryList read FFTPDirectoryList;
  published
    property OnPacketRecvd;
    property OnPacketSent;
    property OnError;
    property OnConnectionRequired;
    property OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
    property UserID: string read FUserID write FUserID;
    property Password: string read FPassword write FPassword;
    property OnTransactionStart: TNotifyEvent read FTransactionStart write FTransactionStart;
    property OnTransactionStop: TNotifyEvent read FTransactionStop write FTransactionStop;
    property OnAuthenticationNeeded: THandlerEvent read FOnAuthenticationNeeded write FOnAuthenticationNeeded;
    property OnAuthenticationFailed: THandlerEvent read FOnAuthenticationFailed write FOnAuthenticationFailed;
    property OnFailure: TFailureEvent read FOnFailure write FOnFailure;
    property OnSuccess: TSuccessEvent read FOnSuccess write FOnSuccess;
    property OnListItem: TNMListItem read FOnListItem write FOnListItem;
    property OnUnSupportedFunction: TUnsupportedEvent read FOnUnSupportedFunction write FOnUnSupportedFunction;
    property Vendor: integer read FVendor write FVendor;
    property ParseList: Boolean read FParseList write FParseList;
    property Proxy;
    property ProxyPort;
    property Passive: Boolean read FPassive write FPassive;
    property FirewallType: TFirewallType read FFirewallType write FFirewallType;
      // Added these 2 properties to support user ID and password with firewalls
    property FWUserID: string read FFWUserID write FFWUserID;
    property FWPassword: string read FFWPassword write FFWPassword;

// Added FWAuthenticate for optional firewall authentication
    property FWAuthenticate: Boolean read FFWAuth write FFWAuth;
    property ListMask: string read FListMask write FListMask;

  end; {_ TNMFTP            = class(TPowersock) _}

implementation

constructor TFTPDirectoryList.Create;
begin
  inherited Create;
  FAttribute := TStringList.Create;
  FName := TStringList.Create;
  FModifDate := TStringList.Create;
  FSize := TStringList.Create;
end; {_ constructor TFTPDirectoryList.Create; _}

destructor TFTPDirectoryList.Destroy;
begin
  FAttribute.free;
  FModifDate.free;
  FName.free;
  FSize.free;
  inherited Destroy;
end; {_ destructor TFTPDirectoryList.Destroy; _}

procedure TFTPDirectoryList.ParseLine(Line: string);
var

  i, j: integer;

  procedure skipblanks;
  begin

    repeat
      inc(j)
    until (Line[j] <> ' ') or (j > Length(Line));
  end; {_ repeat _}

begin
  for i := 1 to 25 do tokens[i] := ''; //clear tokens;
  i := 1;
  j := 1;
  tokens[1] := '';
  repeat
    if Line[j] <> ' ' then
    begin
      tokens[i] := tokens[i] + Line[j];
      inc(j)
    end {_ if line[i] <> ' ' then _}
    else {_ NOT if line[i] <> ' ' then _}
    begin
      inc(i);
      tokens[i] := '';
      skipblanks;
    end; {_ NOT if line[i] <> ' ' then _}