idcmdtcpserver.pas

网络控件适用于Delphi6

begin
  Result := TIdReplyRFC;
end;

function TIdCmdTCPServer.GetRepliesClass: TIdRepliesClass;
begin
  Result := TIdRepliesRFC;
end;

destructor TIdCmdTCPServer.Destroy;
begin
  inherited Destroy;
  FreeAndNil(FReplyUnknownCommand);
  FreeAndNil(FReplyTexts);
  FreeAndNil(FMaxConnectionReply);
  FreeAndNil(FHelpReply);
  FreeAndNil(FGreeting);
  FreeAndNil(FExceptionReply);
  FreeAndNil(FCommandHandlers);
end;

procedure TIdCmdTCPServer.DoAfterCommandHandler(ASender: TIdCommandHandlers;
  AContext: TIdContext);
begin
  if Assigned(OnAfterCommandHandler) then begin
    OnAfterCommandHandler(Self, AContext);
  end;
end;

procedure TIdCmdTCPServer.DoBeforeCommandHandler(ASender: TIdCommandHandlers;
  var AData: string; AContext: TIdContext);
begin
  if Assigned(OnBeforeCommandHandler) then begin
    OnBeforeCommandHandler(Self, AData, AContext);
  end;
end;

function TIdCmdTCPServer.DoExecute(AContext: TIdContext): Boolean;
var
  LLine: string;
begin
  if CommandHandlersEnabled and (CommandHandlers.Count > 0) then begin
    Result := True;
    if AContext.Connection.Connected then begin
      LLine := ReadCommandLine(AContext);
      // OLX sends blank lines during reset groups (NNTP) and expects no response.
      // Not sure what the RFCs say about blank lines.
      // I telnetted to some newsservers, and they dont respond to blank lines.
      // This unit is core and not NNTP, but we should be consistent.
      if LLine <> '' then begin
        if not FCommandHandlers.HandleCommand(AContext, LLine) then begin
          DoReplyUnknownCommand(AContext, LLine);
        end;
      end;
    end;
  end else begin
    Result := inherited DoExecute(AContext);
  end;
  if Result and Assigned(AContext.Connection) then begin
    Result := AContext.Connection.Connected;
  end;
  // the return value is used to determine if the DoExecute needs to be called again by the thread
end;

procedure TIdCmdTCPServer.DoReplyUnknownCommand(AContext: TIdContext; ALine: string);
var
  LReply: TIdReply;
begin
  LReply := FReplyClass.Create(nil, ReplyTexts); try
    LReply.Assign(ReplyUnknownCommand);
    LReply.Text.Add(ALine);
    AContext.Connection.IOHandler.Write(LReply.FormattedReply);
  finally FreeAndNil(LReply); end;
end;

procedure TIdCmdTCPServer.InitializeCommandHandlers;
begin
end;

procedure TIdCmdTCPServer.DoConnect(AContext: TIdContext);
var
  LGreeting: TIdReply;
begin
  inherited;
  // RLebeau - check the connection first in case the application
  // chose to disconnect the connection in the OnConnect event handler.
  if AContext.Connection.Connected then begin
    ReplyTexts.UpdateText(Greeting);
    LGreeting := FReplyClass.Create(nil); try // SendGreeting calls TIdReply.GetFormattedReply
      LGreeting.Assign(Greeting);           // and that changes the reply object, so we have to
      SendGreeting(AContext, LGreeting);    // clone it to make it thread-safe
    finally
      FreeAndNil(LGreeting);
    end;
  end;
end;

procedure TIdCmdTCPServer.DoMaxConnectionsExceeded(AIOHandler: TIdIOHandler);
begin
  inherited;
  //Do not UpdateText here - in thread. Is done in constructor
  AIOHandler.Write(MaxConnectionReply.FormattedReply);
end;

procedure TIdCmdTCPServer.SetActive(AValue: Boolean);
var
  i, j: Integer;
  LDescr: TIdStrings;
  LHelpList: TStringList;
  LHandler: TIdCommandHandler;
begin
  if (not (csDesigning in ComponentState)) and (not (csLoading in ComponentState))
   and (FActive = False) and (AValue = True) and (FCommandHandlersInitialized = False) then begin
    // InitializeCommandHandlers must be called only at runtime, and only after streaming
    // has occured. This used to be in .Loaded and that worked for forms. It failed
    // for dynamically created instances and also for descendant classes.
    FCommandHandlersInitialized := True;
    InitializeCommandHandlers;
    if HelpReply.Code <> '' then begin
      with CommandHandlers.Add do begin
        Command := 'Help'; {do not localize}
        Description.Text := 'Displays commands that the servers supports.'; {do not localize}
        NormalReply.Assign(HelpReply);
        LHelpList := TStringList.Create; try
          for i := 0 to CommandHandlers.Count - 1 do begin
            LHandler := CommandHandlers.Items[i];
            if LHandler.HelpVisible then
            begin
              LHelpList.AddObject(LHandler.Command+LHandler.HelpSuperScript, LHandler);
            end;
          end;
          LHelpList.Sort;
          for i := 0 to LHelpList.Count - 1 do begin
            Response.Add(LHelpList[i]);
            LDescr := TIdCommandHandler(LHelpList.Objects[i]).Description;
            for j := 0 to LDescr.Count - 1 do begin
              Response.Add('  ' + LDescr[j]);
            end;
            Response.Add('');
          end;
        finally FreeAndNil(LHelpList); end;
      end;
    end;
  end;
  inherited;
