ftpsrv.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

        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  := '0.0.0.0';
    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
            Inc(I);
        J := I;
        while (J <= Length(Params)) and (Params[J] in ['A'..'Z', 'a'..'z', '0'..'9']) do
            Inc(J);
        KeyWord := UpperCase(Copy(Params, I, J - I));

        { Extract parameters, ignoring leading spaces and tabs }
        while (J <= Length(Params)) and (Params[J] in [' ', #9]) do
            Inc(J);
        Params := Copy(Params, J, Length(Params));

        { Pass the command to the component user to let him a chance to }
        { handle it. If it does, he must return the answer.             }
        TriggerClientCommand(Client, Keyword, Params, Answer);
        if Answer <> '' then begin
            { Event handler has processed the client command, send the answer }
            SendAnswer(Client, Answer);
            Exit;
        end;

        { The command has not been processed, we'll process it }
        if Keyword = '' then begin
            { Empty keyword (should never occurs) }
            SendAnswer(Client, Format(msgCmdUnknown, [Params]));
            Exit;
        end;

        { We need to process the client command, search our command table }
        I := 0;
        while I <= High(FCmdTable) do begin
            if FCmdTable[I].KeyWord = KeyWord then begin
                FCmdTable[I].Proc(Client, KeyWord, Params, Answer);
                SendAnswer(Client, Answer);
                Exit;
            end;
            Inc(I);
        end;
        SendAnswer(Client, Format(msgCmdUnknown, [KeyWord]));
    except
        on E:Exception do begin
            SendAnswer(Client, '501 ' + E.Message);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientDataSent(Sender : TObject; Error : Word);
var
    Client  : TFtpCtrlSocket;
begin
    Client := Sender as TFtpCtrlSocket;
    if Client.CloseRequest then begin
        Client.CloseRequest := FALSE;
        PostMessage(FWindowHandle, WM_FTPSRV_CLOSE_REQUEST, 0, LongInt(Client));
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.ClientSessionClosed(Sender : TObject; Error : Word);
begin
    PostMessage(FWindowHandle, WM_FTPSRV_CLIENT_CLOSED, 0, LongInt(Sender));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WMFtpSrvClientClosed(var msg: TMessage);
var
    Client : TFtpCtrlSocket;
begin
    Client := TFtpCtrlSocket(Msg.LParam);
    try
        FClientList.Remove(Client);
        TriggerClientDisconnect(Client, Error);
    finally
        Client.Destroy;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WMFtpSrvAbortTransfer(var msg: TMessage);
var
    Data : TWSocket;
begin
    Data := TWSocket(Msg.LParam);
    Data.ShutDown(2);
    Data.Close;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.WMFtpSrvCloseData(var msg: TMessage);
var
    Data : TWSocket;
begin
    if msg.WParam > 0 then begin
{$IFNDEF VER80}
        Sleep(0);  { Release time slice }
{$ENDIF}
        PostMessage(FWindowHandle, Msg.Msg, msg.WParam - 1, msg.LParam);
    end
    else begin
        Data := TWSocket(Msg.LParam);
        Data.Close;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TFtpServer.GetClientCount : Integer;
begin
    if Assigned(FClientList) then
        Result := FClientList.Count
    else
        Result := 0;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerServerStart;
begin
    if Assigned(FOnStart) then
        FOnStart(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerServerStop;
begin
    if Assigned(FOnStop) then
        FOnStop(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TFtpServer.TriggerAuthenticate(