ftpsrvc.pas

互联网套件

{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Author:       Fran鏾is PIETTE
Description:  TFtpCtrlSocket component. It handle the client connection for
              the TFtpServer component.
EMail:        [e-mail]
              [e-mail]             http://www.rtfm.be/fpiette
Creation:     April 21, 1998
Version:      1.04
Support:      Use the mailing list [e-mail] See website for details.
Legal issues: Copyright (C) 1997, 1998, 1999 by Fran鏾is PIETTE
              Rue de Grady 24, 4053 Embourg, Belgium. Fax: [phone]
              <[e-mail]>

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely, subject to the following
              restrictions:

              1. The origin of this software must not be misrepresented,
                 you must not claim that you wrote the original software.
                 If you use this software in a product, an acknowledgment
                 in the product documentation would be appreciated but is
                 not required.

              2. Altered source versions must be plainly marked as such, and
                 must not be misrepresented as being the original software.

              3. This notice may not be removed or altered from any source
                 distribution.

              4. You must register this software by sending a picture postcard
                 to the author. Use a nice stamp and mention your name, street
                 address, EMail address and any comment you like to say.

History:
Apr 29, 1998  V0.90 released for beta testing.
May 03, 1998  V0.93 Adapted for Delphi 2.0 and C++Builder
May 04, 1998  V0.94 Added support for UNC (not finished !)
Jul 09, 1998  V1.00 Adapted for Delphi 4, removed beta status.
Jul 21, 1998  V1.01 Publised TrumpetCompatibility property.
Aug 06, 1998  V1.02 Verified that FRcvCnt was 0 in SetRcvSize. Suggested
              by Nick MacDonald <[e-mail]>
Mar 06, 1999  V1.03 Added code from  Plegge, Steve <[e-mail]> to add
              APPE and STRU support.
Aug 20, 1999  V1.04 Revised compile time options. Adapted for BCB4.

 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit FtpSrvC;

interface

{$B-}           { Enable partial boolean evaluation   }
{$T-}           { Untyped pointers                    }
{$X+}           { Enable extended syntax              }
{$IFNDEF VER80} { Not for Delphi 1                    }
    {$H+}       { Use long strings                    }
    {$J+}       { Allow typed constant to be modified }
{$ENDIF}
{$IFDEF VER110} { C++ Builder V3.0                    }
    {$ObjExportAll On}
{$ENDIF}
{$IFDEF VER125} { C++ Builder V4.0                    }
    {$ObjExportAll On}
{$ENDIF}

uses
    WinTypes, WinProcs, Messages, Classes, SysUtils, Winsock, WSocket;

const
    FtpCtrlSocketVersion = 104;
    CopyRight : String = ' TFtpCtrlSocket  (c) 1998, 1999 F. Piette V1.04 ';
    DefaultRcvSize       = 2048;

type
    EFtpCtrlSocketException = class(Exception);
    TFtpCtrlState = (ftpcInvalid, ftpcWaitingUserCode, ftpcWaitingPassword,
                     ftpcReady, ftpcWaitingAnswer);
    TFtpCmdType   = (ftpcPORT, ftpcSTOR, ftpcRETR, ftpcCWD,  ftpcXPWD, ftpcPWD,
                     ftpcUSER, ftpcPASS, ftpcLIST, ftpcRMD,  ftpcTYPE, ftpcSYST,
                     ftpcQUIT, ftpcDELE, ftpcRNFR, ftpcMKD,  ftpcRNTO, ftpcNOOP,
                     ftpcNLST, ftpcABOR, ftpcCDUP, ftpcSIZE, ftpcREST, ftpcAPPE,
                     ftpcSTRU);  {jsp - Added APPE and STRU types}
    TFtpOption    = (ftpcUNC);
    TFtpOptions   = set of TFtpOption;
    TDisplayEvent = procedure (Sender : TObject; Msg : String) of object;
    TCommandEvent = procedure (Sender : TObject; CmdBuf : PChar; CmdLen : Integer) of object;

    TFtpCtrlSocket = class(TCustomWSocket)
    protected
        FDataSocket        : TWSocket;
        FRcvBuf            : PChar;
        FRcvCnt            : Integer;
        FRcvSize           : Integer;
        FBusy              : Boolean;
        FConnectedSince    : TDateTime;
        FLastCommand       : TDateTime;
        FCommandCount      : LongInt;
        FBanner            : String;
        FUserName          : String;
        FPassWord          : String;
        FCloseRequest      : Boolean;
        FHomeDir           : String;
        FDirectory         : String;
        FFtpState          : TFtpCtrlState;
        FAbortingTransfer  : Boolean;
        FUserData          : LongInt;        { Reserved for component user }
        FPeerAddr          : String;
        FOnDisplay         : TDisplayEvent;
        FOnCommand         : TCommandEvent;
        procedure TriggerSessionConnected(Error : Word); override;
        function  TriggerDataAvailable(Error : Word) : boolean; override;
        procedure TriggerCommand(CmdBuf : PChar; CmdLen : Integer); virtual;
        procedure SetRcvSize(newValue : Integer);
    public
        BinaryMode        : Boolean;
        DataAddr          : String;
        DataPort          : String;
        FileName          : String;
        FilePath          : String;
        DataSessionActive : Boolean;
        DataStream        : TStream;
        HasOpenedFile     : Boolean;
        TransferError     : String;
        ByteCount         : LongInt;
        DataSent          : Boolean;
        CurCmdType        : TFtpCmdType;
        RestartPos        : LongInt;
        FromFileName      : String;
        ToFileName        : String;
        PassiveMode       : Boolean;
        PassiveStart      : Boolean;
        PassiveConnected  : Boolean;
        Options           : TFtpOptions;
        constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
        procedure   Dup(newHSocket : TSocket); override;
        procedure   StartConnection; virtual;
        procedure   SendAnswer(Answer : String);
        procedure   SetDirectory(newValue : String);
        procedure   SetAbortingTransfer(newValue : Boolean);
        function    GetPeerAddr: string; override;
        property    DataSocket     : TWSocket    read FDataSocket;
        property    ConnectedSince : TDateTime   read FConnectedSince;
        property    LastCommand    : TDateTime   read FLastCommand;
        property    CommandCount   : LongInt     read FCommandCount;
        property    RcvBuf         : PChar       read FRcvBuf;
        property    RcvdCount;
        property    CloseRequest   : Boolean     read  FCloseRequest
                                                 write FCloseRequest;
        property Directory : String              read  FDirectory
                                                 write SetDirectory;
        property HomeDir : String                read  FHomeDir
                                                 write FHomeDir;
        property AbortingTransfer : Boolean      read  FAbortingTransfer
                                                 write SetAbortingTransfer;
    published
        property FtpState : TFtpCtrlState  read  FFtpState
                                           write FFtpState;
        property Banner : String           read  FBanner
                                           write FBanner;
        property RcvSize : integer         read  FRcvSize
                                           write SetRcvSize;
        property Busy : Boolean            read  FBusy
                                           write FBusy;
        property UserName : String         read  FUserName
                                           write FUserName;
        property PassWord : String         read  FPassWord
                                           write FPassWord;
        property UserData  : LongInt       read  FUserData
                                           write FUserData;
        property OnDisplay : TDisplayEvent read  FOnDisplay
                                           write FOnDisplay;
        property OnCommand : TCommandEvent read  FOnCommand
                                           write FOnCommand;
        property OnSessionClosed;
        property OnDataSent;
        property HSocket;
        property AllSent;
        property State;
{$IFDEF VER80}
        property TrumpetCompability;
{$ENDIF}
    end;

function IsUNC(S : String) : Boolean;
{$IFDEF VER80}
function ExtractFileDir(const FileName: String): String;
function ExtractFileDrive(const FileName: String): String;
{$ENDIF}

implementation

const
    DefaultBanner = '220-ICS FTP Server ready';


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
procedure SetLength(var S: string; NewLength: Integer);
begin
    S[0] := chr(NewLength);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ ExtractFileDir extracts the drive and directory parts of the given        }
{ filename. The resulting string is a directory name suitable for passing   }
{ to SetCurrentDir, CreateDir, etc. The resulting string is empty if        }
{ FileName contains no drive and directory parts.                           }
function ExtractFileDir(const FileName: String): String;
var
    I: Integer;
begin
    I := Length(FileName);
    while (I > 0) and (not (FileName[I] in ['\', ':'])) do
        Dec(I);
    if (I > 1) and (FileName[I] = '\') and
       (not (FileName[I - 1] in ['\', ':'])) then
        Dec(I);
    Result := Copy(FileName, 1, I);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ ExtractFileDrive extracts the drive part of the given filename.  For        }
{ filenames with drive letters, the resulting string is '<drive>:'.           }
{ For filenames with a UNC path, the resulting string is in the form          }
{ '\\<servername>\<sharename>'.  If the given path contains neither           }
{ style of filename, the result is an empty string.                           }
function ExtractFileDrive(const FileName: String): String;
var
    I : Integer;
begin
    if Length(FileName) <= 1 then
        Result := ''
    else begin
        if FileName[2] = ':' then
            Result := Copy(FileName, 1, 2)
        else if (FileName[2] = '\') and (FileName[1] = '\') then begin
            { UNC file name }
            I := 3;
            while (I <= Length(FileName)) and (FileName[I] <> '\') do
                Inc(I);
            Result := Copy(FileName, 1, I - 1);
        end
        else
            Result := '';
    end;
end;
{$ENDIF}