📄 ftpsrv.pas
字号:
{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author: Fran鏾is PIETTE
Description: TFtpServer class encapsulate the FTP protocol (server side)
See RFC-959 for a complete protocol description.
Creation: April 21, 1998
Version: 1.19
EMail: http://www.overbyte.be francois.piette@overbyte.be
http://www.rtfm.be/fpiette francois.piette@rtfm.be
francois.piette@pophost.eunet.be
Support: Use the mailing list twsocket@elists.org
Follow "support" link at http://www.overbyte.be for subscription.
Legal issues: Copyright (C) 1998-2001 by Fran鏾is PIETTE
Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56
<francois.piette@pophost.eunet.be><francois.piette@overbyte.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.
Nov 24, 1999 V1.07 Added MTDM support. Thanks to Bruce Christensen
<bkc51831234@hotmail.com> for his code.
Jan 24, 2000 V1.08 Patch IE5 bug in file names. Thanks to <dsnake@infonie.fr>
Jun 08, 2000 V1.09 Added 'A N' type for type command for AIX systems.
Oct 25, 2000 V1.10 Exposed list of clients thru Client[] property.
Oct 29, 2000 V1.11 Added IsClient() method.
Implemented OnValidateRmd event.
Nov 01, 2000 V1.12 Implemented proposals from Carl@Smotricz.com:
(1) support for MODE command, but only the default do-nothing
option S. (2) binding the data socket to the local host address
and port 20 ('ftp-data'). (3) detection of failure to open the
data connection for STOR or RETR.
Added option wsoNoReceiveLoop to sockets. See comments in TWSocket
about this option. Help in very fast LAN.
Nov 11, 2000 V1.13 Checked for DOS attack. Close connection when buffer
overflow occured. Thanks to Lester <les@lester.co.uk> for finding
this security hole.
Jun 18, 2001 V1.14 Fixed file left open when storing and client broken data
connection. Thanks to Davie <smatters@smatters.com>
Jul 27, 2001 V1.15 I fixed a race condition between WMFtpSrvClientClosed and
WMFtpSrvCloseData found by Matthew Comb <matt@filesafe.co.nz> who
worked with Davie <smatters@smatters.com>. Now WMFtpSrvCloseData
receive Client in LParam and check if client is still in client
list.
Fixed a but with resumed put. Thanks Yvan Turkan iturcan@gamo.sk !
Added a procedure to disconnect a single client.
Changed all Exception by FtpServerException.
Changed all "Error" by "AError" to avoid conflict with global var.
Added Client.ID property to uniquely indentify the client. Pass
this ID along with all posted messages and verify if the correct
client still exists when message is processed.
Jul 30, 2001 V1.16 Added same check as above for WMFtpSrvCloseData.
Sep 09, 2001 V1.17 Eric Pascual <e.pascual@cstb.fr> added Store Unique (STOU)
command.
Feb 26, 2002 V1.18 Fastream Technologies (http://www.fastream.com) found a bug
in Disconnect and DisconnectAll which prevented data connection
to be closed and client component to be destroyed.
Jul 06, 2002 V1.19 Fastream Technologies (http://www.fastream.com) fixed
CommandXPWD and CommandPWD to make the path in answer as
"/c:/windows" instead of "c:/windows" which is more compatible
with the UNIX standard that most clients expect.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
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}
{$DEFINE BIND_FTP_DATA}
interface
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Winsock, WSocket, FtpSrvC, FtpSrvT;
const
FtpServerVersion = 119;
CopyRight : String = ' TFtpServer (c) 1998-2002 F. Piette V1.19 ';
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;
WM_FTPSRV_START_SEND = WM_USER + 5;
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 lines 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}
{$IFDEF VER80}
WPARAM = WORD;
LPARAM = DWORD;
{$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;
AError : Word) of object;
TFtpSrvDataSessionConnectedEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Data : TWSocket;
AError : 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;
AError : Word) of object;
TFtpSrvRetrDataSentEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
Data : TWSocket;
AError : Word) of object;
TFtpSrvGetUniqueFileNameEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var FileName : TFtpString) of object;
TFtpSrvGetProcessingEvent = procedure (Sender : TObject;
Client : TFtpCtrlSocket;
var DelayedSend : Boolean) 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;
FOnValidateRmd : TFtpSrvValidateXferEvent;
FOnValidateRnFr : TFtpSrvValidateXferEvent;
FOnValidateRnTo : TFtpSrvValidateXferEvent;
FOnStorSessionConnected : TFtpSrvDataSessionConnectedEvent;
FOnStorSessionClosed : TFtpSrvDataSessionConnectedEvent;
FOnStorDataAvailable : TFtpSrvDataAvailableEvent;
FOnValidateGet : TFtpSrvValidateXferEvent;
FOnRetrSessionConnected : TFtpSrvDataSessionConnectedEvent;
FOnRetrSessionClosed : TFtpSrvDataSessionConnectedEvent;
FOnRetrDataSent : TFtpSrvRetrDataSentEvent;
FOnGetUniqueFileName : TFtpSrvGetUniqueFileNameEvent ;
FOnGetProcessing : TFtpSrvGetProcessingEvent;
procedure Notification(AComponent: TComponent; operation: TOperation); override;
procedure ServSocketSessionAvailable(Sender : TObject; AError : Word);
procedure ServSocketStateChange(Sender : TObject; OldState, NewState : TSocketState);
procedure ClientSessionClosed(Sender : TObject; AError : Word);
procedure ClientDataSent(Sender : TObject; AError : Word);
procedure ClientCommand(Sender : TObject; CmdBuf : PChar; CmdLen : Integer);
procedure ClientPassiveSessionAvailable(Sender : TObject; AError : Word);
procedure ClientStorSessionConnected(Sender : TObject; AError : Word);
procedure ClientStorSessionClosed(Sender : TObject; AError : Word);
procedure ClientStorDataAvailable(Sender: TObject; AError : word);
procedure ClientRetrSessionConnected(Sender : TObject; AError : Word);
procedure ClientRetrSessionClosed(Sender : TObject; AError : Word);
procedure ClientRetrDataSent(Sender : TObject; AError : 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;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -