idcommandhandlers.pas

网络控件适用于Delphi6

{ $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:  21522: IdCommandHandlers.pas
{
{   Rev 1.32    10/26/2004 8:42:58 PM  JPMugaas
{ Should be more portable with new references to TIdStrings and TIdStringList.
}
{
{   Rev 1.31    6/17/2004 2:19:50 AM  JPMugaas
{ Problem with unparsed parameters.  The initial deliniator between the command
{ and reply was being added to Unparsed Params leading some strange results and
{ command failures.
}
{
{   Rev 1.30    6/6/2004 11:44:34 AM  JPMugaas
{ Removed a temporary workaround for a Telnet Sequences issue in the
{ TIdFTPServer.  That workaround is no longer needed as we fixed the issue
{ another way.
}
{
{   Rev 1.29    5/16/04 5:20:22 PM  RLebeau
{ Removed local variable from TIdCommandHandler constructor, no longer used
}
{
{   Rev 1.28    2004.03.03 3:19:52 PM  czhower
{ sorted
}
{
{   Rev 1.27    3/3/2004 4:59:40 AM  JPMugaas
{ Updated for new properties.
}
{
{   Rev 1.26    3/2/2004 8:10:36 AM  JPMugaas
{ HelpHide renamed to HelpVisable.
}
{
{   Rev 1.25    3/2/2004 6:37:36 AM  JPMugaas
{ Updated with properties for more comprehensive help systems.
}
{
{   Rev 1.24    2004.03.01 7:13:40 PM  czhower
{ Comaptibilty fix.
}
{
{   Rev 1.23    2004.03.01 5:12:26 PM  czhower
{ -Bug fix for shutdown of servers when connections still existed (AV)
{ -Implicit HELP support in CMDserver
{ -Several command handler bugs
{ -Additional command handler functionality.
}
{
{   Rev 1.22    2004.02.29 9:49:06 PM  czhower
{ Bug fix, and now responses are also write buffered.
}
{
{   Rev 1.21    2004.02.03 4:17:10 PM  czhower
{ For unit name changes.
}
{
{   Rev 1.20    1/29/04 10:00:40 PM  RLebeau
{ Added setter methods to various TIdReply properties
}
{
{   Rev 1.19    2003.12.31 7:31:58 PM  czhower
{ AnsiSameText --> TextIsSame
}
{
    Rev 1.18    10/19/2003 11:36:52 AM  DSiders
  Added localization comments where setting response codes.
}
{
{   Rev 1.17    2003.10.18 9:33:26 PM  czhower
{ Boatload of bug fixes to command handlers.
}
{
{   Rev 1.16    2003.10.18 8:07:12 PM  czhower
{ Fixed bug with defaults.
}
{
{   Rev 1.15    2003.10.18 8:03:58 PM  czhower
{ Defaults for codes
}
{
{   Rev 1.14    10/5/2003 03:06:18 AM  JPMugaas
{ Should compile.
}
{
    Rev 1.13    8/9/2003 3:52:44 PM  BGooijen
  TIdCommandHandlers can now create any TIdCommandHandler descendant. this
  makes it possible to override TIdCommandHandler.check and check for the
  command a different way ( binary commands, protocols where the string doesn't
  start with the command )
}
{
{   Rev 1.12    8/2/2003 2:22:54 PM  SPerry
{ Fixed OnCommandHandlersException problem
}
{
{   Rev 1.11    8/2/2003 1:43:08 PM  SPerry
{ Modifications to get command handlers to work
}
{
{   Rev 1.9    7/30/2003 10:18:30 PM  SPerry
{ Fixed AV when creating commandhandler (again) -- for some reason the bug
{ fixed in Rev. 1.7 was still there.
}
{
{   Rev 1.8    7/30/2003 8:31:58 PM  SPerry
{ Fixed AV with LFReplyClass.
}
{
    Rev 1.4    7/9/2003 10:55:26 PM  BGooijen
  Restored all features
}
{
{   Rev 1.3    7/9/2003 04:36:10 PM  JPMugaas
{ You now can override the TIdReply with your own type.  This should illiminate
{ some warnings about some serious issues.  TIdReply is ONLY a base class with
{ virtual methods.
}
{
{   Rev 1.2    7/9/2003 01:43:22 PM  JPMugaas
{ Should now compile.
}
{
{   Rev 1.1    7/9/2003 2:56:44 PM  SPerry
{ Added OnException event
}
{
{
{   Rev 1.0    7/6/2003 4:47:38 PM  SPerry
{ Units that use Command handlers
}
{
	Original author: Chad Z. Hower
	Separate Unit  : Sergio Perry
}
unit IdCommandHandlers;

interface

uses
  SysUtils, Classes, IdBaseComponent, IdComponent, IdReply, IdGlobal,
  IdContext, IdReplyRFC, IdTStrings;

const
  IdEnabledDefault = True;
  // DO NOT change this default (ParseParams). Many servers rely on this
  IdParseParamsDefault = True;
  IdCommandHandlersEnabledDefault = True;
  IdHelpVisibleDef = True;
type
  TIdCommandHandlers = class;
  TIdCommandHandler = class;
  TIdCommand = class;

  { Events }
  TIdCommandEvent = procedure(ASender: TIdCommand) of object;
  TIdAfterCommandHandlerEvent = procedure(ASender: TIdCommandHandlers;
    AContext: TIdContext) of object;
  TIdBeforeCommandHandlerEvent = procedure(ASender: TIdCommandHandlers;
    var AData: string; AContext: TIdContext) of object;
  TIdCommandHandlersExceptionEvent = procedure(ACommand: String; AContext: TIdContext) of object;

  { TIdCommandHandler }
  TIdCommandHandler = class(TCollectionItem)
  protected
    FCmdDelimiter: Char;
    FCommand: string;
    FData: TObject;
    FDescription: TIdStrings;
    FDisconnect: boolean;
    FEnabled: boolean;
    FExceptionReply: TIdReply;
    FHelpSuperScript : String;  //may be something like * or + which should appear in help
    FHelpVisible : Boolean;
    FName: string;
    FNormalReply: TIdReply;
    FOnCommand: TIdCommandEvent;
    FParamDelimiter: Char;
    FParseParams: Boolean;
    FReplyClass : TIdReplyClass;
    FResponse: TIdStrings;
    FTag: integer;
    //
    function GetDisplayName: string; override;
    procedure SetDescription(AValue: TIdStrings);
    procedure SetExceptionReply(AValue: TIdReply);
    procedure SetNormalReply(AValue: TIdReply);
    procedure SetResponse(AValue: TIdStrings);
  public
    function Check(AData: string; AContext: TIdContext): boolean; virtual;
    procedure DoCommand(AData: string; AContext: TIdContext; AUnparsedParams: string); 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 Description: TIdStrings read FDescription write SetDescription;
    property Disconnect: boolean read FDisconnect write FDisconnect;
    property Enabled: boolean read FEnabled write FEnabled default IdEnabledDefault;
    property ExceptionReply: TIdReply read FExceptionReply write SetExceptionReply;
    property Name: string read FName write FName;
    property NormalReply: TIdReply read FNormalReply write SetNormalReply;
    property ParamDelimiter: Char read FParamDelimiter write FParamDelimiter;
    property ParseParams: Boolean read FParseParams write FParseParams default IdParseParamsDefault;
    property Response: TIdStrings read FResponse write SetResponse;
    property Tag: Integer read FTag write FTag;
    //
    property HelpSuperScript : String read FHelpSuperScript write FHelpSuperScript;  //may be something like * or + which should appear in help
    property HelpVisible : Boolean read FHelpVisible write FHelpVisible default IdHelpVisibleDef;

    property OnCommand: TIdCommandEvent read FOnCommand write FOnCommand;
  end;

  TIdCommandHandlerClass = class of TIdCommandHandler;

  { TIdCommandHandlers }
  TIdCommandHandlers = class(TOwnedCollection)
  protected
    FBase: TIdComponent;
    FExceptionReply: TIdReply;
    FOnAfterCommandHandler: TIdAfterCommandHandlerEvent;
    FOnBeforeCommandHandler: TIdBeforeCommandHandlerEvent;
    FOnCommandHandlersException: TIdCommandHandlersExceptionEvent;
    FReplyClass: TIdReplyClass;
    FReplyTexts: TIdReplies;
    //
    procedure DoAfterCommandHandler(AContext: TIdContext);
    procedure DoBeforeCommandHandler(AContext: TIdContext; var VLine: string);
    procedure DoOnCommandHandlersException(ACommand: String; AContext: TIdContext);
    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(
      ABase: TIdComponent;
      AReplyClass: TIdReplyClass;
      AReplyTexts: TIdReplies;
      AExceptionReply: TIdReply = nil;
      ACommandHandlerClass: TIdCommandHandlerClass = nil
      ); reintroduce;
    function HandleCommand(
      AContext: TIdContext;
      var VCommand: string
      ): Boolean;
      virtual;
    //
    property Base: TIdComponent read FBase;
    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 ReplyClass : TIdReplyClass read FReplyClass;
    //
    property OnAfterCommandHandler: TIdAfterCommandHandlerEvent read FOnAfterCommandHandler
     write FOnAfterCommandHandler;
    // Occurs in the context of the peer thread
    property OnBeforeCommandHandler: TIdBeforeCommandHandlerEvent read FOnBeforeCommandHandler
     write FOnBeforeCommandHandler;
    property OnCommandHandlersException: TIdCommandHandlersExceptionEvent read FOnCommandHandlersException
      write FOnCommandHandlersException;
    property ReplyTexts: TIdReplies read FReplyTexts;
  end;

  { TIdCommand }
  TIdCommand = class(TObject)
  protected
    FCommandHandler: TIdCommandHandler;
    FDisconnect: Boolean;
    FParams: TIdStrings;
    FPerformReply: Boolean;
    FRawLine: string;
    FReply: TIdReply;
    FResponse: TIdStrings;
    FContext: TIdContext;
    FUnparsedParams: string;
    //
    procedure DoCommand; virtual;
    procedure SetReply(AValue: TIdReply);
    procedure SetResponse(AValue: TIdStrings);
  public
    constructor Create(AOwner: TIdCommandHandler); virtual;
    destructor Destroy; override;
    procedure SendReply;
    //
    property CommandHandler: TIdCommandHandler read FCommandHandler;
    property Disconnect: Boolean read FDisconnect write FDisconnect;
    property PerformReply: Boolean read FPerformReply write FPerformReply;
    property Params: TIdStrings read FParams;
    property RawLine: string read FRawLine;
    property Reply: TIdReply read FReply write SetReply;
    property Response: TIdStrings read FResponse write SetResponse;
    property Context: TIdContext read FContext;
    property UnparsedParams: string read FUnparsedParams;
  end;//TIdCommand

implementation

{ TIdCommandHandlers }

constructor TIdCommandHandlers.Create(