www.pudn.com > ftpsrv.zip > FTPSRVC.PAS, change:1999-07-17,size:18462b


{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
 
Author:       François PIETTE 
Description:  TFtpCtrlSocket component. It handle the client connection for 
              the TFtpServer component. 
EMail:        francois.piette@pophost.eunet.be 
              francois.piette@rtfm.be             http://www.rtfm.be/fpiette 
Creation:     April 21, 1998 
Version:      1.03 
Support:      Use the mailing list twsocket@rtfm.be See website for details. 
Legal issues: Copyright (C) 1997, 1998 by François PIETTE 
              Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56 
              <francois.piette@pophost.eunet.be> 
 
              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 <NickM@futurepace.net> 
Mar 06, 1999  V1.03 Added code from  Plegge, Steve <jsp@nciinc.com> to add 
              APPE and STRU support. 
 
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
unit FtpSrvC; 
 
interface 
 
{$B-}           { Enable partial boolean evaluation   } 
{$T-}           { Untyped pointers                    } 
{$IFNDEF VER80} 
    {$J+}       { Allow typed constant to be modified } 
{$ENDIF} 
{$IFDEF VER110} { C++ Builder V3.0                    } 
    {$ObjExportAll On} 
{$ENDIF} 
 
uses 
    WinTypes, WinProcs, Messages, Classes, SysUtils, Winsock, WSocket; 
 
const 
    FtpCtrlSocketVersion = 103; 
    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} 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
constructor TFtpCtrlSocket.Create(AOwner: TComponent); 
begin 
    inherited Create(AOwner); 
    FDataSocket      := TWSocket.Create(Self); 
    FDataSocket.Name := 'DataWSocket'; 
    FBanner          := DefaultBanner; 
    FFtpState        := ftpcInvalid; 
    FHomeDir         := 'C:\TEMP\'; 
    FDirectory       := FHomeDir; 
    SetRcvSize(DefaultRcvSize); 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
destructor TFtpCtrlSocket.Destroy; 
begin 
    SetRcvSize(0);     { Free the buffer } 
    if Assigned(FDataSocket) then begin 
        FDataSocket.Destroy; 
        FDataSocket := nil; 
    end; 
    inherited Destroy; 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
procedure TFtpCtrlSocket.SetRcvSize(newValue : Integer); 
begin 
    if FRcvCnt <> 0 then 
        raise EFtpCtrlSocketException.Create('Data in buffer, can''t change size'); 
 
    if FRcvSize < 0 then 
        FRcvSize := 0; 
 
    if FRcvSize = newValue then 
        Exit; { No change, nothing to do } 
 
    { Free previously allocated buffer } 
    if FRcvBuf <> nil then begin 
        FreeMem(FRcvBuf, FRcvSize); 
        FRcvBuf := nil; 
    end; 
 
    { Allocate new buffer } 
    FRcvSize := newValue; 
 
    { If size is nul, then do not allocated the buffer } 
    if newValue > 0 then 
        GetMem(FRcvBuf, FRcvSize); 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
