invokeregistry.pas

Delphi的Soap一些使用功能控件

{*******************************************************}
{                                                       }
{ Borland Delphi Visual Component Library               }
{       SOAP           Support                          }
{                                                       }
{ Copyright (c) 2001-2005 Borland Software Corporation  }
{                                                       }
{*******************************************************}
{
  Central registry for interfaces with RTTI and the classes that implement them.
  Classes that are used as parameter types in methods of interfaces are registered
  in a separate registry.
}
unit InvokeRegistry;

{$IFNDEF VER150}
{$INCLUDE 'CompVer.inc'}
{$ENDIF}

{$IFDEF DIAMONDBACK_UP}
  {$DEFINE CLEANUP_SOAP_HEADERS}
{$ENDIF}

{$IFDEF HIGHLANDER_UP}
  {$DEFINE WIDE_RETURN_PARAM_NAMES}
  {$DEFINE CONST_WIDESTRING_PARAMS}
{$ENDIF}


{$IFDEF NO_SOAP_RUNTIME}
{ If SOAP components are not packaged }
(*$HPPEMIT '#pragma link "dclsoap.lib"' *)
{$ENDIF}

{$IFDEF MSWINDOWS}
{ SOAP/Windows is currently implemented with WININET }
(*$HPPEMIT '#if defined(__WIN32__)'     *)
(*$HPPEMIT '#pragma link "wininet.lib"' *)
(*$HPPEMIT '#endif'                     *)
(*$HPPEMIT '                           '*)
{$ENDIF}

(*$HPPEMIT '#if !defined(SOAP_REMOTABLE_CLASS)'                   *)
(*$HPPEMIT '#define SOAP_REMOTABLE_CLASS __declspec(delphiclass)' *)
(*$HPPEMIT '#endif'                                               *)
(*$HPPEMIT '                                                     '*)

interface

uses SysUtils, TypInfo, IntfInfo, Classes, Contnrs, {$IFDEF MSWINDOWS}Windows{$ENDIF}
  {$IFDEF LINUX}Libc{$ENDIF}, XMLSchema, XmlIntf, Types;

type

  InvString = WideString;

  TDataContext = class;

  ObjectConvertOptions = (ocoDontPrefixNode,
                          ocoDontSerializeProps,
                          ocoDontPutTypeAttr);
  TObjectConvertOptions= set of ObjectConvertOptions;

  TSOAPAttachment = class;

  IObjConverter = interface
  ['{7F67EA52-A3D1-429B-B54D-49F692B6131A}']
    function  ObjInstanceToSOAP(Instance: TObject; RootNode, ParentNode: IXMLNode;
                                const NodeName, NodeNamespace: InvString; ObjConvOpts: TObjectConvertOptions;
                                out RefID: InvString): IXMLNode;
    procedure InitObjectFromSOAP(Instance: TObject; RootNode, Node: IXMLNode);
    procedure AddAttachment(Attachment: TSOAPAttachment; const AContentId: string);
    function  FindAttachment(const AContentId: string): TSOAPAttachment;
  end;

  { ======================================================================================
    Serialization options apply to remotable classes - i.e. type derived from TRemotable.
    Usually these types simply represent an XML <complextype> with zero or more elements;
    however, the are times when they are really shells for another type.
    For example, if a schema describes a type that returns an array with 'truncated'
    attribute describing whether the data was truncated, you'll need a 'TRemotable-derived'
    type to properly deserialize the data. However, in such a case, the
    'TRemotable-derived' type is really just a shell to house the array and the
    attribute fields. The 'TRemotable-derived' type is not involved in the
    [de]serialization process. It's stealth!

    Serialization options can either be registered for a particular ClassType. Or it can
    be set by an instance of a class itself via TRemotable's FSerializationOptions member.

    NOTE: Currently Serialization options are only for Client usage. i.e. They are used by
    the WSDL importer when creating types from a WSDL. Servers should *NOT* register any
    types with these options as the WSDL publishing logic will ignore all serialization
    options. IOW, these flags are here to adapt the language binding to constructs that don't
    easily map to a native type - like the example of an array with an attribute. Servers,
    don't need to resort to any of these flags since all of a server's needs can be
    mapped to SOAP without use of holder classes.
    ====================================================================================== }
  SerializationOptions  = (xoHolderClass,
                           xoAttributeOnLastMember,
                           xoInlineArrays,
                           xoLiteralParam,
                           xoSimpleTypeWrapper,
                           xoOption6, xoOption7,
                           xoOption8, xoOption9,
                           xoOptionA, xoOptionB,
                           xoOptionC, xoOptionD,
                           xoOptionE, xoOptionF,
                           xoOptionG, xoOptionH, xoOptionI);
  TSerializationOptions = set of SerializationOptions;

  { TRemotable is the base class for remoting complex types - it introduces a virtual
    constructor (to allow the SOAP runtime to properly create the object and derived
    types) and it provides life-time management - via DataContext - so the SOAP
    runtime can properly disposed of complex types received by a Service }
{$M+}
  TRemotable = class
  private
    FDataContext: TDataContext;
    procedure SetDataContext(Value: TDataContext);
  protected
    FSerializationOptions: TSerializationOptions;
  public
    constructor Create; virtual;
    destructor  Destroy; override;

    { Serialization routines }
    function   ObjectToSOAP(RootNode, ParentNode: IXMLNode;
                            const ObjConverter: IObjConverter;
                            const Name, URI: InvString; ObjConvOpts: TObjectConvertOptions;
                            out RefID: InvString): IXMLNode; virtual;
    procedure  SOAPToObject(const RootNode, Node: IXMLNode; const ObjConverter: IObjConverter); virtual;

    property   DataContext: TDataContext read FDataContext write SetDataContext;
    property   SerializationOptions: TSerializationOptions read FSerializationOptions;
  end;
{$M-}

  { TRemotableXS represents Scalar types that are implement via a TRemotable-derived
    type }
  TRemotableXS = class(TRemotable)
  public
    function  NativeToXS: WideString; virtual; abstract;
{$IFDEF CONST_XS_TO_NATIVE}
    procedure XSToNative(const Data: WideString); virtual; abstract;
{$ELSE}
    procedure XSToNative(Data: WideString); virtual; abstract;
{$ENDIF}
    function  ObjectToSOAP(RootNode, ParentNode: IXMLNode;
                           const ObjConverter: IObjConverter;
                           const Name, URI: InvString; ObjConvOpts: TObjectConvertOptions;
                           out RefID: InvString): IXMLNode; override;
    procedure SOAPToObject(const RootNode, Node: IXMLNode; const ObjConverter: IObjConverter); override;
  end;

  PTRemotable = ^TRemotable;
  TRemotableClass = class of TRemotable;
  TRemotableXSClass = class of TRemotableXS;

  { TSOAPHeader is the base class for SOAP Headers - it introduces the ability to
    handle Header-specific attributes such as 'Must-Understand' and 'Actor' }
  TSOAPHeader = class(TRemotable)
  private
    FMustUnderstand: Boolean;
    FActor: WideString;
  public
    { Serialization routines }
    function   ObjectToSOAP(RootNode, ParentNode: IXMLNode;
                            const ObjConverter: IObjConverter;
                            const Name, URI: InvString; ObjConvOpts: TObjectConvertOptions;
                            out RefID: InvString): IXMLNode; override;
    procedure  SOAPToObject(const RootNode, Node: IXMLNode; const ObjConverter: IObjConverter); override;

    property MustUnderstand: Boolean read FMustUnderstand write FMustUnderstand;
    property Actor: WideString read FActor write FActor;
  end;
  TSOAPHeaderClass = class of TSOAPHeader;

