最近阅读了SocketConn的源码和WebService 的源码，把追踪的过程写了下来，方便大家学习。毕竟这需要精力，时间和毅力。感谢煮茶待英雄博志区和三层数据库讨论区兄弟们的支持，特别是julian兄弟，不是他，我可能没耐心继续下去。如果有时间，大家可以继续完善。从socket和Websevice的底层实现细节，我们发现BORLAND的工程师们的构思和实现的过程。我觉得这对我们的学习应该是非常重要的。学会思考。学会读源码，学会分析。
希望和我交往的朋友可通过QQ或Email联系我。Wu_yanan2003@yahoo.com.cn 11718111
另见：《远程调用技术代码追踪(socket) 》
《远程调用技术代码追踪(第三方控件) 》
webservice内部工作机制比较复杂，有些地方分析错误在所难免。加上时间关系，比较匆忙。有错误的地方，请斧正。学习不密闭。有些地方贴了些图片。不好贴上来，所以不是很完整，有需要的，可以QQ，或者MAIL联系我。
远程调用技术内幕
有关WebService的相关的知识，我就不说了，我直接分析源码。有问题的地方请参考李维的书。
initialization
InvRegistry.RegisterInterface(TypeInfo(IMyFirstWS), 'urn:MyFirstWSIntf-IMyFirstWS', 'utf-8');
看过李维的分布式架构的应该都知道，WEB服务端对类和接口进行了注册，客户端这里也进行了注册。然后客户端把数据通过HTTP传输到服务器端，服务器端通过拆包，去到注册管理的类中寻找相应的接口，并创建一个相应的对象，把客户端的数据压进去，调用后，把数据再传回来。
在调用这句的时候，TinvokableClassRegistry类已经创建了，由于inquire_v1也引用了InvRegistry注册，所以在哪里被引用的时候已经被创建了。
function InvRegistry: TInvokableClassRegistry;
begin
if not Assigned(InvRegistryV) then
InitIR;
Result := InvRegistryV;
end;
初次引用会调用InitIR方法。
procedure InitIR;
begin
InvRegistryV := TInvokableClassRegistry.Create;
RemTypeRegistryV := TRemotableClassRegistry.Create;
RemClassRegistryV:= RemTypeRegistry;
InitBuiltIns; //定们到这一句：
InitXSTypes;
InitMoreBuiltIns;
end;
先看InvRegistryV := TInvokableClassRegistry.Create;，这个类是用来注册，相应的接口及类，
并能够根据soap封包内容找到相应的接口及方法。
TRemotableClassRegistry = TRemotableTypeRegistry;
所对应的是TremotableTypeRegistry, 这个类主要是对数据类型进行注册。
大致来了解一下这个类。
TInvokableClassRegistry = class(TInterfacedObject)
private
FLock: TRTLCriticalSection;
FRegClasses: array of InvRegClassEntry;
FRegIntfs: array of InvRegIntfEntry;
这里可以看到，声明了两个动态数组。分别用来放接口注册，及类注册信息。
TCreateInstanceProc = procedure(out obj: TObject);
InvRegClassEntry = record
ClassType: TClass;
Proc: TCreateInstanceProc;
URI: string;
end;
它包含了webservice实现类的指针，以建立实现类的factory函数指针。
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 }
ReturnParamNames: string; { Return Parameter names }
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;
看到它里面有很多东西，接口名称，单元名，GUID等信息。
procedure InitBuiltIns;
begin
{ DO NOT LOCALIZE }
RemClassRegistry.RegisterXSInfo(TypeInfo(System.Boolean), XMLSchemaNameSpace, 'boolean');
对于处理结构型数据，需要进行SOAP封包类型的转换
开发人员在使用这种自定义数据类型前必须对其进行注册，分别是RegisterXSClass和RegisterXSInfo。前一个方法是注册从Tremotable继承下来的类，后一个不需要是从TremotablXS继承下来的类。
InitBuiltIns;
InitXSTypes;
InitMoreBuiltIns;
这三个函数类似，都是注册一些基本类型等。
看看到底怎么处理的,(这里注册一个BOOLEAN类型)
RemClassRegistry.RegisterXSInfo(TypeInfo(System.Boolean), XMLSchemaNameSpace, 'boolean');
procedure TRemotableTypeRegistry.RegisterXSInfo(Info: PTypeInfo; const URI: WideString = '';
const Name: WideString = '';
const ExtName: WideString = '');
…
Index := GetEntry(Info, Found, Name);
if Found then
Exit;
if AppNameSpacePrefix <> '' then
AppURI := AppNameSpacePrefix + '-';
if URI = '' then
begin
if Info.Kind = tkDynArray then
begin
UnitName := GetTypeData(Info).DynUnitName;
URIMap[Index].URI := 'urn:' + AppURI + UnitName;
end
else if Info.Kind = tkEnumeration then
begin
UnitName := GetEnumUnitName(Info);
URIMap[Index].URI := 'urn:' + AppURI + UnitName;
end
else if Info.Kind = tkClass then
URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(Info).UnitName
else
URIMap[Index].URI := 'urn:' + AppURI;
end
else
URIMap[Index].URI := URI;
if Name <> '' then
URIMap[Index].Name := Name
else
begin
URIMap[Index].Name := Info.Name;
end;
URIMap[Index].ExtName := ExtName;
URIMap[Index].Info := Info;
if Info.Kind = tkClass then
URIMap[Index].ClassType := GetTypeData(Info).ClassType;
finally
UnLock;
end;
end;
看研究一下GetEntry函数，这里以后多次用到，发现这个函数是TremotableClassRegistry类的，说明实际的注册还是在TremotableClassRegistry这个类完成的。
function TRemotableClassRegistry.GetEntry(Info: PTypeInfo; var Found: Boolean; const Name: WideString): Integer;
begin
Result := FindEntry(Info, Found, Name);
if not Found then
SetLength(URIMap, Result + 1);
end;
这个函数功能是搜索类型是否已注册，否则，动态数组加1，分配空间进行注册。
看看FindEntry (这里传进来的info是TypeInfo(System.Boolean), name: Boolean)
function TRemotableClassRegistry.FindEntry(Info: PTypeInfo; var Found: Boolean; const Name: WideString): Integer;
begin
Result := 0;
Found := False;
while Result < Length(URIMap) do
begin
if (Info <> nil) and (URIMap[Result].Info = Info) then
begin
if (Name = '') or (URIMap[Result].Name = Name) then
begin
Found := True;
Exit;
end;
end;
Inc(Result);
end;
end;
这个函数的功能是遍历整个动态数组TremRegEntry，利用TypeInfo信息和名字进行搜索，查看是否已进行注册。
看看URIMAP的定义：
URIMAP: array of TRemRegEntry;
TObjMultiOptions = (ocDefault, ocMultiRef, ocNoMultiRef);
TRemRegEntry = record
ClassType: TClass; //类信息
Info: PtypeInfo; // typeInfo信息（RTTL）
URI: WideString; //
Name: WideString; //
ExtName: WideString; //
IsScalar: Boolean; //
MultiRefOpt: TObjMultiOptions; //
SerializationOpt: TSerializationOptions;
PropNameMap: array of ExtNameMapItem; { Renamed properties }
end;
继续RegisterXSInfo函数：
这是对动态数组的uri赋值：
if AppNameSpacePrefix <> '' then
AppURI := AppNameSpacePrefix + '-';
if URI = '' then
begin
if Info.Kind = tkDynArray then
begin
UnitName := GetTypeData(Info).DynUnitName;
URIMap[Index].URI := 'urn:' + AppURI + UnitName;
end
else if Info.Kind = tkEnumeration then
begin
UnitName := GetEnumUnitName(Info);
URIMap[Index].URI := 'urn:' + AppURI + UnitName;
end
else if Info.Kind = tkClass then
URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(Info).UnitName
else
URIMap[Index].URI := 'urn:' + AppURI;
end
else
URIMap[Index].URI := URI;
if Name <> '' then
URIMap[Index].Name := Name
else
begin
URIMap[Index].Name := Info.Name;
end;
这句比较关键：
URIMap[Index].Info := Info;
把RTTL信息保存在URL动态数组中。
总结一下：一些基本类型，都是通过这种方式，把URI，及INFO信息保存在动态数组中的。
为什么要进行登记，因为WEBSERVICE中的数据类型要转换成DELPHI的PAS类型，用URI标记的XML文件，传输之后，根据这张对照表，就可以分配相应的空间。另外这些类型的注册信息是放在：TremRegEntry动态数组中的。和我们自己定义的接口及类是不同的。
FRegClasses: array of InvRegClassEntry;
FRegIntfs: array of InvRegIntfEntry; 这是注册自己定义接口及类的动态数组。
再来分析：
InitBuiltIns函数中的：
RemClassRegistry.RegisterXSClass(TSOAPAttachment, XMLSchemaNamespace, 'base64Binary', '', False, ocNoMultiRef);
大致和基本类型差不多。
procedure TRemotableTypeRegistry.RegisterXSClass(AClass: TClass; const URI: WideString = '';
const Name: WideString = '';
const ExtName: WideString = '';
IsScalar: Boolean = False;
MultiRefOpt: TObjMultiOptions = ocDefault);
var
Index: Integer;
Found: Boolean;
AppURI: WideString;
begin
Lock;
try
Index := GetEntry(AClass.ClassInfo, Found, Name);
if not Found then
begin
if AppNameSpacePrefix <> '' then
AppURI := AppNameSpacePrefix + '-';
if URI = '' then
URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(AClass.ClassInfo).UnitName { do not localize }
else
URIMap[Index].URI := URI;
if Name <> '' then
URIMap[Index].Name := Name
else
begin
URIMap[Index].Name := AClass.ClassName;
end;
URIMap[Index].ExtName := ExtName;
URIMap[Index].ClassType := AClass;
URIMap[Index].Info := AClass.ClassInfo;
URIMap[Index].IsScalar := IsScalar;
URIMap[Index].MultiRefOpt := MultiRefOpt;
end;
finally
UnLock;
end;
end;
前面都是说系统类型的注册。下面看看我们自己定义的接口，是如何注册的：
procedure TInvokableClassRegistry.RegisterInterface(Info: PTypeInfo; const Namespace: InvString;
const WSDLEncoding: InvString; const Doc: string; const ExtName: InvString);
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 + '-';
{ Auto-generate a namespace from the filename in which the interface was declared and
the AppNameSpacePrefix }
if Namespace = '' then
FRegIntfs[Index].Namespace := 'urn:' + URIApp + IntfMD.UnitName + '-' + IntfMD.Name
else
begin
FRegIntfs[Index].Namespace := Namespace;
FRegIntfs[Index].InvokeOptions := FRegIntfs[Index].InvokeOptions + [ioHasNamespace];
end;
if FRegIntfs[Index].DefImpl = nil then
begin
{ NOTE: First class that implements this interface wins!! }
for I := 0 to Length(FRegClasses) - 1 do
begin
Table := FRegClasses[I].ClassType.GetInterfaceTable;
if (Table = nil) then
begin
Table := FRegClasses[I].ClassType.ClassParent.GetInterfaceTable;
end;
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;
end;
end;
finally
Unlock;
end;
end;
功能：
for I := 0 to Length(FRegIntfs) - 1 do
if FRegIntfs[I].Info = Info then
Exit;
遍历FRegIntfs: array of InvRegIntfEntry;数组，根据TypeInfo信息判断该接口是否已注册。
Index := Length(FRegIntfs);
SetLength(FRegIntfs, Index + 1);
新增一个数组元素。
GetIntfMetaData(Info, IntfMD, True);
//得到接口的RTTL信息，然后动态增加到注册的动态数组中。
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;
DefImpl里存放的是classType信息：
if FRegIntfs[Index].DefImpl = nil then
begin
for I := 0 to Length(FRegClasses) - 1 do
begin
Table := FRegClasses[I].ClassType.GetInterfaceTable;
if (Table = nil) then
begin
Table := FRegClasses[I].ClassType.ClassParent.GetInterfaceTable;
end;
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;
end;
end;
注意这里：
FRegClasses: array of InvRegClassEntry;
到注册类的动态数组中去搜寻接口的实现类是否注册，如果注册，便把实现类的指针拷贝到DefImpl数据字段。
顺便看一下类是怎么注册的：
procedure TInvokableClassRegistry.RegisterInvokableClass(AClass: TClass; CreateProc: TCreateInstanceProc);
var
Index, I, J: Integer;
Table: PInterfaceTable;
begin
Lock;
try
Table := AClass.GetInterfaceTable;
。。。。。。
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
if FRegIntfs[J].DefImpl = nil then
FRegIntfs[J].DefImpl := AClass;
end;
finally
UnLock;
end;
end;
可以看到和注册接口非常相似。在调用上面方法时，会传入实现类的指针及factory函数指针，调用GetInterfaceTable判断是否实现接口。否则为NIL， 然后在FregClasses增加一元素，把值写入。最后再到FregIntfs是搜寻此实现类的接口是否已经注册。是的话，就把指针储存在FRegIntfs[J].DefImpl中。
继续：
InvRegistry.RegisterDefaultSOAPAction(TypeInfo(IMyFirstWS), 'urn:MyFirstWSIntf-IMyFirstWS#%operationName%');
procedure TInvokableClassRegistry.RegisterDefaultSOAPAction(Info: PTypeInfo; const DefSOAPAction: InvString);
var
I: Integer;
begin
I := GetIntfIndex(Info);
if I >= 0 then
begin
FRegIntfs[I].SOAPAction := DefSOAPAction;
//值为：urn:MyFirstWSIntf-IMyFirstWS#%operationName
FRegIntfs[I].InvokeOptions := FRegIntfs[I].InvokeOptions + [ioHasDefaultSOAPAction];
Exit;
end;
end;
设置接口的SOAPAction, 及InvokeOptions属性。
上面讲了用户接口及自定义类注册的实现。
看看这几句为何如此神奇，竟然可以实现对象的远程调用？
MyHTTPRIO := THTTPRIO.Create(nil);
MyHTTPRIO.URL :='http://localhost/soap/MyCGI.exe/soap/IMyFirstWS';
ShowMessage(( MyHTTPRIO As IMyFirstWS ).GetObj);
研究一下客户端代码：
constructor THTTPRIO.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ Converter }
FDomConverter := GetDefaultConverter;
FConverter := FDomConverter as IOPConvert;
{ WebNode }
FHTTPWebNode := GetDefaultWebNode;
FWebNode := FHTTPWebNode as IWebNode;
end;
继续到父类中TRIO查看相应代码：
constructor TRIO.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FInterfaceBound := False;
FContext := TInvContext.Create;
FSOAPHeaders := TSOAPHeaders.Create(Self);
FHeadersInbound := THeaderList.Create;
FHeadersOutBound:= THeaderList.Create;
FHeadersOutbound.OwnsObjects := False;
(FSOAPHeaders as IHeadersSetter).SetHeadersInOut(FHeadersInbound, FHeadersOutBound);
end;
创建了TinvContext，这个对象是用来创建一个和服务器端一样的调用环境。
客户端的参数信息一个个的填入这个环境中。
创建一个TSOAPHeaders头对象。
回到
constructor THTTPRIO.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ Converter }
FDomConverter := GetDefaultConverter;
FConverter := FDomConverter as IOPConvert;
{ WebNode }
FHTTPWebNode := GetDefaultWebNode;
FWebNode := FHTTPWebNode as IWebNode;
end;
function THTTPRIO.GetDefaultConverter: TOPToSoapDomConvert;
begin
if (FDefaultConverter = nil) then
begin
FDefaultConverter := TOPToSoapDomConvert.Create(Self);
FDefaultConverter.Name := 'Converter1'; { do not localize }
FDefaultConverter.SetSubComponent(True);
end;
Result := FDefaultConverter;
end;
而TOPToSoapDomConvert可以把Object Pascal的呼叫和參數自動轉換為SOAP封裝的格式資訊，再藉由THTTPReqResp傳送HTTP封包。
function THTTPRIO.GetDefaultWebNode: THTTPReqResp;
begin
if (FDefaultWebNode = nil) then
begin
FDefaultWebNode := THTTPReqResp.Create(Self);
FDefaultWebNode.Name := 'HTTPWebNode1'; { do not localize }
FDefaultWebNode.SetSubComponent(True);
end;
Result := FDefaultWebNode;
end;
//用来传送HTTP的封包。
function THTTPRIO.GetDefaultConverter: TOPToSoapDomConvert;
begin
if (FDefaultConverter = nil) then
begin
FDefaultConverter := TOPToSoapDomConvert.Create(Self);
FDefaultConverter.Name := 'Converter1'; { do not localize }
FDefaultConverter.SetSubComponent(True);
end;
Result := FDefaultConverter;
end;
FHTTPWebNode := GetDefaultWebNode;
function THTTPRIO.GetDefaultWebNode: THTTPReqResp;
begin
if (FDefaultWebNode = nil) then
begin
FDefaultWebNode := THTTPReqResp.Create(Self);
FDefaultWebNode.Name := 'HTTPWebNode1'; { do not localize }
FDefaultWebNode.SetSubComponent(True);
end;
Result := FDefaultWebNode;
end;
创建了一个THTTPReqResp，用于HTTP通信。
MyHTTPRIO.URL :='http://localhost/soap/MyCGI.exe/soap/IMyFirstWS';
procedure THTTPRIO.SetURL(Value: string);
begin
if Assigned(FHTTPWebNode) then
begin
FHTTPWebNode.URL := Value;
if Value <> '' then
begin
WSDLLocation := '';
ClearDependentWSDLView;
end;
end;
end;
procedure THTTPReqResp.SetURL(const Value: string);
begin
if Value <> '' then
FUserSetURL := True
else
FUserSetURL := False;
InitURL(Value);
Connect(False);
end;
procedure THTTPReqResp.InitURL(const Value: string);
InternetCrackUrl(P, 0, 0, URLComp);
FURLScheme := URLComp.nScheme;
FURLPort := URLComp.nPort;
FURLHost := Copy(Value, URLComp.lpszHostName - P + 1, URLComp.dwHostNameLength);
FURL := Value;
end;
设置THTTPReqResp的属性。和HTTP服务器通信。
procedure THTTPReqResp.Connect(Value: Boolean);
if Assigned(FInetConnect) then
InternetCloseHandle(FInetConnect);
FInetConnect := nil;
if Assigned(FInetRoot) then
InternetCloseHandle(FInetRoot);
FInetRoot := nil;
FConnected := False;
Value 为FLASE。
ShowMessage(( MyHTTPRIO As IMyFirstWS ).GetObj);
利用AS转换成webservice的接口。用转换后的接口到客户端的InvRegInftEntry表格中搜寻WEBSERVICE服务接口，根据RTTL生成SOAP封包。
procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID);
先看这一句：CALL DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface
function THTTPRIO.QueryInterface(const IID: TGUID; out Obj): HResult;
var
UDDIOperator, UDDIBindingKey: string;
begin
Result := inherited QueryInterface(IID, Obj);
if Result = 0 then
begin
if IsEqualGUID(IID, FIID) then
begin
FHTTPWebNode.SoapAction := InvRegistry.GetActionURIOfIID(IID);
if InvRegistry.GetUDDIInfo(IID, UDDIOperator, UDDIBindingKey) then
begin
FHTTPWebNode.UDDIOperator := UDDIOperator;
FHTTPWebNode.UDDIBindingKey := UDDIBindingKey;
end;
end;
end;
end;
Result := inherited QueryInterface(IID, Obj);//跟踪一下这一句：
这句比较重要，要重点分析。
这里创建了虚拟表格。
function TRIO.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
Result := E_NOINTERFACE;
{ IInterface, IRIOAccess } //判断接口是不是IRIOAccess类型
if IsEqualGUID(IID, IInterface) or IsEqualGUID(IID, IRIOAccess) then
{ ISOAPHeaders }//判断接口是不是ISOAPHeaders类型
if IsEqualGUID(IID, ISOAPHeaders) then
…
if GenVTable(IID) then
begin
Result := 0;
FInterfaceBound := True;
Pointer(Obj) := IntfTableP;
InterlockedIncrement(FRefCount);
end;
看看GenVTable函数：
function TRIO.GenVTable(const IID: TGUID): Boolean;
Info := InvRegistry.GetInterfaceTypeInfo(IID);
这个函数是去到TinvokableClassRegistry中搜寻该接口是否注册，注册过的接口则返回typeinfo信息赋给指针。
function TInvokableClassRegistry.GetInterfaceTypeInfo(const AGUID: TGUID): Pointer;
var
I: Integer;
begin
Result := nil;
Lock;
try
for I := 0 to Length(FRegIntfs) - 1 do
begin
if IsEqualGUID(AGUID, FRegIntfs[I].GUID) then
begin
Result := FRegIntfs[I].Info;
Exit;
end;
end;
finally
UnLock;
end;
end;
继续：通过infotype得到RTTL信息。
try
GetIntfMetaData(Info, IntfMD, True);
except
HasRTTI := False;
Exit;
end;
{
TProc = procedure of object;
TObjFunc = function: Integer of Object; stdcall;
TQIFunc = function(const IID: TGUID; out Obj): HResult of object; stdcall;
PProc = ^TProc;
TCracker = record
case integer of
0: (Fn: TProc);
1: (Ptr: Pointer);
2: (ObjFn: TObjFunc);
3: (QIFn: TQIFunc);
end;}
Crack.Fn := GenericStub;
StubAddr := Crack.Ptr;
地址指向函数TRIO.GenericStub函数。
Crack.Fn结构的指针指向
这段代码的意思是用C/stdcall等方式调用函数。
从左到右，从右到左压入堆栈。调整TRIO.IntfTable的指针,最后调用TRIO.Generic
procedure TRIO.GenericStub;
asm
POP EAX { Return address in runtime generated stub }
POP EDX { Is there a pointer to return structure on stack and which CC is used? }
CMP EDX, 2
JZ @@RETONSTACKRL
CMP EDX, 1
JZ @@RETONSTACKLR
POP EDX { Method # pushed by stub }
PUSH EAX { Push back return address }
LEA ECX, [ESP+12] { Calc stack pointer to start of params }
MOV EAX, [ESP+8] { Calc interface instance ptr }
JMP @@CONT
@@RETONSTACKLR:
POP EDX { Method # pushed by stub }
PUSH EAX { Push back return address }
LEA ECX, [ESP+12] { Calc stack pointer to start of params }
MOV EAX, [ESP+8] { Calc interface instance ptr }
JMP @@CONT
@@RETONSTACKRL:
POP EDX { Method # pushed by stub }
PUSH EAX { Push back return address }
LEA ECX, [ESP+8] { Calc stack pointer to start of params }
MOV EAX, [ESP+12] { calc interface instance ptr }
@@CONT:
SUB EAX, OFFSET TRIO.IntfTable; { Adjust intf pointer to object pointer }
JMP TRIO.Generic
end;
Crack.Fn := ErrorEntry;
ErrorStubAddr := Crack.Ptr;
//首先分配vtable空间，接口数加3， 因为有Iunknown接口。
GetMem(IntfTable, (Length(IntfMD.MDA) + NumEntriesInIInterface) * 4);
IntfTableP := @IntfTable;
然后把地址赋给IntfTableP变量
GetMem(IntfStubs, (Length( IntfMD.MDA) + NumEntriesInIInterface) * StubSize );
分配存根接口空间。
这是解释
IntfTable: Pointer; { Generated vtable for the object }
IntfTableP: Pointer; { Pointer to the generated vtable }
IntfStubs: Pointer; { Pointer to generated vtable thunks}
//Load the IUnknown vtable 分配指针，加入三个接口Iunknown
VTable := PPointer(IntfTable);
Crack.QIFn := _QIFromIntf;
QI查询指针赋值给 Crack结构体
VTable^ := Crack.Ptr; 赋给VT指针
IncPtr(VTable, 4); 增加一个指针。
Crack.ObjFn := _AddRefFromIntf;
VTable^ := Crack.Ptr;
IncPtr(VTable, 4);
Crack.ObjFn := _ReleaseFromIntf;
VTable^ := Crack.Ptr;
IncPtr(VTable, 4);
VTable := AddPtr(IntfTable, NumEntriesInIInterface * 4);
//增加IunKnown指针的三个方法。压入IntfTable中。
Thunk := AddPtr(IntfStubs, NumEntriesInIInterface * StubSize);
//调整Thunk，加入IunKnown接口方法。
//遍历所有方法：产生机器相应的汇编机器代码。
for I := NumEntriesInIInterface to Length(IntfMD.MDA) - 1 do
begin
CallStubIdx := 0;
if not IntfMD.MDA[I].HasRTTI then
begin
GenByte($FF); { FF15xxxxxxxx Call [mem] }
GenByte($15);
Crack.Fn := ErrorEntry;
GenDWORD(LongWord(@ErrorStubAddr));
end else
begin
{ PUSH the method ID }
GenPushI(I);
//定位这里：看看函数做了什么：
CallStub: array[0..StubSize-1] of Byte;
I=3。CallStubIdx=2
procedure TRIO.GenPushI(I: Integer);
begin
if I < 128 then
begin
CallStub[CallStubIdx] := $6A;
CallStub[CallStubIdx + 1] := I;
Inc(CallStubIdx, 2);
end
else
begin
CallStub[CallStubIdx] := $68;
PInteger(@CallStub[CallStubIdx + 1])^ := I;
Inc(CallStubIdx, 5);
end;
end;
登记函数调用信息, 数组增加一元素。
遍历接口信息，函数ID号压入堆栈中。
{ PUSH the info about return value location }
if RetOnStack(IntfMD.MDA[I].ResultInfo) then
begin
if IntfMD.MDA[I].CC in [ccStdcall, ccCdecl] then
GenPushI(2)
else
GenPushI(1);
end
else
GenPushI(0);
把返回值压入堆栈中。//把返回参数压入堆栈。
接着把GenericStub压入堆栈中。
{ Generate the CALL [mem] to the generic stub }
GenByte($FF); { FF15xxxxxxxx Call [mem] }
GenByte($15);
GenDWORD(LongWord(@StubAddr));
这几句是生成汇编的代码。可以产生这样的调用：
ff15xxxxxx:地址： caa [mem]编号: //这里调用的。
//看看里面的内容是什么：
{ Generate the return sequence }
if IntfMD.MDA[I].CC in [ccCdecl] then
begin
{ For cdecl calling convention, the caller will do the cleanup, so }
{ we convert to a regular ret. }
GenRet;
end
else
begin
BytesPushed := 0;
for J := 0 to IntfMD.MDA[I].ParamCount - 1 do
begin
if IsParamByRef(IntfMD.MDA[I].Params[J].Flags, IntfMD.MDA[I].Params[J].Info, IntfMD.MDA[I].CC) then
Inc(BytesPushed, 4)
else
Inc(BytesPushed, GetStackTypeSize(IntfMD.MDA[I].Params[J].Info, IntfMD.MDA[I].CC ));
//每个参数分配空间。
end;
Inc(BytesPushed, GetStackTypeSize(IntfMD.MDA[I].SelfInfo, IntfMD.MDA[I].CC ));
//压入函数本身信息：
{ TODO: Investigate why not always 4 ?? }
if RetOnStack(IntfMD.MDA[I].ResultInfo) or (IntfMD.MDA[I].CC = ccSafeCall) then
Inc(BytesPushed, 4);
if BytesPushed > 252 then
raise Exception.CreateFmt(STooManyParameters, [IntfMD.MDA[I].Name]);
GenRET(BytesPushed);
end;
end;
//GenRET(BytesPushed); 分配函数参数空间。
{ Copy as much of the stub that we initialized over to the }
{ block of memory we allocated. }
P := PByte(Thunk);
for J := 0 to CallStubIdx - 1 do
begin
P^ := CallStub[J];
IncPtr(P);
end;
Thunk的指针，指向汇编代码相应的调用信息：
{ And then fill the remainder with INT 3 instructions for }
{ cleanliness and safety. If we do the allocated more smartly, we }
{ can remove all the wasted space, except for maybe alignment. }
for J := CallStubIdx to StubSize - 1 do
begin
P^ := $CC;
IncPtr(P);
end;
增加Thunk指向存根相应调用信息：
{ Finally, put the new thunk entry into the vtable slot. }
VTable^ := Thunk;
IncPtr(VTable, 4);
把thunk指针赋给vtable之后，压入堆栈。
IncPtr(Thunk, StubSize);
把存根相应调用信息压入堆栈。
然后继续下一个函数的相应操作。
end;
end;
procedure IncPtr(var P; I: Integer = 1);
asm
ADD [EAX], EDX
end;
总结一下GenVTable函数，这个函数，根据注册的接口，生成了内存表格。
首先遍历整个动态数组，然后，得到接口的RTTL信息，随后把Tcracker结构内存入相应的调用信息。然后再分配两块内存，一块放接口信息，一块放存根调用信息，再把接口内存的指针赋给TRIO的IntfTableP变量。IntfStubs存放存根指针IntfTable指接口信息后，又加入了Iunknown的指针空间。最近遍历接口函数，把函数信息写入CallStub数组之后（生成机器代码），再填入堆栈之中。
继续：
THTTPRIO.QueryInterface
TInvokableClassRegistry.GetActionURIOfInfo
if InvRegistry.GetUDDIInfo(IID, UDDIOperator, UDDIBindingKey) then
调用之后：
function TInvokableClassRegistry.GetUDDIInfo(const IntfInfo: PTypeInfo; var Operator, BindingKey: string): Boolean;
返回
procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID);
这里，继续：
procedure TRIO.GenericStub;
JMP TRIO.Generic
//这里是最重要的地方：这个函数完成了。打包，传递，并返回服务器端结果。我们仔细研究一下。
function TRIO.Generic(CallID: Integer; Params: Pointer): Int64;
。。。。
MethMD := IntfMD.MDA[CallID]; //得到方法相应的属性。
FContext.SetMethodInfo(MethMD); // FContext 产生虚拟的表函数表格。
procedure TInvContext.SetMethodInfo(const MD: TIntfMethEntry);
begin
SetLength(DataP, MD.ParamCount + 1);
SetLength(Data, (MD.ParamCount + 1) * MAXINLINESIZE);
end;
if MethMd.CC <> ccSafeCall then
begin
if RetOnStack(MethMD.ResultInfo) then
begin
RetP := Pointer(PInteger(P)^);
if MethMD.ResultInfo.Kind = tkVariant then
IncPtr(P, sizeof(Pointer))
else
IncPtr(P, GetStackTypeSize(MethMD.ResultInfo, MethMD.CC));
if MethMD.CC in [ccCdecl, ccStdCall] then
begin
IncPtr(P, sizeof(Pointer)); { Step over self }
end;
end else
RetP := @Result;
FContext.SetResultPointer(RetP);
end;
//把相应的返回信息压入Fcontext中。
for J := 0 to MethMD.ParamCount - 1 do
begin
FContext.SetParamPointer(ParamIdx, P);
with MethMD.Params[J] do
begin
if (Info.Kind = tkVariant) and
(MethMD.CC in [ccCdecl, ccStdCall, ccSafeCall]) and
not (pfVar in Flags) and
not (pfOut in Flags) then
begin
IncPtr(P, sizeof(TVarData)); { NOTE: better would be to dword-align!! }
end
else if IsParamByRef(Flags, Info, MethMD.CC) then
IncPtr(P, 4)
else
IncPtr(P, GetStackTypeSize(Info, MethMD.CC));
end;
Inc(ParamIdx, LeftRightOrder);
end;
//把相应的参数压入Fcontext中。
//转换成XML封包，并写入流中，这里就是具体打包的地方：
大家看清楚了：
Req := FConverter.InvContextToMsg(IntfMD, MethNum, FContext, FHeadersOutBound);
现在来好好研究一下它是怎么转换成XML封包的。
function TOPToSoapDomConvert.InvContextToMsg(const IntfMD: TIntfMetaData; MethNum: Integer;
Con: TInvContext; Headers: THeaderList): TStream;
MethMD := IntfMD.MDA[MethNum];
首先得到方法的动态信息。
XMLDoc := NewXMLDocument; 看看这句：
function TOPToSoapDomConvert.NewXMLDocument: IXMLDocument;
begin
Result := XMLDoc.NewXMLDocument;
Result.Options := Result.Options + [doNodeAutoIndent];
Result.ParseOptions := Result.ParseOptions + [poPreserveWhiteSpace];
end;
function NewXMLDocument(Version: DOMString = '1.0'): IXMLDocument;
begin
Result := TXMLDocument.Create(nil);
Result.Active := True;
if Version <> '' then
Result.Version := Version;
end;
创建了一个TXMLDocument对象用于读写XML。
procedure TXMLDocument.SetActive(const Value: Boolean);
begin
。。。。
CheckDOM;
FDOMDocument := DOMImplementation.createDocument('', '', nil);
try
LoadData;
except
ReleaseDoc(False);
raise;
end;
DoAfterOpen;
end
else
begin
DoBeforeClose;
ReleaseDoc;
DoAfterClose;
end;
end;
end;
浙公网安备 33010602011771号