?? ftpsrv.pas
字號:
i := Length(Str);
while (i > 0) and (Str[i] = ' ') do
i := i - 1;
Result := Copy(Str, 1, i);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TrimLeft(Str : String) : String;
var
i : Integer;
begin
if Str[1] <> ' ' then
Result := Str
else begin
i := 1;
while (i <= Length(Str)) and (Str[i] = ' ') do
i := i + 1;
Result := Copy(Str, i, Length(Str) - i + 1);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function Trim(Str : String) : String;
begin
Result := TrimLeft(TrimRight(Str));
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function GetFileSize(FileName : String) : LongInt;
var
SR : TSearchRec;
begin
if FindFirst(FileName, faReadOnly or faHidden or
faSysFile or faArchive, SR) = 0 then
Result := SR.Size
else
Result := -1;
FindClose(SR);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TFtpServer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FWindowHandle := AllocateHWnd(WndProc);
FServSocket := TWSocket.Create(Self);
FServSocket.Name := 'ServerWSocket';
FClientList := TList.Create;
FPort := 'ftp';
FAddr := '0.0.0.0';
FBanner := msgDftBanner;
FClientClass := TFtpCtrlSocket;
AddCommand('PORT', CommandPORT);
AddCommand('STOR', CommandSTOR);
AddCommand('RETR', CommandRETR);
AddCommand('CWD', CommandCWD);
AddCommand('XPWD', CommandXPWD);
AddCommand('PWD', CommandPWD);
AddCommand('USER', CommandUSER);
AddCommand('PASS', CommandPASS);
AddCommand('LIST', CommandLIST);
AddCommand('NLST', CommandNLST);
AddCommand('TYPE', CommandTYPE);
AddCommand('SYST', CommandSYST);
AddCommand('QUIT', CommandQUIT);
AddCommand('DELE', CommandDELE);
AddCommand('SIZE', CommandSIZE);
AddCommand('REST', CommandREST);
AddCommand('RNFR', CommandRNFR);
AddCommand('RNTO', CommandRNTO);
AddCommand('MKD', CommandMKD);
AddCommand('RMD', CommandRMD);
AddCommand('ABOR', CommandABOR);
AddCommand('PASV', CommandPASV);
AddCommand('NOOP', CommandNOOP);
AddCommand('CDUP', CommandCDUP);
AddCommand('APPE', CommandAPPE);
AddCommand('STRU', CommandSTRU);
AddCommand('XMKD', CommandMKD);
AddCommand('XRMD', CommandRMD);
AddCommand('MDTM', CommandMDTM);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TFtpServer.Destroy;
begin
if Assigned(FServSocket) then begin
FServSocket.Destroy;
FServSocket := nil;
end;
if Assigned(FClientList) then begin
FClientList.Destroy;
FClientList := nil;
end;
DeallocateHWnd(FWindowHandle);
inherited Destroy;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WndProc(var MsgRec: TMessage);
begin
with MsgRec do begin
case Msg of
WM_FTPSRV_CLOSE_REQUEST : WMFtpSrvCloseRequest(MsgRec);
WM_FTPSRV_CLIENT_CLOSED : WMFtpSrvClientClosed(MsgRec);
WM_FTPSRV_ABORT_TRANSFER : WMFtpSrvAbortTransfer(MsgRec);
WM_FTPSRV_CLOSE_DATA : WMFtpSrvCloseData(MsgRec);
else
Result := DefWindowProc(Handle, Msg, wParam, lParam);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WMFtpSrvCloseRequest(var msg: TMessage);
var
Client : TFtpCtrlSocket;
begin
Client := TFtpCtrlSocket(msg.LParam);
if Client.AllSent then
Client.Close
else
Client.CloseRequest := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.Notification(AComponent: TComponent; operation: TOperation);
begin
inherited Notification(AComponent, operation);
if operation = opRemove then begin
if AComponent = FServSocket then
FServSocket := nil;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.AddCommand(
const Keyword : String;
const Proc : TFtpSrvCommandProc);
begin
if FLastCmd > High(FCmdTable) then
raise FtpServerException.Create('Too many command');
FCmdTable[FLastCmd].KeyWord := KeyWord;
FCmdTable[FLastCmd].Proc := Proc;
Inc(FLastCmd);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.Start;
begin
if FServSocket.State = wsListening then
Exit; { Server is already running }
FServSocket.Port := Port;
FServSocket.Proto := 'tcp';
FServSocket.Addr := FAddr;
FServSocket.OnSessionAvailable := ServSocketSessionAvailable;
FServSocket.OnChangeState := ServSocketStateChange;
FServSocket.Listen;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.Stop;
begin
FServSocket.Close;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.DisconnectAll;
var
Client : TFtpCtrlSocket;
begin
while FClientList.Count > 0 do begin
Client := TFtpCtrlSocket(FClientList.Items[0]);
Client.Close;
FClientList.Remove(Client);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TFtpServer.GetActive : Boolean;
begin
Result := (FServSocket.State = wsListening);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.SetActive(newValue : Boolean);
begin
if newValue then
Start
else
Stop;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ServSocketStateChange(Sender : TObject; OldState, NewState : TSocketState);
begin
if csDestroying in ComponentState then
Exit;
if NewState = wsListening then
TriggerServerStart
else if NewState = wsClosed then
TriggerServerStop;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ServSocketSessionAvailable(Sender : TObject; Error : Word);
var
Client : TFtpCtrlSocket;
begin
if Error <> 0 then
raise FtpServerException.Create('Session available error #' + IntToStr(Error));
Inc(FClientNum);
Client := FClientClass.Create(Self);
FClientList.Add(Client);
Client.Name := 'ClientWSocket' + IntToStr(FClientNum);
Client.DataSocket.Name := 'DataWSocket' + IntToStr(FClientNum);
Client.Banner := FBanner;
Client.HSocket := ServSocket.Accept;
Client.OnCommand := ClientCommand;
Client.OnSessionClosed := ClientSessionClosed;
Client.OnDataSent := ClientDataSent;
TriggerClientConnect(Client, Error);
{ The event handler may have destroyed the client ! }
if FClientList.IndexOf(Client) < 0 then
Exit;
{ The event handler may have closed the connection }
if Client.State <> wsConnected then
Exit;
{ Ok, the client is still there, process with the connection }
if (FMaxClients > 0) and (FMaxClients < ClientCount) then begin
{ Sorry, toomuch clients }
Client.Banner := msgTooMuchClients;
Client.StartConnection;
Client.Close;
end
else
Client.StartConnection;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.SendAnswer(Client : TFtpCtrlSocket; Answer : TFtpString);
begin
try
TriggerSendAnswer(Client, Answer);
Client.SendAnswer(Answer);
except
{ Just ignore any exception here }
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientCommand(
Sender : TObject;
CmdBuf : PChar;
CmdLen : Integer);
const
TELNET_IAC = #255;
TELNET_IP = #244;
TELNET_DATA_MARK = #242;
var
Client : TFtpCtrlSocket;
Answer : TFtpString;
Params : TFtpString;
KeyWord : TFtpString;
I, J : Integer;
begin
Client := Sender as TFtpCtrlSocket;
Answer := '';
{ Copy the command received, removing any telnet option }
try
Params := '';
I := 0;
while I < CmdLen do begin
if CmdBuf[I] <> TELNET_IAC then begin
Params := Params + CmdBuf[I];
Inc(I);
end
else begin
Inc(I);
if CmdBuf[I] = TELNET_IAC then
Params := Params + CmdBuf[I];
Inc(I);
end;
end;
{ Extract keyword, ignoring leading spaces and tabs }
I := 1;
while (I <= Length(Params)) and (Params[I] in [' ', #9]) do
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -