📄 ftpsrv.pas
字号:
{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author: Fran鏾is PIETTE
Description: TFtpServer class encapsulate the FTP protocol (server side)
See RFC-959 for a complete protocol description.
EMail: francois.piette@pophost.eunet.be
francois.piette@rtfm.be http://www.rtfm.be/fpiette
Creation: April 21, 1998
Version: 1.06
Support: Use the mailing list twsocket@rtfm.be See website for details.
Legal issues: Copyright (C) 1997, 1998, 1999 by Fran鏾is 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 01, 1998 V0.92 Adapted for Delphi 1.0
May 03, 1998 V0.93 Adapted for Delphi 2.0 and C++Builder
May 04, 1998 V0.94 Use '/' or '\' as path delimiter. Expose only '/' to the
outside. Stripped any telnet options (IE send two !). Handled
absolute path. Implemented SIZE and REST commands.
Added support for UNC (not finished !)
May 06, 1998 V0.95 Corrected spurious 226 message on PASV mode STOR.
Made GetInteger retunrs a LongInt.
Use a LongInt for N in CommandPORT (needed for 16 bits)
Added slash substitution in BuildFilePath command.
Jul 09, 1998 V1.00 Adapted for Delphi 4, removed beta status.
Jul 21, 1998 V1.01 Added OnValidateDele event
Changed function to get file size (do not open the file)
Feb 14, 1999 V1.02 Replaced straight winsock call by indirect calls thru
wsocket (this provide runtime link to winsock DLL).
Mar 06, 1999 V1.03 Added code from Plegge, Steve <jsp@nciinc.com> to add
APPE, XMKD, KRMD and STRU commands support.
Jul 24, 1999 V1.04 Replaced msgStorDisabled value from '500 Cannot STOR.' to
'501 Permission Denied' because CuteFTP doesn't like error 500.
Suggested by Cedric Veilleux <webmaster@smashweb.com>.
Aug 20, 1999 V1.05 Added compile time options. Revised for BCB4.
Added Addr property to select interface in multihomed computers.
Oct 02, 1999 V1.06 Added OnValidateRnFr and OnValidateRnTo events.
Initialized Allowed variable to TRUE before triggerValidateDele.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit FtpSrv;
{$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}
interface
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Winsock, WSocket, FtpSrvC;
const
FtpServerVersion = 106;
CopyRight : String = ' TFtpServer (c) 1998 F. Piette V1.06 ';
WM_FTPSRV_CLOSE_REQUEST = WM_USER + 1;
WM_FTPSRV_CLIENT_CLOSED = WM_USER + 2;
WM_FTPSRV_ABORT_TRANSFER = WM_USER + 3;
WM_FTPSRV_CLOSE_DATA = WM_USER + 4;
type
FtpServerException = class(Exception);
{ Various Delphi and C++Builder version handle string parameter passed as var }
{ differently. To get application code compatible across all versions, we }
{ need to define our own string type. We use the larger we can with the given }
{ compiler version. btw: the 255 limit is not a problem because it applies to }
{ the command laines sent to the server and 255 should be enough except if }
{ you use incredibly long file names. }
{$IFDEF VER100} { Delphi 3 }
TFtpString = String;
{$ELSE} { All others }
TFtpString = String[255];
{$ENDIF}
TFtpCtrlSocketClass = class of TFtpCtrlSocket;
TFtpSrvAuthenticateEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
UserName : TFtpString;
Password : TFtpString;
var Authenticated : Boolean) of object;
TFtpSrvChangeDirectoryEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Directory : TFtpString;
var Allowed : Boolean) of object;
TFtpSrvBuildDirectoryEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var Directory : TFtpString;
Detailed : Boolean) of object;
TFtpSrvClientConnectEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Error : Word) of object;
TFtpSrvDataSessionConnectedEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word) of object;
TFtpSrvClientCommandEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString) of object;
TFtpSrvAnswerToClientEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var Answer : TFtpString) of object;
TFtpSrvValidateXferEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean) of object;
TFtpSrvDataAvailableEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Data : TWSocket;
Buf : PChar;
Len : LongInt;
Error : Word) of object;
TFtpSrvRetrDataSentEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word) of object;
TFtpSrvCommandProc = procedure (Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString) of object;
TFtpSrvCommandTableItem = record
KeyWord : String;
Proc : TFtpSrvCommandProc;
end;
TFtpServer = class(TComponent)
protected
FAddr : String;
FPort : String;
FBanner : String;
FServSocket : TWSocket;
FWindowHandle : HWND;
FClientClass : TFtpCtrlSocketClass;
FClientList : TList;
FClientNum : LongInt;
FMaxClients : LongInt;
FCmdTable : array [0..31] of TFtpSrvCommandTableItem;
FLastCmd : Integer;
FUserData : LongInt; { Reserved for component user }
FOnStart : TNotifyEvent;
FOnStop : TNotifyEvent;
FOnAuthenticate : TFtpSrvAuthenticateEvent;
FOnClientConnect : TFtpSrvClientConnectEvent;
FOnClientDisconnect : TFtpSrvClientConnectEvent;
FOnClientCommand : TFtpSrvClientCommandEvent;
FOnAnswerToClient : TFtpSrvAnswerToClientEvent;
FOnChangeDirectory : TFtpSrvChangeDirectoryEvent;
FOnMakeDirectory : TFtpSrvChangeDirectoryEvent;
FOnBuildDirectory : TFtpSrvBuildDirectoryEvent;
FOnAlterDirectory : TFtpSrvBuildDirectoryEvent;
FOnValidatePut : TFtpSrvValidateXferEvent;
FOnValidateDele : TFtpSrvValidateXferEvent;
FOnValidateRnFr : TFtpSrvValidateXferEvent;
FOnValidateRnTo : TFtpSrvValidateXferEvent;
FOnStorSessionConnected : TFtpSrvDataSessionConnectedEvent;
FOnStorSessionClosed : TFtpSrvDataSessionConnectedEvent;
FOnStorDataAvailable : TFtpSrvDataAvailableEvent;
FOnValidateGet : TFtpSrvValidateXferEvent;
FOnRetrSessionConnected : TFtpSrvDataSessionConnectedEvent;
FOnRetrSessionClosed : TFtpSrvDataSessionConnectedEvent;
FOnRetrDataSent : TFtpSrvRetrDataSentEvent;
procedure Notification(AComponent: TComponent; operation: TOperation); override;
procedure ServSocketSessionAvailable(Sender : TObject; Error : Word);
procedure ServSocketStateChange(Sender : TObject; OldState, NewState : TSocketState);
procedure ClientSessionClosed(Sender : TObject; Error : Word);
procedure ClientDataSent(Sender : TObject; Error : Word);
procedure ClientCommand(Sender : TObject; CmdBuf : PChar; CmdLen : Integer);
procedure ClientPassiveSessionAvailable(Sender : TObject; Error : Word);
procedure ClientStorSessionConnected(Sender : TObject; Error : Word);
procedure ClientStorSessionClosed(Sender : TObject; Error : Word);
procedure ClientStorDataAvailable(Sender: TObject; Error : word);
procedure ClientRetrSessionConnected(Sender : TObject; Error : Word);
procedure ClientRetrSessionClosed(Sender : TObject; Error : Word);
procedure ClientRetrDataSent(Sender : TObject; Error : Word);
procedure SendAnswer(Client : TFtpCtrlSocket; Answer : TFtpString);
procedure SendNextDataChunk(Client : TFtpCtrlSocket; Data : TWSocket);
procedure StartSendData(Client : TFtpCtrlSocket);
procedure BuildDirectory(Client : TFtpCtrlSocket; var Params : TFtpString; Stream : TStream; Detailed : Boolean);
procedure TriggerServerStart; virtual;
procedure TriggerServerStop; virtual;
procedure TriggerAuthenticate(Client : TFtpCtrlSocket;
UserName : String;
PassWord : String;
var Authenticated : Boolean); virtual;
procedure TriggerChangeDirectory(Client : TFtpCtrlSocket;
Directory : String;
var Allowed : Boolean); virtual;
procedure TriggerMakeDirectory(Client : TFtpCtrlSocket;
Directory : String;
var Allowed : Boolean); virtual;
procedure TriggerBuildDirectory(Client : TFtpCtrlSocket;
var Params : TFtpString;
Detailed : Boolean);
procedure TriggerAlterDirectory(Client : TFtpCtrlSocket;
var Params : TFtpString;
Detailed : Boolean);
procedure TriggerSendAnswer(Client : TFtpCtrlSocket;
var Answer : TFtpString); virtual;
procedure TriggerClientConnect(Client : TFtpCtrlSocket; Error : Word); virtual;
procedure TriggerClientDisconnect(Client : TFtpCtrlSocket; Error : Word); virtual;
procedure TriggerClientCommand(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure TriggerStorSessionConnected(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
procedure TriggerStorSessionClosed(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
procedure TriggerValidatePut(Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean); virtual;
procedure TriggerValidateDele(Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean); virtual;
procedure TriggerValidateRnFr(Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean); virtual;
procedure TriggerValidateRnTo(Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean); virtual;
procedure TriggerRetrSessionConnected(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
procedure TriggerRetrSessionClosed(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
procedure TriggerValidateGet(Client : TFtpCtrlSocket;
var FilePath : TFtpString;
var Allowed : Boolean); virtual;
procedure TriggerStorDataAvailable(Client : TFtpCtrlSocket;
Data : TWSocket;
Buf : PChar;
Len : LongInt;
Error : Word); virtual;
procedure TriggerRetrDataSent(Client : TFtpCtrlSocket;
Data : TWSocket;
Error : Word); virtual;
function GetClientCount : Integer; virtual;
function GetActive : Boolean;
procedure SetActive(newValue : Boolean);
procedure AddCommand(const Keyword : String;
const Proc : TFtpSrvCommandProc); virtual;
procedure WMFtpSrvCloseRequest(var msg: TMessage);
message WM_FTPSRV_CLOSE_REQUEST;
procedure WMFtpSrvClientClosed(var msg: TMessage);
message WM_FTPSRV_CLIENT_CLOSED;
procedure WMFtpSrvAbortTransfer(var msg: TMessage);
message WM_FTPSRV_ABORT_TRANSFER;
procedure WMFtpSrvCloseData(var msg: TMessage);
message WM_FTPSRV_CLOSE_DATA;
procedure CommandDirectory(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString;
Detailed : Boolean);
procedure CommandUSER(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandPASS(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandQUIT(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
var Answer : TFtpString); virtual;
procedure CommandNOOP(Client : TFtpCtrlSocket;
var Keyword : TFtpString;
var Params : TFtpString;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -