idtcpserver.pas

Indy控件的使用源代码

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  10367: IdTCPServer.pas 
{
    Rev 1.2    3/22/2003 1:56:40 AM  BGooijen
  Fixed a bug where non-paged memory was leaked when an exception occured in
  TIdListenerThread.Run
}
{
    Rev 1.1    3/21/2003 4:51:50 PM  BGooijen
  Intercept is freed in TIdPeerThread.AfterRun if a ServerIntercept is assigned
  to the server
}
{
{   Rev 1.0    2002.11.12 10:55:14 PM  czhower
}
unit IdTCPServer;

interface

{
Original Author and Maintainer:
 - Chad Z. Hower a.k.a Kudzu
2002-01-01 - Andrew P.Rybin
 - bug fix (MaxConnections, SetActive(FALSE)), TerminateListenerThreads, DoExecute
2002-04-17 - Andrew P.Rybin
 - bug fix: if exception raised in OnConnect, Threads.Remove and ThreadMgr.ReleaseThread are not called
}

uses
  Classes, SysUtils,
  IdComponent, IdException, IdSocketHandle, IdTCPConnection, IdThread, IdThreadMgr,
  IdIOHandlerSocket, IdIOHandler, IdThreadMgrDefault, IdIntercept, IdStackConsts,
  IdGlobal, IdRFCReply, IdServerIOHandler, IdServerIOHandlerSocket;

const
  IdEnabledDefault = True;
  // DO NOT change this defualt (ParseParams). Many servers rely on this
  IdParseParamsDefault = True;
  IdCommandHandlersEnabledDefault = True;
  IdListenQueueDefault = 15;

type
  TIdCommandHandler = class;
  TIdCommand = class;
  TIdPeerThread = class;
  TIdTCPServer = class;
  TIdAfterCommandHandlerEvent = procedure(ASender: TIdTCPServer; AThread: TIdPeerThread) of object;
  TIdBeforeCommandHandlerEvent = procedure(ASender: TIdTCPServer; const AData: string;
    AThread: TIdPeerThread) of object;
  TIdCommandEvent = procedure(ASender: TIdCommand) of object;
  TIdNoCommandHandlerEvent = procedure(ASender: TIdTCPServer; const AData: string;
    AThread: TIdPeerThread) of object;

  TIdCommandHandler = class(TCollectionItem)
  protected
    FCmdDelimiter: Char;
    FCommand: string;
    FData: TObject;
    FDisconnect: boolean;
    FEnabled: boolean;
    FName: string;
    FOnCommand: TIdCommandEvent;
    FParamDelimiter: Char;
    FParseParams: Boolean;
    FReplyExceptionCode: Integer;
    FReplyNormal: TIdRFCReply;
    FResponse: TStrings;
    FTag: integer;
    //
    function GetDisplayName: string; override;
    procedure SetDisplayName(const AValue: string); override;
    procedure SetResponse(AValue: TStrings);
  public
    function Check(const AData: string; AThread: TIdPeerThread): boolean; virtual;
    constructor Create(ACollection: TCollection); override;
    destructor Destroy; override;
    function GetNamePath: string; override;
    function NameIs(ACommand: string): Boolean;
    //
    property Data: TObject read FData write FData;
  published
    property CmdDelimiter: Char read FCmdDelimiter write FCmdDelimiter;
    property Command: string read FCommand write FCommand;
    property Disconnect: boolean read FDisconnect write FDisconnect;
    property Enabled: boolean read FEnabled write FEnabled default IdEnabledDefault;
    property Name: string read FName write FName;
    property OnCommand: TIdCommandEvent read FOnCommand write FOnCommand;
    property ParamDelimiter: Char read FParamDelimiter write FParamDelimiter;
    property ParseParams: Boolean read FParseParams write FParseParams default IdParseParamsDefault;
    property ReplyExceptionCode: Integer read FReplyExceptionCode write FReplyExceptionCode;
    property ReplyNormal: TIdRFCReply read FReplyNormal write FReplyNormal;
    property Response: TStrings read FResponse write SetResponse;
    property Tag: integer read FTag write FTag;
  end;

  TIdCommandHandlers = class(TOwnedCollection)
  protected
    FServer: TIdTCPServer;
    //
    function GetItem(AIndex: Integer): TIdCommandHandler;
    // This is used instead of the OwnedBy property directly calling GetOwner because
    // D5 dies with internal errors and crashes
    function GetOwnedBy: TPersistent;
    procedure SetItem(AIndex: Integer; const AValue: TIdCommandHandler);
  public
    function Add: TIdCommandHandler;
    constructor Create(AServer: TIdTCPServer); reintroduce;
    //
    property Items[AIndex: Integer]: TIdCommandHandler read GetItem write SetItem;
    // OwnedBy is used so as not to conflict with Owner in D6
    property OwnedBy: TPersistent read GetOwnedBy;
    property Server: TIdTCPServer read FServer;
  end;

  TIdCommand = class(TObject)
  protected
    FCommandHandler: TIdCommandHandler;
    FParams: TStrings;
    FPerformReply: Boolean;
    FRawLine: string;
    FReply: TIdRFCReply;
    FResponse: TStrings;
    FThread: TIdPeerThread;
    FUnparsedParams: string;
    //
    procedure DoCommand; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure SendReply;
    procedure SetResponse(AValue: TStrings);
    //
    property CommandHandler: TIdCommandHandler read FCommandHandler;
    property PerformReply: Boolean read FPerformReply write FPerformReply;
    property Params: TStrings read FParams;
    property RawLine: string read FRawLine;
    property Reply: TIdRFCReply read FReply write FReply;
    property Response: TStrings read FResponse write SetResponse;
    property Thread: TIdPeerThread read FThread;
    property UnparsedParams: string read FUnparsedParams;
  end;

  // This is the thread that listens for incoming connections and spawns
  // new ones to handle each one
  TIdListenerThread = class(TIdThread)
  protected
    FBinding: TIdSocketHandle;
    FServer: TIdTCPServer;
    procedure AfterRun; override;
    procedure Run; override;
  public
    constructor Create(AServer: TIdTCPServer; ABinding: TIdSocketHandle); reintroduce;
   //
    property Binding: TIdSocketHandle read FBinding write FBinding;
    property Server: TIdTCPServer read FServer;
  End;//TIdListenerThread

  TIdTCPServerConnection = class(TIdTCPConnection)
  protected
    FServer: TIdTCPServer;
//    FLastRcvTimeStamp: TDateTime;    //Timestamp of latest received command
//    FProcessingTimeout: boolean;     //To avoid double timeout processing
    //
  public
//    property LastRcvTimeStamp: TDateTime read fLastRcvTimeStamp write fLastRcvTimeStamp;
//    property ProcessingTimeout: boolean read fbProcessingTimeout write fbProcessingTimeout;
//    function Read(const piLen: Integer): string; override;
    constructor Create(AServer: TIdTCPServer); reintroduce;
  published
    property Server: TIdTCPServer read FServer;
  end;

  TIdPeerThread = class(TIdThread)
  protected
    FConnection: TIdTCPServerConnection;
    //
    procedure AfterRun; override;
    procedure BeforeRun; override;
    procedure Cleanup; override;
    // If things need freed, free them in AfterRun so that pooled threads clean themselves up.
    // Only persistent things should be handled in AfterExecute (Destroy)
    procedure Run; override;
  public
    //
    property Connection: TIdTCPServerConnection read FConnection;
  End;//TIdPeerThread

  TIdListenExceptionEvent = procedure(AThread: TIdListenerThread; AException: Exception) of object;
  TIdServerThreadExceptionEvent = procedure(AThread: TIdPeerThread; AException: Exception)
    of object;
  TIdServerThreadEvent = procedure(AThread: TIdPeerThread) of object;

  TIdTCPServer = class(TIdComponent)
  protected
    FActive: Boolean;
    FThreadMgr: TIdThreadMgr;
    FBindings: TIdSocketHandles;
    FCommandHandlers: TIdCommandHandlers;
    FCommandHandlersEnabled: Boolean;
    FCommandHandlersInitialized: Boolean;
    FGreeting: TIdRFCReply;
    FImplicitThreadMgr: Boolean;
    FImplicitIOHandler: Boolean;
    FIntercept: TIdServerIntercept;
    FIOHandler: TIdServerIOHandler;
    FListenerThreads: TThreadList;
    FListenQueue: integer;
    FMaxConnectionReply: TIdRFCReply;
    FMaxConnections: Integer;
    FReplyTexts: TIdRFCReplies;
    FReuseSocket: TIdReuseSocket;
    FTerminateWaitTime: Integer;
    FThreadClass: TIdThreadClass;
    FThreads: TThreadList;
    FOnAfterCommandHandler: TIdAfterCommandHandlerEvent;
    FOnBeforeCommandHandler: TIdBeforeCommandHandlerEvent;
    FOnConnect: TIdServerThreadEvent;
    FOnDisconnect: TIdServerThreadEvent;
    FOnException: TIdServerThreadExceptionEvent;
    FOnExecute: TIdServerThreadEvent;
    FOnListenException: TIdListenExceptionEvent;
    FOnNoCommandHandler: TIdNoCommandHandlerEvent;
    FReplyExceptionCode: Integer;
    FReplyUnknownCommand: TIdRFCReply;
    //
    procedure CheckActive;
    procedure DoAfterCommandHandler(AThread: TIdPeerThread);
    procedure DoBeforeCommandHandler(AThread: TIdPeerThread; const ALine: string);
    procedure DoConnect(AThread: TIdPeerThread); virtual;
    procedure DoDisconnect(AThread: TIdPeerThread); virtual;
    procedure DoException(AThread: TIdPeerThread; AException: Exception);
    function DoExecute(AThread: TIdPeerThread): boolean; virtual;
    procedure DoListenException(AThread: TIdListenerThread; AException: Exception);
    procedure DoOnNoCommandHandler(const AData: string; AThread: TIdPeerThread);
    function GetDefaultPort: integer;
    function GetThreadMgr: TIdThreadMgr;
    procedure InitializeCommandHandlers; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetActive(AValue: Boolean); virtual;
    procedure SetBindings(const AValue: TIdSocketHandles); virtual;
    procedure SetDefaultPort(const AValue: integer); virtual;
    procedure SetIntercept(const AValue: TIdServerIntercept); virtual;
    procedure SetIOHandler(const AValue: TIdServerIOHandler); virtual;
    procedure SetThreadMgr(const AValue: TIdThreadMgr); virtual;
    procedure TerminateAllThreads;
    procedure TerminateListenerThreads; //APR
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    //
    property ImplicitIOHandler: Boolean read FImplicitIOHandler;
    property ImplicitThreadMgr: Boolean read FImplicitThreadMgr;
    property ThreadClass: TIdThreadClass read FThreadClass write FThreadClass;
    property Threads: TThreadList read FThreads;
  published
    property Active: Boolean read FActive write SetActive default False;
    property Bindings: TIdSocketHandles read FBindings write SetBindings;
    property CommandHandlers: TIdCommandHandlers read FCommandHandlers write FCommandHandlers;
    property CommandHandlersEnabled: boolean read FCommandHandlersEnabled
      write FCommandHandlersEnabled default IdCommandHandlersEnabledDefault;
    property DefaultPort: integer read GetDefaultPort write SetDefaultPort;
    property Greeting: TIdRFCReply read FGreeting write FGreeting;
    property Intercept: TIdServerIntercept read FIntercept write SetIntercept;
    property IOHandler: TIdServerIOHandler read FIOHandler write SetIOHandler;
    property ListenQueue: integer read FListenQueue write FListenQueue default IdListenQueueDefault;
    property MaxConnectionReply: TIdRFCReply read FMaxConnectionReply write FMaxConnectionReply;
    property MaxConnections: Integer read FMaxConnections write FMaxConnections default 0;
    // Occurs in the context of the peer thread
    property OnAfterCommandHandler: TIdAfterCommandHandlerEvent read FOnAfterCommandHandler
     write FOnAfterCommandHandler;
    // Occurs in the context of the peer thread
    property OnBeforeCommandHandler: TIdBeforeCommandHandlerEvent read FOnBeforeCommandHandler
     write FOnBeforeCommandHandler;
    // Occurs in the context of the peer thread
    property OnConnect: TIdServerThreadEvent read FOnConnect write FOnConnect;
    // Occurs in the context of the peer thread
    property OnExecute: TIdServerThreadEvent read FOnExecute write FOnExecute;
    // Occurs in the context of the peer thread
    property OnDisconnect: TIdServerThreadEvent read FOnDisconnect write FOnDisconnect;
    // Occurs in the context of the peer thread
    property OnException: TIdServerThreadExceptionEvent read FOnException write FOnException;
    property OnListenException: TIdListenExceptionEvent read FOnListenException
      write FOnListenException;
    property OnNoCommandHandler: TIdNoCommandHandlerEvent read FOnNoCommandHandler
      write FOnNoCommandHandler;
    property ReplyExceptionCode: Integer read FReplyExceptionCode write FReplyExceptionCode;
    property ReplyTexts: TIdRFCReplies read FReplyTexts write FReplyTexts;
    property ReplyUnknownCommand: TIdRFCReply read FReplyUnknownCommand write FReplyUnknownCommand;
    property ReuseSocket: TIdReuseSocket read FReuseSocket write FReuseSocket default rsOSDependent;
    property TerminateWaitTime: Integer read FTerminateWaitTime write FTerminateWaitTime
      default 5000;
    property ThreadMgr: TIdThreadMgr read GetThreadMgr write SetThreadMgr;
  end;
  EIdTCPServerError = class(EIdException);
  EIdNoExecuteSpecified = class(EIdTCPServerError);
  EIdTerminateThreadTimeout = class(EIdTCPServerError);

implementation

uses
  IdResourceStrings, IdStack, IdStrings, IdThreadSafe;

{ TIdTCPServer }

procedure TIdTCPServer.CheckActive;
begin
  if Active and (not (csDesigning in ComponentState)) and (not (csLoading in ComponentState))
    then begin
    raise EIdTCPServerError.Create(RSCannotPerformTaskWhileServerIsActive);
  end;
end;

constructor TIdTCPServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBindings := TIdSocketHandles.Create(Self);
  // Before Command handlers
  FReplyTexts := TIdRFCReplies.Create(Self);
  FCommandHandlers := TIdCommandHandlers.Create(Self);
  FCommandHandlersEnabled := IdCommandHandlersEnabledDefault;
  FGreeting := TIdRFCReply.Create(nil);
  FMaxConnectionReply := TIdRFCReply.Create(nil);
  FThreads := TThreadList.Create;
  FThreadClass := TIdPeerThread;
  FReplyUnknownCommand := TIdRFCReply.Create(nil);
  //
  FTerminateWaitTime := 5000;
  FListenQueue := IdListenQueueDefault;
  //TODO: When reestablished, use a sleeping thread instead
//  fSessionTimer := TTimer.Create(self);
end;

destructor TIdTCPServer.Destroy;
begin
  Active := False;

  if Assigned(FIOHandler) and FImplicitIOHandler then begin
    FreeAndNil(FIOHandler);
  end;

  // Destroy bindings first
  FreeAndNil(FBindings);
  //
  FreeAndNil(FReplyUnknownCommand);
  FreeAndNil(FReplyTexts);
  FreeAndNil(FThreads);
  FreeAndNil(FMaxConnectionReply);
  FreeAndNil(FGreeting);
  FreeAndNil(FCommandHandlers);
  inherited Destroy;
end;

procedure TIdTCPServer.DoAfterCommandHandler(AThread: TIdPeerThread);
begin
  if Assigned(OnAfterCommandHandler) then begin
    OnAfterCommandHandler(Self, AThread);
  end;