end;

function TIdCmdTCPServer.CreateExceptionReply: TIdReply;
begin
  Result := FReplyClass.Create(nil, ReplyTexts);
  Result.SetReply(500, 'Unknown Internal Error'); {do not localize}
end;

function TIdCmdTCPServer.GetExceptionReply: TIdReply;
begin
  if FExceptionReply = nil then begin
    FExceptionReply := CreateExceptionReply;
  end;
  Result := FExceptionReply;
end;

procedure TIdCmdTCPServer.SetExceptionReply(AValue: TIdReply);
begin
  ExceptionReply.Assign(AValue);
end;

function TIdCmdTCPServer.CreateGreeting: TIdReply;
begin
  Result := FReplyClass.Create(nil, ReplyTexts);
  Result.SetReply(200, 'Welcome'); {do not localize}
end;

function TIdCmdTCPServer.GetGreeting: TIdReply;
begin
  if FGreeting = nil then begin
    FGreeting := CreateGreeting;
  end;
  Result := FGreeting;
end;

procedure TIdCmdTCPServer.SetGreeting(AValue: TIdReply);
begin
  Greeting.Assign(AValue);
end;

function TIdCmdTCPServer.CreateHelpReply: TIdReply;
begin
  Result := FReplyClass.Create(nil, ReplyTexts);
  Result.SetReply(100, 'Help follows'); {do not localize}
end;

function TIdCmdTCPServer.GetHelpReply: TIdReply;
begin
  if FHelpReply = nil then begin
    FHelpReply := CreateHelpReply;
  end;
  Result := FHelpReply;
end;

procedure TIdCmdTCPServer.SetHelpReply(AValue: TIdReply);
begin
  HelpReply.Assign(AValue);
end;

function TIdCmdTCPServer.CreateMaxConnectionReply: TIdReply;
begin
  Result := FReplyClass.Create(nil, ReplyTexts);
  Result.SetReply(300, 'Too many connections. Try again later.'); {do not localize}
end;

function TIdCmdTCPServer.GetMaxConnectionReply: TIdReply;
begin
  if FMaxConnectionReply = nil then begin
    FMaxConnectionReply := CreateMaxConnectionReply;
  end;
  Result := FMaxConnectionReply;
end;

procedure TIdCmdTCPServer.SetMaxConnectionReply(AValue: TIdReply);
begin
  MaxConnectionReply.Assign(AValue);
end;

function TIdCmdTCPServer.CreateReplyUnknownCommand: TIdReply;
begin
  Result := FReplyClass.Create(nil, ReplyTexts);
  Result.SetReply(400, 'Unknown Command'); {do not localize}
end;

function TIdCmdTCPServer.GetReplyUnknownCommand: TIdReply;
begin
  if FReplyUnknownCommand = nil then begin
    FReplyUnknownCommand := CreateReplyUnknownCommand;
  end;
  Result := FReplyUnknownCommand;
end;

procedure TIdCmdTCPServer.SetReplyUnknownCommand(AValue: TIdReply);
begin
  ReplyUnknownCommand.Assign(AValue);
end;

procedure TIdCmdTCPServer.SetReplyTexts(AValue: TIdReplies);
begin
  FReplyTexts.Assign(AValue);
end;

procedure TIdCmdTCPServer.InitComponent;
begin
  inherited;
  FReplyClass := GetReplyClass;

  // Before Command handlers as they need FReplyTexts, but after FReplyClass is set
  FReplyTexts := GetRepliesClass.Create(Self, FReplyClass);

  FCommandHandlersEnabled := IdCommandHandlersEnabledDefault;
  FCommandHandlers := TIdCommandHandlers.Create(Self, FReplyClass, ReplyTexts, ExceptionReply);
  FCommandHandlers.OnAfterCommandHandler := DoAfterCommandHandler;
  FCommandHandlers.OnBeforeCommandHandler := DoBeforeCommandHandler;
end;

function TIdCmdTCPServer.ReadCommandLine(AContext: TIdContext): string;
begin
  Result := AContext.Connection.IOHandler.ReadLn;
end;

end.