{$M+}
  { ERemotableException is the base class for handling fault packets with
    information in the <detail> nodes. It's also the base exception thrown
    when no suitable (registered) ERemotableException-derived class is found
    for a particular fault or when there is no <detail> node sent. }
  ERemotableException = class(Exception)
  private
    FFaultActor: WideString;
    FFaultCode: WideString;
    FFaultDetail: WideString;
  public
    constructor Create; overload;  virtual;
    constructor Create(const Msg: string;
                       const AFaultCode: WideString = '';
                       const AFaultActor: WideString = '');overload;  virtual;
    property FaultActor:  WideString read FFaultActor write FFaultActor;
    property FaultCode:   WideString read FFaultCode  write FFaultCode;
    property FaultDetail: WideString read FFaultDetail write FFaultDetail;
  end;
{$M-}

  ERemotableExceptionClass = class of ERemotableException;

{ sender can specify FileName or TStream as source }
  TSOAPAttachment = class(TRemotable)
  private
    FCacheFile: string;            { used by attachment receiver to store data }
    FCacheFilePersist: Boolean;    { if true, don't delete cacehfile on close }
    FContentType: string;
    FEncoding: WideString;
    FFileName: string;      { used by attachment sender to specify source of data }
    FSourceStream: TStream; { used by attachment sender to specify stream source of data }
    FSourceString: string;
    FHeaders: TStrings;
    FStreamOwnership: TStreamOwnership;
    procedure ClearStream;
  protected
    function GetSourceStream: TStream; virtual;
    procedure InternalSetCacheFile(const Value: string); virtual;
    procedure InternalSetSourceStream(const Value: TStream; const Ownership: TStreamOwnership = soReference);
    procedure SetSourceString(const Value: string); virtual;
    procedure SetOwnership(const Value: TStreamOwnership); virtual;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Init(ATempLocation: string; AHeaders: TStrings; AContentType: String;
                   AEncoding: WideString);

    { Serialization routines - Handle MIME Part I/O }
    function   ObjectToSOAP(RootNode, ParentNode: IXMLNode;
                            const ObjConverter: IObjConverter;
                            const Name, URI: InvString; ObjConvOpts: TObjectConvertOptions;
                            out RefID: InvString): IXMLNode; override;
    procedure  SOAPToObject(const RootNode, Node: IXMLNode; const ObjConverter: IObjConverter); override;

    property CacheFile: string read FCacheFile;
    property CacheFilePersist: Boolean read FCacheFilePersist write FCacheFilePersist default False;
    property ContentType: string read FContentType write FContentType;
    property Encoding: WideString read FEncoding write FEncoding;
    property Headers: TStrings read FHeaders;
    property Ownership: TStreamOwnership read FStreamOwnerShip write FStreamOwnerShip;
    property SourceStream: TStream read GetSourceStream;
    property SourceString: string read FSourceString write SetSourceString;

    procedure SaveToStream(AStream: TStream);
    procedure SaveToFile(AFileName: string);
    procedure SetSourceFile(const Value: string); virtual;
    procedure SetSourceStream(const Value: TStream; const Ownership: TStreamOwnership = soReference); virtual;
  end;

  TSOAPAttachmentClass = class of TSOAPAttachment;

  THeaderList = class
  private
    FObjectList: TObjectList;
  protected
    function    GetOwnsObjects: Boolean;
    procedure   SetOwnsObjects(Val: Boolean);
    function    GetCount: Integer;
    function    GetHeader(Index: Integer): TObject;
  public
    constructor Create;
    destructor  Destroy; override;

    procedure Add(Header: TSOAPHeader); overload;
    procedure Add(Header: TObject); overload;
    procedure Clear;
    function  Extract(Obj: TObject): TObject;
    function  IndexOf(Obj: TObject): Integer;
    property  Count: Integer read GetCount;
    property  OwnsObjects: Boolean read GetOwnsObjects write SetOwnsObjects;
    property  Headers[Index: Integer]: TObject read GetHeader; default;
  end;

  { Internal interface used by framework to allow ISOAPHeaders to work
    on either Client/RIO or Server/Invoker Headers }
  IHeadersSetter = interface
  ['{FC96447A-94AC-4C88-B724-192284E2DA34}']
    procedure SetHeadersInOut(var InHdrs, OutHdrs: THeaderList);
  end;

  { Client and Server side interface to send and process headers
    received }
  ISOAPHeaders = interface
  ['{E240BE0C-256F-D611-96FA-00C04FA06B45}']
    { Send this header to Service or send this header back to a Client }
    procedure Send(const Hdr: TSOAPHeader);

    { Query list of headers to be sent }
    function  SendCount: Integer;
    function  SendAt(Index: Integer): TSOAPHeader;

    { Retrieve a header sent by a a Client or returned by a Service }
    { NOTE: You have ownership of the header once you retrieve it   }
    procedure Get(Cls: TClass; out Hdr: TSOAPHeader); overload;
    function  Get(Cls: TClass): TSOAPHeader; overload;
    function  Get(const Name, URI: WideString): TSOAPHeader; overload;

    { Outbound header ownership - NOTE: We always own inbound ones until
      you retrieve them; also, ownership on the Server side is handled
      by TRemotable's DataContext!!}
    function  GetOwnsSentHeaders: Boolean;
    procedure SetOwnsSentHeaders(Flag: Boolean);

    property OwnsSentHeaders: Boolean read GetOwnsSentHeaders write SetOwnsSentHeaders;
  end;

  TSOAPHeadersBase = class(TContainedObject, IHeadersSetter)
  protected
    FHeadersInbound: THeaderList;
    FHeadersOutBound: THeaderList;
    procedure SetHeadersInOut(var InHdrs, OutHdrs: THeaderList);
  end;

  TSOAPHeaders = class(TSOAPHeadersBase, ISOAPHeaders, IHeadersSetter)
  public
    procedure Send(const Hdr: TSOAPHeader);

    { Query list of headers to be sent }
    function  SendCount: Integer;
    function  SendAt(Index: Integer): TSOAPHeader;

    { Retrieve a header sent by a a Client or returned by a Service }
    { NOTE: You have ownership of the header once you retrieve it   }
    procedure Get(Cls: TClass; out Hdr: TSOAPHeader); overload;
    function  Get(Cls: TClass): TSOAPHeader; overload;
    function  Get(const Name, URI: WideString): TSOAPHeader; overload;

    function  GetOwnsSentHeaders: Boolean;
    procedure SetOwnsSentHeaders(Flag: Boolean);
  end;

  TInvokableClass = class(TObject, IInterface)
  protected
    FSOAPHeaders: TSOAPHeaders;
    FRefCount: Integer;
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    constructor Create; virtual;
{$IFDEF CLEANUP_SOAP_HEADERS}
    destructor Destroy; override;
{$ENDIF}
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    class function NewInstance: TObject; override;
    property RefCount: Integer read FRefCount;
  end;
  TInvokableClassClass = class of TInvokableClass;


  { Used when registering a class factory  - Specify a factory callback
    if you need to control the lifetime of the object - otherwise SOAP
    will create the implementation class using the virtual constructor }
  TCreateInstanceProc = procedure(out obj: TObject);

  InvRegClassEntry = record
    ClassType: TClass;
    Proc: TCreateInstanceProc;
    URI: string;
  end;

  ExtNameMapItem = record
    Name: string;
    ExtName: WideString;
  end;