invokeregistry.pas

Delphi开发webservice的一套例子

{*******************************************************}
{                                                       }
{ Borland Delphi Visual Component Library               }
{       SOAP           Support                          }
{                                                       }
{ Copyright (c) 2001 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;

interface

uses SysUtils, TypInfo, IntfInfo, Classes, Windows, XMLSchema;

type

  InvString = WideString;

  TInvokableClass = class(TInterfacedObject)
  public
    constructor Create; virtual;
  end;
  TInvokableClassClass = class of TInvokableClass;

  TDataContext = class;

{$M+}
  TRemotable = class
  private
    FDataContext: TDataContext;
    procedure SetDataContext(Value: TDataContext);
  public
    constructor Create; virtual;
    destructor Destroy; override;
    property DataContext: TDataContext read FDataContext write SetDataContext;
  end;
{$M-}
  TRemotableXS = class(TRemotable)
  public
    function NativeToXS: WideString; virtual;
    procedure XSToNative(Data: WideString); virtual;
  end;
  PTRemotable = ^TRemotable;
  TRemotableClass = class of TRemotable;
  TRemotableXSClass = class of TRemotableXS;
{$M+}
   ERemotableException = class(Exception)
   public
     constructor CreateRem;  virtual;
   end;
{$M-}
  ERemotableExceptionClass = class of ERemotableException;


  // Used when registering a class factory
  TCreateInstanceProc = procedure(out obj: TObject);

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


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

  MethParamNameMapItem = record
    MethName: string;
    ParamNameMap: array of ExtNameMapItem;
  end;

  InvRegIntfEntry = record
    Name: string;
    ExtName: Widestring;
    UnitName: string;
    GUID: TGUID;
    Info: PTypeInfo;
    DefImpl: TClass;
    Namespace: Widestring;
    WSDLEncoding: WideString;
    Documentation: string;
    MethNameMap: array of ExtNameMapItem;
    MethParamNameMap: array of MethParamNameMapItem;
  end;
  TInvRegIntfEntryArray = array of InvRegIntfEntry;

  TInvokableClassRegistry = class(TInterfacedObject)
  private
    FLock: TRTLCriticalSection;
    FRegClasses: array of InvRegClassEntry;
    FRegIntfs: array of InvRegIntfEntry;
    procedure DeleteFromReg(AClass: TClass; Info: PTypeInfo);
  public
    constructor Create;
    destructor Destroy; override;
    function GetNamespaceByGUID(const AGUID: TGUID): string;
    function GetInfoForURI(const PathURI, ActionURI: string; var ACLass : TClass;  var IntfInfo: PTypeInfo; var AMeth: string): Boolean;
    procedure GetInterfaceInfoFromName(const UnitName,  IntfName: string; var Info: PTypeInfo; var IID: TGUID);
    function GetInterfaceTypeInfo(const AGUID: TGUID): Pointer;
    function GetInvokableObjectFromClass(AClass: TClass): TObject;
    function GetInterface(Index: Integer): InvRegIntfEntry;
    procedure GetClassFromIntfInfo(Info: PTypeInfo; var AClass: TClass);
    function GetInterfaceCount: Integer;
    procedure Lock; virtual;
    procedure UnLock; virtual;
    procedure RegisterInterface(Info: PTypeInfo; const Namespace: InvString  = ''; const WSDLEncoding: InvString = ''; const Doc: string = ''; const ExtName: InvString = '');
    function  GetInterfaceExternalName(Info: PTypeInfo; Namespace: string  = ''; InternalIntfName: string = '' ): InvString;
    function  GetWSDLEncoding(Info: PTypeInfo; Namespace: string  = ''; InternalIntfName: string = '' ): InvString;
    procedure UnRegisterInterface(Info: PTypeInfo);
    procedure RegisterInvokableClass(AClass: TClass; CreateProc: TCreateInstanceProc = nil);
    procedure UnRegisterInvokableClass(AClass: TClass);
    procedure RegisterExternalMethName(Info: PTypeInfo; InternalName: string; const ExternalName: InvString);
    procedure RegisterExternalParamName(Info: PTypeInfo; MethodName, InternalName: string; const ExternalName: InvString);
    function GetParamExternalName(Info: PTypeInfo;  MethodName, InternalParamName: string): InvString;
    function GetParamInternalName(Info: PTypeInfo;  MethodName: string; ExternalParamName: InvString): string;
    function GetMethExternalName(Info: PTypeInfo;  MethodIntName: string): InvString;
    function GetMethInternalName(Info: PTypeInfo;  MethodExtName: InvString): string;
  end;

  { Classes used to register classes that map from pascal to/from XSD }

  TObjMultiOptions = (ocDefault, ocMultiRef, ocNoMultiRef);
  TRemRegEntry = record
    ClassType: TClass;
    Info: PTypeInfo;
    URI: WideString;
    Name: WideString;
    ExtName: WideString;
    IsScalar: Boolean;
    MultiRefOpt: TObjMultiOptions;
  end;


  ETypeRegistryException = class(Exception);

  TPascalRemotableTypeRegistry = class
  private
    FLock: TRTLCriticalSection;
    URIMap: array of TRemRegEntry;
    function GetEntry(Info: PTypeInfo; var Found: Boolean): Integer;
    procedure DeleteEntryFromURIMap(Info: PTypeInfo);
    function GetSimpleBuiltInXSDType(const URI, TypeName: WideString): PTypeInfo;
    function GetRegisteredClassForBuiltInXSD(const TypeName: WideString): TClass;
  public
    constructor Create;
    destructor Destroy; override;
    function  ClassToURI(AClass: TClass; var URI, Name: WideString; var IsScalar: Boolean): Boolean; overload;
    function  InfoToURI(Info: PTypeInfo; var URI, Name: WideString; var IsScalar: Boolean): Boolean;
    procedure RegisterXSClass(AClass: TClass; URI: WideString = ''; Name: WideString = ''; ExtName: WideString = ''; IsScalar: Boolean = False; MultiRefOpt: TObjMultiOptions = ocDefault);
    procedure RegisterXSInfo(Info: PTypeInfo; URI: WideString = ''; Name: WideString = ''; ExtName: WideString = '');
    function GetURICount: Integer;
    function GetURIMap(Index: Integer): TRemRegEntry;
    function  TypeInfoToXSD(Info: PTypeInfo; var URI, TypeName: WideString): Boolean;
    function URIToClass(URI, Name: WideString; var IsScalar: Boolean): TClass;
    procedure GetXSDInfoForClass(Info: PTypeInfo; var URI, TypeName: WideString);
    function XSDToTypeInfo(URI, TypeName: WideString): PTypeInfo;
    function IsClassScalar(AClass: TClass): Boolean;
    function ClassOptions(AClass: TClass): TObjMultiOptions;
    function URIToInfo(const URI, Name: WideString): PTypeInfo;
    function VariantToInfo(V: Variant; TryAllSchema: Boolean): PTypeInfo;
    function GetVarTypeFromXSD(URI, TypeName: InvString): TVarType;
    procedure Lock; virtual;
    procedure UnLock; virtual;
    procedure UnRegisterXSClass(AClass: TClass);
    procedure UnRegisterXSInfo(Info: PTypeInfo);
    procedure RegisterExternalPropName(Info: PTypeInfo; InternalName: string; const ExternalName: InvString);
    function GetExternalPropName(Info: PTypeInfo; InternalName: string): InvString;
    function GetInternalPropName(Info: PTypeInfo; ExternalName: InvString): string;
  end;

  TPascalRemotableClassRegistry = TPascalRemotableTypeRegistry;

  TDynToClear = record
    P: Pointer;
    Info: PTypeInfo;
  end;

  TDataContext = class
  protected
    FObjsToDestroy: array of TObject;
    DataOffset: Integer;
    Data: array of Byte;
    DataP: array of Pointer;
    VarToClear: array of Pointer;
    DynArrayToClear: array of TDynToClear;
    StrToClear: array of Pointer;
  public
    constructor Create;
    destructor Destroy; override;
    function AllocData(Size: Integer): Pointer;
    procedure SetDataPointer(Index: Integer; P: Pointer);
    function GetDataPointer(Index: Integer): Pointer;
    procedure AddObjectToDestroy(Obj: TObject);
    procedure RemoveObjectToDestroy(Obj: TObject);
    procedure AddDynArrayToClear(P: Pointer; Info: PTypeInfo);
    procedure AddVariantToClear(P: PVarData);
    procedure AddStrToClear(P: Pointer);
  end;

  TInvContext = class(TDataContext)
  private
    ResultP: Pointer;
  public
    procedure SetMethodInfo(const MD: TIntfMethEntry);
    procedure SetParamPointer(Param: Integer; P: Pointer);
    function GetParamPointer(Param: Integer): Pointer;
    function GetResultPointer: Pointer;
    procedure SetResultPointer(P: Pointer);
    procedure AllocServerData(const MD: TIntfMethEntry);
  end;

  function GetRemotableDataContext: Pointer;
  procedure SetRemotableDataContext(Value: Pointer);

  function InvRegistry:   TInvokableClassRegistry;
  function RemClassRegistry: TPascalRemotableClassRegistry;
  function RemTypeRegistry: TPascalRemotableTypeRegistry;

var
  AppNameSpacePrefix: string;

const
  XMLSchemaInstNamepspaces: array[0..2] of InvString =
    (SXMLSchemaInstURI_1999, SXMLSchemaInstURI_2000_10, SXMLSchemaInstURI);

  XMLSchemaNamepspaces: array[0..2] of InvString =
    (SXMLSchemaURI_1999, SXMLSchemaURI_2000_10, SXMLSchemaURI_2001);

  XMLBase64Types: array[0..1] of InvString = ('base64Binary', 'bin.base64');

implementation

uses  Variants, InvRules, SoapConst, Types;

var
  InvRegistryV: TInvokableClassRegistry;
  RemClassRegistryV: TPascalRemotableClassRegistry;
  RemTypeRegistryV: TPascalRemotableTypeRegistry;


threadvar
  RemotableDataContext: Pointer;

function InvRegistry: TInvokableClassRegistry;
begin
  Result :=  InvRegistryV;
end;

function RemClassRegistry: TPascalRemotableClassRegistry;
begin
  Result := RemTypeRegistryV;
end;

function RemTypeRegistry: TPascalRemotableTypeRegistry;
begin
  Result := RemTypeRegistryV;
end;

function GetRemotableDataContext: Pointer;
begin
  Result := RemotableDataContext;
end;

procedure SetRemotableDataContext(Value: Pointer);
begin
  RemotableDataContext := Value;
end;

function TInvokableClassRegistry.GetInterfaceCount: Integer;
begin
  Result := 0;
  if FRegIntfs <> nil then
    Result := Length(FRegIntfs);
end;

function TInvokableClassRegistry.GetInterface(Index: Integer): InvRegIntfEntry;
begin
  if Index < Length(FRegIntfs) then
    Result := FRegIntfs[Index];
end;

constructor TInvokableClassRegistry.Create;
begin
  inherited Create;
  InitializeCriticalSection(FLock);
end;

destructor TInvokableClassRegistry.Destroy;
begin
  DeleteCriticalSection(FLock);
  inherited Destroy;
end;

procedure TInvokableClassRegistry.Lock;
begin
  EnterCriticalSection(FLock);
end;

procedure TInvokableClassRegistry.UnLock;
begin
  LeaveCriticalSection(FLock);
end;

procedure TInvokableClassRegistry.RegisterInvokableClass(AClass: TClass; CreateProc: TCreateInstanceProc);
var
  Index, I, J: Integer;
  Table: PInterfaceTable;
begin
  Lock;
  try
    Table := AClass.GetInterfaceTable;
    if Table = nil then
      raise ETypeRegistryException.CreateFmt(SNoInterfacesInClass, [AClass.ClassName]);
    Index := Length(FRegClasses);
    SetLength(FRegClasses, Index + 1);
    FRegClasses[Index].ClassType := AClass;
    FRegClasses[Index].Proc := CreateProc;
    for I := 0 to Table.EntryCount - 1 do
    begin
      for J := 0 to Length(FRegIntfs) - 1 do
        if IsEqualGUID(FRegIntfs[J].GUID, Table.Entries[I].IID) then
          FRegIntfs[J].DefImpl := AClass;
    end;
  finally
    UnLock;
  end;
end;

procedure TInvokableClassRegistry.DeleteFromReg(AClass: TClass; Info: PTypeInfo);
var
  I, Index, ArrayLen: Integer;
begin
  Lock;
  try
    Index := -1;
    if Assigned(Info) then
      ArrayLen := Length(FRegIntfs)
    else
      ArrayLen := Length(FRegClasses);
    for I := 0 to ArrayLen - 1 do
    begin
      if (Assigned(Info) and (FRegIntfs[I].Info = Info)) or
        (Assigned(AClass) and (FRegClasses[I].ClassType = AClass)) then
      begin
        Index := I;
        break;
      end;
    end;
    if Index <> -1 then
    begin
      if Assigned(Info) then
      begin
        for I := Index to ArrayLen - 2 do
          FRegIntfs[I] := FRegIntfs[I+1];
        SetLength(FRegIntfs, Length(FRegIntfs) -1);
      end else
      begin
        for I := Index to ArrayLen - 2 do
          FRegClasses[I] := FRegClasses[I+1];
        SetLength(FRegClasses, Length(FRegClasses) -1);
      end;
    end;
  finally
    UnLock;
  end;
end;

procedure TInvokableClassRegistry.UnRegisterInvokableClass(AClass: TClass);
begin
  DeleteFromReg(AClass, Nil);
end;

procedure TInvokableClassRegistry.RegisterInterface(Info: PTypeInfo; const Namespace: InvString = '';
  const WSDLEncoding: InvString = ''; const Doc: string = ''; const ExtName: InvString = '');
var
  Index: Integer;
  IntfMD: TIntfMetaData;
  I, J: Integer;
  Table: PInterfaceTable;
  URIApp: string;
begin
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
      if FRegIntfs[I].Info = Info then
        Exit;
    Index := Length(FRegIntfs);
    SetLength(FRegIntfs, Index + 1);
    GetIntfMetaData(Info, IntfMD, True);
    FRegIntfs[Index].GUID := IntfMD.IID;
    FRegIntfs[Index].Info := Info;
    FRegIntfs[Index].Name := IntfMD.Name;
    FRegIntfs[Index].UnitName := IntfMD.UnitName;
    FRegIntfs[Index].Documentation := Doc;
    FRegIntfs[Index].ExtName := ExtName;
    FRegIntfs[Index].WSDLEncoding := WSDLEncoding;

    if AppNameSpacePrefix <> '' then
      URIApp :=  AppNameSpacePrefix +  '-';

    if Namespace = '' then
      FRegIntfs[Index].Namespace :=  'urn:' + URIApp + IntfMD.UnitName + '-' + IntfMD.Name
    else
      FRegIntfs[Index].Namespace := Namespace;

    if FRegIntfs[Index].DefImpl = nil then
    begin
      for I := 0 to Length(FRegClasses) - 1 do
      begin
        Table :=  FRegClasses[I].ClassType.GetInterfaceTable;
        for J := 0 to Table.EntryCount - 1 do
        begin
          if IsEqualGUID(IntfMD.IID, Table.Entries[J].IID) then
          begin
            FRegIntfs[Index].DefImpl := FRegClasses[I].ClassType;
            Exit;
          end;
        end;