procedure TFtpCtrlSocket.StartConnection; 
begin 
    FConnectedSince := Now; 
    FLastCommand    := 0; 
    FCommandCount   := 0; 
    FFtpState       := ftpcWaitingUserCode; 
    SendStr(FBanner + #13#10); 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
function TFtpCtrlSocket.GetPeerAddr: String; 
begin 
    Result := FPeerAddr; 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
procedure TFtpCtrlSocket.Dup(newHSocket : TSocket); 
begin 
    inherited Dup(newHSocket); 
    FPeerAddr := inherited GetPeerAddr; 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
procedure TFtpCtrlSocket.TriggerSessionConnected(Error : Word); 
begin 
    FPeerAddr := inherited GetPeerAddr; 
    inherited TriggerSessionConnected(Error); 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
procedure TFtpCtrlSocket.TriggerCommand(CmdBuf : PChar; CmdLen : Integer); 
begin 
    if Assigned(FOnCommand) then 
        FOnCommand(Self, CmdBuf, CmdLen); 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
function TFtpCtrlSocket.TriggerDataAvailable(Error : Word) : Boolean; 
var 
    Len  : Integer; 
    I    : Integer; 
begin 
    Result := TRUE;                                { We read data } 
 
    Len := Receive(@FRcvBuf[FRcvCnt], FRcvSize - FRcvCnt - 1); 
    if Len <= 0 then 
        Exit; 
 
    FRcvCnt := FRcvCnt + Len; 
    FRcvBuf[FRcvCnt] := #0; 
 
    while TRUE do begin 
        I := 0; 
        while (I < FRcvCnt) and (FRcvBuf[I] <> #10) do 
            Inc(I); 
        if I >= FRcvCnt then 
            Exit; 
        FRcvBuf[I] := #0; 
        FLastCommand := Now; 
        Inc(FCommandCount); 
        if (I > 1) and (FRcvBuf[I - 1] = #13) then begin 
            FRcvBuf[I - 1] := #0; 
            TriggerCommand(FRcvBuf, I - 1); 
            FRcvBuf[I - 1] := #13; 
        end 
        else 
            TriggerCommand(FRcvBuf, I); 
 
        FRcvBuf[I] := #10; 
        if I >= (FRcvCnt - 1) then begin 
            FRcvCnt    := 0; 
            FRcvBuf[0] := #0; 
            break; 
        end; 
        Move(FRcvBuf[I + 1], FRcvBuf^, FRcvCnt - I); 
        FRcvCnt := FRcvCnt - I - 1; 
    end; 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
procedure TFtpCtrlSocket.SendAnswer(Answer : String); 
begin 
    SendStr(Answer + #13#10); 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
function IsUNC(S : String) : Boolean; 
begin 
    Result := (Length(S) >= 2) and (S[2] = '\') and (S[1] = '\'); 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
procedure TFtpCtrlSocket.SetDirectory(newValue : String); 
var 
    newDrive : String; 
    newPath  : String; 
    I        : Integer; 
begin 
    if FDirectory = newValue then 
        Exit; 
 
    newDrive := ExtractFileDrive(newValue); 
    if IsUNC(newDrive) then begin 
        if not (ftpcUNC in Options) then 
            raise Exception.Create('Cannot accept UNC path'); 
        FDirectory := newValue; 
        { Always terminate with a backslash } 
        if (Length(FDirectory) > 0) and (FDirectory[Length(FDirectory)] <> '\') then 
            FDirectory := FDirectory + '\'; 
        Exit; 
    end; 
 
    if Length(newDrive) = 0 then begin 
        newDrive := ExtractFileDrive(FDirectory); 
        newPath  := newValue; 
    end 
    else 
        newPath := Copy(newValue, 3, Length(newValue)); 
 
    if Pos(':', newPath) <> 0 then 
        raise Exception.Create('Invalid directory name syntax'); 
 
    if newPath = '..' then begin 
        if IsUNC(FDirectory) then begin 
            I := Length(FDirectory) - 1; 
            while (I > 0) and (FDirectory[I] <> '\') do 
                Dec(I); 
            if I > Length(newDrive) then 
                SetLength(FDirectory, I); 
            Exit; 
        end 
        else begin 
            newPath := Copy(FDirectory, 3, Length(FDirectory)); 
            I := Length(newPath) - 1; 
            while (I > 0) and (newPath[I] <> '\') do 
                Dec(I); 
            SetLength(newPath, I); 
        end; 
    end; 
 
    if (Length(newPath) > 0) and (newPath[1] <> '\') then begin 
        { Relative path } 
        if IsUNC(FDirectory) then begin 
            FDirectory := FDirectory + newPath; 
            { Always terminate with a backslash } 
            if (Length(FDirectory) > 0) and (FDirectory[Length(FDirectory)] <> '\') then 
                FDirectory := FDirectory + '\'; 
            Exit; 
        end 
        else begin 
            if UpperCase(newDrive[1]) <> UpperCase(FDirectory[1]) then 
                raise Exception.Create('Cannot accept path not relative to current directory'); 
            if Pos('.\', newPath) <> 0 then 
                raise Exception.Create('Cannot accept relative path using dot notation'); 
            if newPath = '.' then 
                newPath := Copy(FDirectory, 3, Length(FDirectory)) 
            else 
                newPath := Copy(FDirectory, 3, Length(FDirectory)) + newPath; 
        end; 
    end 
    else begin 
        if Pos('.\', newPath) <> 0 then 
            raise Exception.Create('Cannot accept relative path using dot notation'); 
    end; 
 
    if Length(newPath) = 0 then begin 
        if UpperCase(newDrive[1]) <> UpperCase(FDirectory[1]) then 
            newPath := '\' 
        else 
            newPath := Copy(FDirectory, 3, Length(FDirectory)); 
    end; 
 
    { Always terminate with a backslash } 
    if (Length(newPath) > 0) and (newPath[Length(newPath)] <> '\') then 
        newPath := newPath + '\'; 
 
    FDirectory := newDrive + newPath; 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
procedure TFtpCtrlSocket.SetAbortingTransfer(newValue : Boolean); 
begin 
    FAbortingTransfer := newValue; 
end; 
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} 
 
end.