📄 invokeregistry.pas
字号:
MethParamNameMapItem = record
MethName: string;
ParamNameMap: array of ExtNameMapItem;
end;
eHeaderMethodType = (hmtAll, hmtRequest, hmtResponse);
THeaderMethodTypeArray = array of eHeaderMethodType;
TRequiredArray = array of Boolean;
IntfHeaderItem = record
Info: PTypeInfo;
ClassType: TClass;
Namespace: WideString; { Header namespace }
Name: WideString; { Header name }
DefaultMethodType: eHeaderMethodType; { used if MethodNames = '' }
DefaultRequired: Boolean; { used if MethodNames = '' }
MethodNames: string; { comma-delimited list of Method Names }
MethodTypes: THeaderMethodTypeArray; { matching array of in/out/inout enums }
HeaderRequired: TRequiredArray; { matching array of Required Booleans }
end;
THeaderItemArray = array of IntfHeaderItem;
IntfExceptionItem = record
ClassType: TClass;
MethodNames: string;
end;
TExceptionItemArray = array of IntfExceptionItem;
{ Options that control invocation & specify items found when
a porttype was imported }
TIntfInvokeOption = (ioDefault, { Nothing special }
ioDocument, { We're passing documents - don't use Sect-5 Encoding }
ioLiteral, { We have unwrapped literal params - skip method node }
ioHasDefaultSOAPAction, { We have a default SOAP Action }
ioHasReturnParamNames, { We have specific return parameter names }
ioHasNamespace, { We have a namespace }
ioIsAppServerSOAP, { The interface derives from IAppServerSOAP }
ioHasUDDIInfo, { We have UDDI info, for fail-over lookup }
ioHasAllSOAPActions { Have all operation SOAPActions }
);
TIntfInvokeOptions= set of TIntfInvokeOption;
InvRegIntfEntry = record
Name: string; { Native name of interface }
ExtName: Widestring; { PortTypeName }
UnitName: string; { Filename of interface }
GUID: TGUID; { GUID of interface }
Info: PTypeInfo; { Typeinfo of interface }
DefImpl: TClass; { Metaclass of implementation }
Namespace: Widestring; { XML Namespace of type }
WSDLEncoding: WideString; { Encoding }
Documentation: string; { Description of interface }
SOAPAction: string; { SOAPAction of interface }
{$IFDEF WIDE_RETURN_NAMES}
ReturnParamNames: InvString; { Return Parameter names }
{$ELSE}
ReturnParamNames: string; { Return Parameter names }
{$ENDIF}
InvokeOptions: TIntfInvokeOptions; { Invoke Options }
MethNameMap: array of ExtNameMapItem; { Renamed methods }
MethParamNameMap: array of MethParamNameMapItem; { Renamed parameters }
IntfHeaders: array of IntfHeaderItem; { Headers }
IntfExceptions: array of IntfExceptionItem;{ Exceptions }
UDDIOperator: String; { UDDI Registry of this porttype }
UDDIBindingKey: String; { UDDI Binding key }
end;
TInvRegIntfEntryArray = array of InvRegIntfEntry;
TInvokableClassRegistry = class(TInterfacedObject (*, IInvokableRegistry *))
private
FLock: TRTLCriticalSection;
FRegClasses: array of InvRegClassEntry;
FRegIntfs: array of InvRegIntfEntry;
procedure DeleteFromReg(AClass: TClass; Info: PTypeInfo);
procedure InternalRegisterHeaderClass(Info: PTypeInfo; AClass: TClass;
const HeaderName: WideString; const HeaderNamespace: WideString;
DefaultMethodType: eHeaderMethodType; const MethodName: string = '';
MethodType: eHeaderMethodType = hmtAll; Required: Boolean = False);
procedure InternalRegisterException(Info: PTypeInfo; AClass: TClass; const MethodName: string);
function InternalGetHeaderName(const Item: IntfHeaderItem): WideString;
function InternalGetHeaderNamespace(const Item: IntfHeaderItem): WideString;
public
constructor Create;
destructor Destroy; override;
{ Basic Invokable Interface Registration Routine }
procedure RegisterInterface(Info: PTypeInfo; const Namespace: InvString = ''; const WSDLEncoding: InvString = ''; const Doc: string = ''; const ExtName: InvString = '');
{ Header registration }
procedure RegisterHeaderClass(Info: PTypeInfo; AClass: TClass;
const HeaderName: WideString; const HeaderNamespace: WideString;
DefaultMethodType: eHeaderMethodType = hmtAll;
Required: Boolean = False); overload;
procedure RegisterHeaderClass(Info: PTypeInfo; AClass: TClass;
DefaultMethodType: eHeaderMethodType = hmtAll;
Required: Boolean = False); overload;
{ Limit Header application to specific methods }
procedure RegisterHeaderMethod(Info: PTypeInfo; AClass: TClass;
const MethodName: string; MethodType: eHeaderMethodType = hmtAll;
Required: Boolean = False); overload;
{ Header Access }
function GetHeaderInfoForInterface(Info: PTypeInfo; MethodType: eHeaderMethodType = hmtAll): THeaderItemArray;
function GetRequestHeaderInfoForInterface(Info: PTypeInfo): THeaderItemArray;
function GetResponseHeaderInfoForInterface(Info: PTypeInfo): THeaderItemArray;
function GetHeaderName(Info: PTypeInfo; AClass: TClass): WideString;
function GetHeaderNamespace(Info: PTypeInfo; AClass: TClass): WideString; overload;
function GetHeaderNamespace(AClass: TClass): WideString; overload;
function GetHeaderClass(Name, Namespace: WideString): TClass;
{ Exception Class registration }
procedure RegisterException(Info: PTypeInfo; AClass: TClass);
procedure RegisterExceptionMethod(Info: PTypeInfo; AClass: TClass; const MethodName: string);
{ Exception Access }
function GetExceptionInfoForInterface(Info: PTypeInfo): TExceptionItemArray;
procedure RegisterExternalMethName(Info: PTypeInfo; const InternalName: string; const ExternalName: InvString);
procedure RegisterExternalParamName(Info: PTypeInfo; const MethodName, InternalName: string; const ExternalName: InvString);
procedure RegisterInvokableClass(AClass: TClass; CreateProc: TCreateInstanceProc); overload;
procedure RegisterInvokableClass(AClass: TClass); overload;
{ SOAPAction - related API }
procedure RegisterDefaultSOAPAction(Info: PTypeInfo; const DefSOAPAction: InvString);
procedure RegisterAllSOAPActions(Info: PTypeInfo; const AllSOAPActions: InvString);
function GetActionURIOfInfo(const IntfInfo: PTypeInfo; const MethodName: WideString; MethodIndex: Integer): string;
function GetActionURIOfIID(const AGUID: TGUID): string;
{ UDDI - related API }
procedure RegisterUDDIInfo(Info: PTypeInfo; const Operator: String; const BindingKey: string);
function GetUDDIInfo(const IntfInfo: PTypeInfo; var Operator, BindingKey: string): Boolean; overload;
function GetUDDIInfo(const AGUID: TGUID; var Operator, BindingKey: string): Boolean; overload;
{$IFDEF WIDE_RETURN_PARAM_NAMES}
procedure RegisterReturnParamNames(Info: PTypeInfo; const RetParamNames: InvString);
function GetReturnParamNames(const IntfInfo: PTypeInfo): InvString;
{$ELSE}
procedure RegisterReturnParamNames(Info: PTypeInfo; const RetParamNames: string);
function GetReturnParamNames(const IntfInfo: PTypeInfo): string;
{$ENDIF}
procedure RegisterInvokeOptions(Info: PTypeInfo; const InvokeOption: TIntfInvokeOption); overload;
procedure RegisterInvokeOptions(Info: PTypeInfo; const InvokeOptions: TIntfInvokeOptions); overload;
private
procedure Lock; virtual;
procedure UnLock; virtual;
function GetIntfIndex(const IntfInfo: PTypeInfo): Integer;
public
function GetNamespaceByGUID(const AGUID: TGUID): string;
function GetInfoForURI(const PathURI, ActionURI: string; var ACLass : TClass; var IntfInfo: PTypeInfo; var AMeth: string): Boolean;
function GetIntfInvokeOptions(const IntfInfo: PTypeInfo): TIntfInvokeOptions; overload;
function GetIntfInvokeOptions(const AGUID: TGUID): TIntfInvokeOptions; overload;
procedure GetInterfaceInfoFromName(const UnitName, IntfName: string; var Info: PTypeInfo; var IID: TGUID);
function GetInterfaceTypeInfo(const AGUID: TGUID): Pointer;
function GetInvokableObjectFromClass(AClass: TClass): TObject;
function GetRegInterfaceEntry(Index: Integer): InvRegIntfEntry;
function HasRegInterfaceImpl(Index: Integer): Boolean;
procedure GetClassFromIntfInfo(Info: PTypeInfo; var AClass: TClass);
function GetInterfaceCount: Integer;
function GetInterfaceExternalName(Info: PTypeInfo; const Namespace: string; const InternalIntfName: string): InvString; overload;
function GetInterfaceExternalName(Info: PTypeInfo; const Namespace: string): InvString; overload;
function GetInterfaceExternalName(Info: PTypeInfo): InvString; overload;
function GetWSDLEncoding(Info: PTypeInfo; const Namespace: string; const InternalIntfName: string): InvString; overload;
function GetWSDLEncoding(Info: PTypeInfo; const Namespace: string): InvString; overload;
function GetWSDLEncoding(Info: PTypeInfo): InvString; overload;
procedure UnRegisterInterface(Info: PTypeInfo);
procedure UnRegisterInvokableClass(AClass: TClass);
function GetParamExternalName(Info: PTypeInfo; const MethodName, InternalParamName: string): InvString;
function GetParamInternalName(Info: PTypeInfo; const MethodName: string; const ExternalParamName: InvString): string;
function GetMethExternalName(Info: PTypeInfo; const MethodIntName: string): InvString;
function GetMethInternalName(Info: PTypeInfo; const MethodExtName: InvString): string;
end;
{ Classes used to register classes that map from pascal to/from XSD }
TRemHeaderEntry = record
Name: WideString;
ExtName: WideString;
URI: WideString;
end;
TObjMultiOptions = (ocDefault, ocMultiRef, ocNoMultiRef);
TRemRegEntry = record
ClassType: TClass;
Info: PTypeInfo;
URI: WideString;
Name: WideString;
ExtName: WideString;
IsScalar: Boolean;
MultiRefOpt: TObjMultiOptions;
SerializationOpt: TSerializationOptions;
PropNameMap: array of ExtNameMapItem; { Renamed properties }
end;
TRemRegEntryArray = array of TRemRegEntry;
ETypeRegistryException = class(Exception);
TRemotableTypeRegistry = class
private
FAutoRegister: Boolean;
FLock: TRTLCriticalSection;
URIMAP: array of TRemRegEntry;
function GetEntry(Info: PTypeInfo; var Found: Boolean; const Name: WideString=''): Integer;
function FindEntry(Info: PTypeInfo; var Found: Boolean; const Name: WideString=''): Integer;
procedure DeleteEntryFromURIMap(Info: PTypeInfo);
function GetSimpleBuiltInXSDType(const URI, TypeName: WideString): PTypeInfo;
function GetRegisteredClassForBuiltInXSD(const TypeName: WideString): TClass;
protected
procedure Lock; virtual;
procedure UnLock; virtual;
public
constructor Create;
destructor Destroy; override;
{ Remotable class registration }
procedure RegisterXSClass(AClass: TClass; const URI: WideString = ''; const Name: WideString = '';
const ExtName: WideString= ''; IsScalar: Boolean = False;
MultiRefOpt: TObjMultiOptions = ocDefault);
{ TypeInfo registration }
procedure RegisterXSInfo(Info: PTypeInfo; const URI: WideString = ''; const Name: WideString = ''; const ExtName: WideString = '');
{ TypeInfo registration via a Holder class }
procedure RegisterHolderClsMember(ClsTypeInfo: PTypeInfo; const URI: WideString = ''; const Name: WideString = ''; const ExtName: WideString = '');
{ Query routines to conver Native Type to XML name and namespace }
function ClassToURI(AClass: TClass; var URI, Name: WideString; var IsScalar: Boolean; tryToRegister: Boolean = True): Boolean; overload;
function ClassToURI(AClass: TClass; var URI, Name: WideString): Boolean; overload;
function InfoToURI(Info: PTypeInfo; var URI, Name: WideString; var IsScalar: Boolean; tryToRegister: Boolean = True): Boolean;
function TypeInfoToXSD(Info: PTypeInfo; var URI, TypeName: WideString): Boolean;
procedure GetXSDInfoForClass(Info: PTypeInfo; var URI, TypeName: WideString);
{ Query routines to convert XML name/namespace to Native TypeInfo }
function URIToClass(const URI, Name: WideString; var IsScalar: Boolean): TClass; overload;
function URIToClass(const URI, Name: WideString): TClass; overload;
function XSDToTypeInfo(const URI, TypeName: WideString): PTypeInfo;
function URIToInfo(const URI, Name: WideString): PTypeInfo;
{ Query registry information }
function GetURICount: Integer;
function GetURIMap(Index: Integer): TRemRegEntry; overload;
function GetURIMap(Index: Integer; out RegEntry: TRemRegEntry): boolean; overload;
{ Class options }
function IsClassScalar(AClass: TClass): Boolean;
function ClassOptions(AClass: TClass): TObjMultiOptions;
{ Variant-related conversions }
function VariantToInfo(const V: Variant; TryAllSchema: Boolean): PTypeInfo;
function GetVarTypeFromXSD(const URI, TypeName: InvString): TVarType;
{ Serialization options }
procedure RegisterSerializeOptions(Info: PTypeInfo; SerialOpt: TSerializationOptions); overload;
function SerializeOptions(Info: PTypeInfo): TSerializationOptions; overload;
procedure RegisterSerializeOptions(AClass: TClass; SerialOpt: TSerializationOptions); overload;
function SerializeOptions(AClass: TClass): TSerializationOptions; overload;
{ Unregister API }
procedure UnRegisterXSClass(AClass: TClass);
procedure UnRegisterXSInfo(Info: PTypeInfo);
{ Name mappings: Internal <-> External }
procedure RegisterExternalPropName(Info: PTypeInfo; const InternalName: string; const ExternalName: InvString);
function GetExternalPropName(Info: PTypeInfo; InternalName: string): InvString;
{$IFDEF CONST_WIDESTRING_PARAMS}
function GetInternalPropName(Info: PTypeInfo; const ExternalName: InvString): string;
{$ELSE}
function GetInternalPropName(Info: PTypeInfo; ExternalName: InvString): string;
{$ENDIF}
{ Flag to automatically register types }
property AutoRegisterNativeTypes: Boolean read FAutoRegister write FAutoRegister;
end;
TRemotableClassRegistry = TRemotableTypeRegistry;
TPascalRemotableTypeRegistry = TRemotableTypeRegistry;
TPascalRemotableClassRegistry = TRemotableTypeRegistry;
{ Forward ref. structure to satisfy DynamicArray<Type> }
{ encountered before declaration of Type itself in .HPP file }
(*$HPPEMIT 'namespace Invokeregistry {' *)
(*$HPPEMIT 'struct TDynToClear;' *)
(*$HPPEMIT '};' *)
(*$HPPEMIT 'using Invokeregistry::TDynToClear;' *)
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;
WStrToClear: 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);
procedure AddWStrToClear(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: TRemotableClassRegistry;
function RemTypeRegistry: TRemotableTypeRegistry;
function SubstituteStrings(const InputString: WideString;
const SubString: WideString;
const Replacement: WideString): WideString;
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');
{
'AS_ATTRIBUTE' is deprecated. The WSDL importer now uses the 'Index' value of
property declarations instead of the 'stored' value to tag properties that map
to XML attributes.
}
AS_ATTRIBUTE = False;
implementation
uses Variants, InvRules, SOAPConst, XSBuiltIns, xmldom, OPToSOAPDomConv, HTTPUtil;
var
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -