远程调用技术代码追踪(webservice)

阿尔萨斯

浏览: 4143678 次

最近访客更多访客>>

snower_tt

iams13

u012363178

wangyy

博主相关

博客

微博

相册

留言

关于我

文章分类

社区版块

存档分类

2014-10 ( 581)
2014-09 ( 572)
2014-08 ( 545)
更多存档...

最近阅读了SocketConn的源码和WebService 的源码，把追踪的过程写了下来，方便大家学习。毕竟这需要精力，时间和毅力。感谢煮茶待英雄博志区和三层数据库讨论区兄弟们的支持，特别是julian兄弟，不是他，我可能没耐心继续下去。如果有时间，大家可以继续完善。从socket和Websevice的底层实现细节，我们发现BORLAND的工程师们的构思和实现的过程。我觉得这对我们的学习应该是非常重要的。学会思考。学会读源码，学会分析。

希望和我交往的朋友可通过QQ或Email联系我。Wu_yanan2003@yahoo.com.cn

另见：《远程调用技术代码追踪(socket) 》

关注我的：《远程调用技术代码追踪(第三方控件) 》

远程调用技术内幕

有关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;

看研究一下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

begin

if (Info nil) and (URIMap[Result].Info = Info) then

begin

if (Name = '') or (URIMap[Result].Name = Name) then

begin

Found := True;

Exit;

end;

Inc(Result);

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;

前面都是说系统类型的注册。下面看看我们自己定义的接口，是如何注册的：

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;

finally

Unlock;

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;

注意这里：

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;

可以看到和注册接口非常相似。在调用上面方法时，会传入实现类的指针及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;

设置接口的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;

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;

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;

finally

UnLock;

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

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;

登记函数调用信息, 数组增加一元素。

遍历接口信息，函数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;

//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;

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中。

forJ := 0 toMethMD.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;

procedure TXMLDocument.CheckDOM;

begin

if not Assigned(FDOMImplementation) then

if Assigned(FDOMVendor) then

FDOMImplementation := FDOMVendor.DOMImplementation

else

FDOMImplementation := GetDOM(DefaultDOMVendor);

end;

在TXMLDocument内部使用了Abstract Factory模式

Abstract Factory希望不用指定具体的类，但为了找到它们，在TXMLDocument是通过指定一个字符串，也就是我们点击DOMVendor时出现的哪几个字符串．

GetDOM函数如下：

Result := GetDOMVendor(VendorDesc).DOMImplementation;

//根据传递进去的名字，创建相应在的实例：

function GetDOMVendor(VendorDesc: string): TDOMVendor;

begin

if VendorDesc = '' then

VendorDesc := DefaultDOMVendor;

if (VendorDesc = '') and (DOMVendorList.Count > 0) then

Result := DOMVendorList[0]

else

Result := DOMVendorList.Find(VendorDesc);

if not Assigned(Result) then

raise Exception.CreateFmt(SNoMatchingDOMVendor, [VendorDesc]);

end;

最后取得一个IDOMImplementation，它有一个createDocument（….）:IDOMDocument;函数，这个函数将返回一个IDOMDocument;接口让IXMLDoucment使用。

//由此可见，默认状态下是创建DOM，微软的XML解析器。

function DOMVendorList: TDOMVendorList;

begin

if not Assigned(DOMVendors) then

DOMVendors := TDOMVendorList.Create;

Result := DOMVendors;

end;

function TDOMVendorList.GetVendors(Index: Integer): TDOMVendor;

begin

Result := FVendors[Index];

end;

如果为空，就返回默认的。

function TMSDOMImplementationFactory.DOMImplementation: IDOMImplementation;

begin

Result := TMSDOMImplementation.Create(nil);

end;

再返回到函数：

procedure TXMLDocument.SetActive(const Value: Boolean);

FDOMDocument := DOMImplementation.createDocument('', '', nil);

继续：

function TMSDOMImplementation.createDocument(const namespaceURI,

qualifiedName: DOMString; doctype: IDOMDocumentType): IDOMDocument;

begin

Result := TMSDOMDocument.Create(MSXMLDOMDocumentCreate);

end;

在如果使用MSXML,接口对应的是TMSDOMDocument，TMSDOMDocument是实际上是调用MSXML技术，下面是调用MS COM的代码

function CreateDOMDocument: IXMLDOMDocument;

begin

Result := TryObjectCreate([CLASS_DOMDocument40, CLASS_DOMDocument30,

CLASS_DOMDocument26, msxml.CLASS_DOMDocument]) as IXMLDOMDocument;

if not Assigned(Result) then

raise DOMException.Create(SMSDOMNotInstalled);

end;

再返回到函数：

procedure TXMLDocument.SetActive(const Value: Boolean);

LoadData

//因为是新建的TXMLDocument，所以装内空数据,立即返回。

procedure TXMLDocument.LoadData;

const

UnicodeEncodings: array[0..2] of string = ('UTF-16', 'UCS-2', 'UNICODE');

var

Status: Boolean;

ParseError: IDOMParseError;

StringStream: TStringStream;

Msg: string;

begin

…

Status := True; { No load, just create empty doc. }

创建空的文档：

if not Status then

begin

DocSource := xdsNone;

ParseError := DOMDocument as IDOMParseError;

with ParseError do

Msg := Format('%s%s%s: %d%s%s', [Reason, SLineBreak, SLine,

Line, SLineBreak, Copy(SrcText, 1, 40)]);

raise EDOMParseError.Create(ParseError, Msg);

end;

SetModified(False);

end;

设置不能修改。因为空文档。

继续返回到

function NewXMLDocument(Version: DOMString = '1.0'): IXMLDocument;

begin

if Version '' then

Result.Version := Version;

end;

procedure TXMLDocument.SetVersion(const Value: DOMString);

begin

SetPrologValue(Value, xpVersion);

end;

procedure TXMLDocument.SetPrologValue(const Value: Variant;

….

PrologNode := GetPrologNode;

PrologAttrs := InternalSetPrologValue(PrologNode, Value, PrologItem);

NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);

if Assigned(PrologNode) then

Node.ChildNodes.ReplaceNode(PrologNode, NewPrologNode)

else

ChildNodes.Insert(0, NewPrologNode);

end;

NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);

这句调用了：

function TXMLDocument.CreateNode(const NameOrData: DOMString;

NodeType: TNodeType = ntElement; const AddlData: DOMString = ''): IXMLNode;

begin

Result := TXMLNode.Create(CreateDOMNode(FDOMDocument, NameOrData,

NodeType, AddlData), nil, Self);

end;

在返回到这个函数中：

function TOPToSoapDomConvert.InvContextToMsg(const IntfMD: TIntfMetaData; MethNum: Integer;

Con: TInvContext; Headers: THeaderList): TStream;

BodyNode := Envelope.MakeBody(EnvNode);

if not (soLiteralParams in Options) then

begin

SoapMethNS := GetSoapNS(IntfMD);

ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name)；

;;;;;

//创建一个SOAP的body:

function TSoapEnvelope.MakeBody(ParentNode: IXMLNode): IXMLNode;

begin

Result := ParentNode.AddChild(SSoapNameSpacePre + ':' + SSoapBody, SSoapNameSpace);

end;

SoapMethNS := GetSoapNS(IntfMD);返回：'urn:MyFirstWSIntf-IMyFirstWS'

ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);

得到调用方法名。剩下的部分就是把参数打包。生成SOAP的源文件。然后写到内存流中。

再回到函数中：InvContextToMsg

Result := TMemoryStream.Create();

DOMToStream(XMLDoc, Result);

把内存块的数据，转化成XML。

具体的函数如下：

procedure TOPToSoapDomConvert.DOMToStream(const XMLDoc: IXMLDocument; Stream: TStream);

var

XMLWString: WideString;

StrStr: TStringStream;

begin

if (FEncoding = '') or (soUTF8EncodeXML in Options) then

begin

XMLDoc.SaveToXML(XMLWString);

StrStr := TStringStream.Create(UTF8Encode(XMLWString));

try

Stream.CopyFrom(StrStr, 0);

finally

StrStr.Free;

end;

end else

XMLDoc.SaveToStream(Stream);

end;

我们跟踪之后StrStr的结果如下：

'<?xml version="1.0"?>'#$D#$A'<envelope xmlns:soap-env="http://schemas.xmlsoap.org/soap/envelope/" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:soap-enc="http://schemas.xmlsoap.org/soap/encoding/">'#$D#$A''#$D#$A'<span> <getobj xmlns:ns1="urn:MyFirstWSIntf-IMyFirstWS">'#$D#$A' <a xsi:type="xsd:int">3</a>'#$D#$A' <b xsi:type="xsd:int">4</b>'#$D#$A' </getobj>'#$D#$A'</span> '#$D#$A'</envelope>'#$D#$A

转化后继续调用Generic函数：

。。。。

FWebNode.BeforeExecute(IntfMD, MethMD, MethNum-3, nil);

if (BindingType = btMIME) then

begin

。。。

FWebNode.BeforeExecute(IntfMD, MethMD, MethNum-3, nil);

THTTPReqResp.BeforeExecute

。。。。。

MethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);

FSoapAction := InvRegistry.GetActionURIOfInfo(IntfMD.Info, MethName, MethodIndex);

得到方法名和FsoapAction

FBindingType := btSOAP

DoBeforeExecute// TRIO.

if Assigned(FOnBeforeExecute) then

退出：

继续：

Resp := GetResponseStream(RespBindingType);

继续返回到TRIO.Generic函数中执行：

try

FWebNode.Execute(Req, Resp);

比较重要的部分：

这个函数就是THTTPReqResp向IIS发出请求。并返回信息：

procedure THTTPReqResp.Execute(const Request: TStream; Response: TStream);

begin

…

Context := Send(Request);

try

Receive(Context, Response);

Exit;

except

on Ex: ESOAPHTTPException do

begin

Connect(False);

if not CanRetry or not IsErrorStatusCode(Ex.StatusCode) then

raise;

{ Trigger UDDI Lookup }

LookUpUDDI := True;

PrevError := Ex.Message;

end;

else

begin

Connect(False);

raise;

end;

finally

if Context 0then

InternetCloseHandle(Pointer(Context));

end;

{$ENDIF}

end;

现在看看Send函数，看看到底如何发送数据给WEB服务器的。

function THTTPReqResp.Send(const ASrc: TStream): Integer;

var

Request: HINTERNET;

RetVal, Flags: DWord;

P: Pointer;

ActionHeader: string;

ContentHeader: string;

BuffSize, Len: Integer;

INBuffer: INTERNET_BUFFERS;

Buffer: TMemoryStream;

StrStr: TStringStream;

begin

{ Connect }

Connect(True);

Flags := INTERNET_FLAG_KEEP_CONNECTION or INTERNET_FLAG_NO_CACHE_WRITE;

if FURLScheme = INTERNET_SCHEME_HTTPS then

begin

Flags := Flags or INTERNET_FLAG_SECURE;

if (soIgnoreInvalidCerts in InvokeOptions) then

Flags := Flags or (INTERNET_FLAG_IGNORE_CERT_CN_INVALID or

INTERNET_FLAG_IGNORE_CERT_DATE_INVALID);

end;

Request := nil;

try

Request := HttpOpenRequest(FInetConnect, 'POST', PChar(FURLSite), nil,

nil, nil, Flags, 0{Integer(Self)});

Check(not Assigned(Request));

{ Timeouts }

if FConnectTimeout > 0 then

Check(InternetSetOption(Request, INTERNET_OPTION_CONNECT_TIMEOUT, Pointer(@FConnectTimeout), SizeOf(FConnectTimeout)));

if FSendTimeout > 0 then

Check(InternetSetOption(Request, INTERNET_OPTION_SEND_TIMEOUT, Pointer(@FSendTimeout), SizeOf(FSendTimeout)));

if FReceiveTimeout > 0 then

Check(InternetSetOption(Request, INTERNET_OPTION_RECEIVE_TIMEOUT, Pointer(@FReceiveTimeout), SizeOf(FReceiveTimeout)));

{ Setup packet based on Content-Type/Binding }

if FBindingType = btMIME then

begin

ContentHeader := Format(ContentHeaderMIME, [FMimeBoundary]);

ContentHeader := Format(ContentTypeTemplate, [ContentHeader]);

HttpAddRequestHeaders(Request, PChar(MIMEVersion), Length(MIMEVersion), HTTP_ADDREQ_FLAG_ADD);

{ SOAPAction header }

{ NOTE: It's not really clear whether this should be sent in the case

of MIME Binding. Investigate interoperability ?? }

if not (soNoSOAPActionHeader in FInvokeOptions) then

begin

ActionHeader:= GetSOAPActionHeader;

HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);

end;

end else { Assume btSOAP }

begin

{ SOAPAction header }

if not (soNoSOAPActionHeader in FInvokeOptions) then

begin

ActionHeader:= GetSOAPActionHeader;

HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);

end;

if UseUTF8InHeader then

ContentHeader := Format(ContentTypeTemplate, [ContentTypeUTF8])

else

ContentHeader := Format(ContentTypeTemplate, [ContentTypeNoUTF8]);

end;

{ Content-Type }

HttpAddRequestHeaders(Request, PChar(ContentHeader), Length(ContentHeader), HTTP_ADDREQ_FLAG_ADD);

{ Before we pump data, see if user wants to handle something - like set Basic-Auth data?? }

if Assigned(FOnBeforePost) then

FOnBeforePost(Self, Request);

ASrc.Position := 0;

BuffSize := ASrc.Size;

if BuffSize > FMaxSinglePostSize then

begin

Buffer := TMemoryStream.Create;

try

Buffer.SetSize(FMaxSinglePostSize);

{ Init Input Buffer }

INBuffer.dwStructSize := SizeOf(INBuffer);

INBuffer.Next := nil;

INBuffer.lpcszHeader := nil;

INBuffer.dwHeadersLength := 0;

INBuffer.dwHeadersTotal := 0;

INBuffer.lpvBuffer := nil;

INBuffer.dwBufferLength := 0;

INBuffer.dwBufferTotal := BuffSize;

INBuffer.dwOffsetLow := 0;

INBuffer.dwOffsetHigh := 0;

{ Start POST }

Check(not HttpSendRequestEx(Request, @INBuffer, nil,

HSR_INITIATE or HSR_SYNC, 0));

try

while True do

begin

{ Calc length of data to send }

Len := BuffSize - ASrc.Position;

if Len > FMaxSinglePostSize then

Len := FMaxSinglePostSize;

{ Bail out if zip.. }

if Len = 0 then

break;

{ Read data in buffer and write out}

Len := ASrc.Read(Buffer.Memory^, Len);

if Len = 0 then

raise ESOAPHTTPException.Create(SInvalidHTTPRequest);

Check(not InternetWriteFile(Request, @Buffer.Memory^, Len, RetVal));

RetVal := InternetErrorDlg(GetDesktopWindow(), Request, GetLastError,

FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or

FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, P);

case RetVal of

ERROR_SUCCESS: ;

ERROR_CANCELLED: SysUtils.Abort;

ERROR_INTERNET_FORCE_RETRY: {Retry the operation};

end;

{ Posting Data Event }

if Assigned(FOnPostingData) then

FOnPostingData(ASrc.Position, BuffSize);

end;

finally

Check(not HttpEndRequest(Request, nil, 0, 0));

end;

finally

Buffer.Free;

end;

end else

begin

StrStr := TStringStream.Create('');

try

StrStr.CopyFrom(ASrc, 0);

while True do

begin

Check(not HttpSendRequest(Request, nil, 0, @StrStr.DataString[1], Length(StrStr.DataString)));

RetVal := InternetErrorDlg(GetDesktopWindow(), Request, GetLastError,

FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or

FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, P);

case RetVal of

ERROR_SUCCESS: break;

ERROR_CANCELLED: SysUtils.Abort;

ERROR_INTERNET_FORCE_RETRY: {Retry the operation};

end;

finally

StrStr.Free;

end;

except

if (Request nil) then

InternetCloseHandle(Request);

Connect(False);

raise;

end;

Result := Integer(Request);

end;

function THTTPReqResp.Send(const ASrc: TStream): Integer;

先调用了：

procedure THTTPReqResp.Connect(Value: Boolean);

……

if InternetAttemptConnect(0) ERROR_SUCCESS then

SysUtils.Abort;

这个函数可以说非常简单，只是尝试计算机连接到网络。

FInetRoot := InternetOpen(PChar(FAgent), AccessType, PChar(FProxy), PChar(FProxyByPass), 0);

创建HINTERNET句柄，并初始化WinInet的API函数：

Check(not Assigned(FInetRoot));

try

FInetConnect := InternetConnect(FInetRoot, PChar(FURLHost), FURLPort, PChar(FUserName),

PChar(FPassword), INTERNET_SERVICE_HTTP, 0, Cardinal(Self));

//创建一个特定的会话：

Check(not Assigned(FInetConnect));

FConnected := True;

except

InternetCloseHandle(FInetRoot);

FInetRoot := nil;

raise;

end;

这里已经创建了一个会话：

继续返回function THTTPReqResp.Send(const ASrc: TStream): Integer;函数之中：

。。。。

Request := HttpOpenRequest(FInetConnect, 'POST', PChar(FURLSite), nil,

nil, nil, Flags, 0{Integer(Self)});

Check(not Assigned(Request));。

打开一个HTTP的请求。向WEB服务器提出请求：

。。

if not (soNoSOAPActionHeader in FInvokeOptions) then

begin

ActionHeader:= GetSOAPActionHeader;

HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);

end;

。。。

为请求添加一个或多个标头。可以看到标点的信息为：

'SOAPAction: "urn:MyFirstWSIntf-IMyFirstWS#GetObj"'

HttpAddRequestHeaders(Request, PChar(ContentHeader), Length(ContentHeader), HTTP_ADDREQ_FLAG_ADD);

继续加入标头'Content-Type: text/xml'信息：

StrStr := TStringStream.Create('');

try

StrStr.CopyFrom(ASrc, 0);

while True do

begin

Check(not HttpSendRequest(Request, nil, 0, @StrStr.DataString[1], Length(StrStr.DataString)));

建立到internet 的连接，并将请求发送到指定的站点。

这句执行完后的图如下（用工具跟踪的结果）：

看看前面的soap生成的字符 StrStr的结果如下，发现后半部分是一样的。

继续

function THTTPReqResp.Execute(const Request: TStream): TStream;

Receive(Context, Response);

procedureTHTTPReqResp.Receive(Context: Integer; Resp: TStream; IsGet: Boolean);

var

Size, Downloaded, Status, Len, Index: DWord;

S: string;

begin

//获取请求信息：

HttpQueryInfo(Pointer(Context), HTTP_QUERY_CONTENT_TYPE, @FContentType[1], Size, Index);

repeat

Check(not InternetQueryDataAvailable(Pointer(Context), Size, 0, 0));

if Size > 0 then

begin

SetLength(S, Size);

Check(not InternetReadFile(Pointer(Context), @S[1], Size, Downloaded));

//下载数据：

Resp.Write(S[1], Size);

{ Receiving Data event }

if Assigned(FOnReceivingData) then

FOnReceivingData(Size, Downloaded)

end;

until Size = 0;

S的结果如下和刚才跟踪器里的是一模一样的：

'<?xml version="1.0"?>'#$D#$A'<envelope xmlns:soap-env="http://schemas.xmlsoap.org/soap/envelope/" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:soap-enc="http://schemas.xmlsoap.org/soap/encoding/">'#$D#$A''#$D#$A'<span> <getobjresponse xmlns:ns1="urn:MyFirstWSIntf-IMyFirstWS">'#$D#$A' <return xsi:type="xsd:string">12</return>'#$D#$A' </getobjresponse>'#$D#$A'</span> '#$D#$A'</envelope>'#$D#$A

最后关闭HTTP会话句柄：

InternetCloseHandle(Pointer(Context));

在返回function TRIO.Generic(CallID: Integer; Params: Pointer): Int64;函数中继续查看：

RespXML := Resp;

返回信息的内存流

FConverter.ProcessResponse(RespXML, IntfMD, MethMD, FContext, FHeadersInbound);

再次把SOAP封包转换成PASCEL调用：

procedure TOPToSoapDomConvert.ProcessResponse(const Resp: TStream;

const IntfMD: TIntfMetaData;

const MD: TIntfMethEntry;

Context: TInvContext;

Headers: THeaderList);

var

XMLDoc: IXMLDocument;

begin

XMLDoc := NewXMLDocument;

XMLDoc.Encoding := FEncoding;

Resp.Position := 0;

XMLDoc.LoadFromStream(Resp);

ProcessResponse(XMLDoc, IntfMD, MD, Context, Headers);

end;

procedure TOPToSoapDomConvert.ProcessResponse(const XMLDoc: IXMLDocument;

const IntfMD: TIntfMetaData;

const MD: TIntfMethEntry;

Context: TInvContext;

Headers: THeaderList);

var

ProcessSuccess(RespNode, IntfMD, MD, Context);

ProcessSuccess函数如下：

….

for I := 0 to RespNode.childNodes.Count - 1 do

begin

Node := RespNode.childNodes[I];

{ Skip non-valid nodes }

if Node.NodeType ntElement then

continue;

// 处理返回值：

if I = RetIndex then

begin

InvData := InvContext.GetResultPointer;

ByRef := IsParamByRef([pfOut], MD.ResultInfo, MD.CC);

ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);

把SOAP的结果，写入返回区地址空间。

procedure TSOAPDomConv.ConvertSoapToNativeData(DataP: Pointer; TypeInfo: PTypeInfo;

Context: TDataContext; RootNode, Node: IXMLNode; Translate, ByRef: Boolean;

NumIndirect: Integer);

var

TypeUri, TypeName: InvString;

IsNull: Boolean;

Obj: TObject;

P: Pointer;

I: Integer;

ID: InvString;

begin

Node := GetDataNode(RootNode, Node, ID);

IsNull := NodeIsNull(Node);

if TypeInfo.Kind = tkVariant then

begin

if NumIndirect > 1 then

DataP := Pointer(PInteger(DataP)^);

if IsNull then

begin

Variant(PVarData(DataP)^) := NULL;

end else

ConvertSoapToVariant(Node, DataP);

end else

if TypeInfo.Kind = tkDynArray then

begin

P := DataP;

for I := 0 to NumIndirect - 2 do

P := Pointer(PInteger(P)^);

P := ConvertSoapToNativeArray(P, TypeInfo, RootNode, Node);

if NumIndirect = 1 then

PInteger(DataP)^ := Integer(P)

else if NumIndirect = 2 then

begin

DataP := Pointer(PInteger(DataP)^);

PInteger(DataP)^ := Integer(P);

end;

end else

if TypeInfo.Kind = tkClass then

begin

Obj := ConvertSOAPToObject(RootNode, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, NumIndirect);

if NumIndirect = 1 then

PTObject(DataP)^ := Obj

else if NumIndirect = 2 then

begin

DataP := Pointer(PInteger(DataP)^);

PTObject(DataP)^ := Obj;

end;

end else

begin

if Translate then

begin

if NumIndirect > 1 then

DataP := Pointer(PInteger(DataP)^);

if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, IsNull) then

raise ESOAPDomConvertError.CreateFmt(STypeMismatchInParam, [node.nodeName]);

end;

作为整型数据，处理方式为：

if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, IsNull) then

functionTTypeTranslator.CastSoapToNative(Info: PTypeInfo; const SoapData: WideString; NatData: Pointer; IsNull: Boolean): Boolean;

var

ParamTypeData: PTypeData;

begin

DecimalSeparator := '.';

Result := True;

if IsNull and (Info.Kind = tkVariant) then

begin

Variant(PVarData(NatData)^) := NULL;

Exit;

end;

ParamTypeData := GetTypeData(Info);

case Info^.Kind of

tkInteger:

case ParamTypeData^.OrdType of

otSByte,

otUByte:

PByte(NatData)^ := StrToInt(Trim(SoapData));

otSWord,

otUWord:

PSmallInt(NatData)^ := StrToInt(Trim(SoapData));

otSLong,

otULong:

PInteger(NatData)^ := StrToInt(Trim(SoapData));

end;

tkFloat:

case ParamTypeData^.FloatType of

ftSingle:

PSingle(NatData)^ := StrToFloatEx(Trim(SoapData));

ftDouble:

begin

if Info = TypeInfo(TDateTime) then

PDateTime(NatData)^ := XMLTimeToDateTime(Trim(SoapData))

else

PDouble(NatData)^ := StrToFloatEx(Trim(SoapData));

end;

ftComp:

PComp(NatData)^ := StrToFloatEx(Trim(SoapData));

ftCurr:

PCurrency(NatData)^ := StrToFloatEx(Trim(SoapData));

ftExtended:

PExtended(NatData)^ := StrToFloatEx(Trim(SoapData));

end;

tkWString:

PWideString(NatData)^ := SoapData;

tkString:

PShortString(NatData)^ := SoapData;

tkLString:

PString(NatData)^ := SoapData;

tkChar:

if SoapData '' then

PChar(NatData)^ := Char(SoapData[1]);

tkWChar:

if SoapData '' then

PWideChar(NatData)^ := WideChar(SoapData[1]);

tkInt64:

PInt64(NatData)^ := StrToInt64(Trim(SoapData));

tkEnumeration:

{ NOTE: Here we assume enums to be byte-size; make sure (specially for C++)

that enums have generated with the proper size }

PByte(NatData)^ :=GetEnumValueEx(Info, Trim(SoapData));

tkClass:

;

tkSet,

tkMethod,

tkArray,

tkRecord,

tkInterface,

tkDynArray:

raise ETypeTransException.CreateFmt(SUnexpectedDataType, [ KindNameArray[Info.Kind]] );

tkVariant:

CastSoapToVariant(Info, SoapData, NatData);

end;

PWideString(NatData)^ := SoapData;

通过把值赋给了相应的指针地址：

另外在看一下传对象时的情况：

Obj := ConvertSOAPToObject(RootNode, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, NumIndirect);

if Assigned(Obj) andLegalRef then

begin

if (NodeClass nil) and (NodeClass Obj.ClassType) then

Obj := NodeClass.Create;

end else

begin

if (NodeClass nil) and NodeClass.InheritsFrom(AClass) then

Obj := TRemotableClass(NodeClass).Create

else

Obj := TRemotableClass(AClass).Create;

end;

Result := Obj;

可以理解，经过双边注册过之后，才可以传递对象。

现在研究一下服务器端的代码：

先大概简单介绍一下WEB服务器应用程序的工作模式：

这里的WEB服务器就是IIS。

也就是说WEB服务器会把客户的HTTP请求消息，传递给CGI程序。然后由CGI进行处理：

CGIApp单元中的：

procedure InitApplication;

begin

Application := TCGIApplication.Create(nil);

end;

//创建一个CGI的应用程序

constructor TWebApplication.Create(AOwner: TComponent);

begin

WebReq.WebRequestHandlerProc := WebRequestHandler;

inherited Create(AOwner);

Classes.ApplicationHandleException := HandleException;

if IsLibrary then

begin

IsMultiThread := True;

OldDllProc := DLLProc;

DLLProc := DLLExitProc;

end

else

AddExitProc(DoneVCLApplication);

end;

constructor TWebRequestHandler.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FCriticalSection := TCriticalSection.Create;

FActiveWebModules := TList.Create;

FInactiveWebModules := TList.Create;

FWebModuleFactories := TWebModuleFactoryList.Create;

FMaxConnections := 32;

FCacheConnections := True;

end;

procedure TCGIApplication.Run;

var

HTTPRequest: TCGIRequest;

HTTPResponse: TCGIResponse;

begin

inherited Run;

if IsConsole then

begin

Rewrite(Output);

Reset(Input);

end;

try

HTTPRequest := NewRequest;

try

HTTPResponse := NewResponse(HTTPRequest);

try

HandleRequest(HTTPRequest, HTTPResponse);

finally

HTTPResponse.Free;

end;

finally

HTTPRequest.Free;

end;

except

HandleServerException(ExceptObject, FOutputFileName);

end;

HTTPResponse := NewResponse(HTTPRequest);

调用：

function TCGIApplication.GetFactory: TCGIFactory;

begin

if not Assigned(FFactory) then

FFactory := TCGIFactory.Create;

Result := FFactory;

end;

function TCGIFactory.NewRequest: TCGIRequest;

Result := TCGIRequest.Create

。。。

end;

//创建TCGIRequest

HTTPResponse := NewResponse(HTTPRequest);

Result := TCGIResponse.Create(CGIRequest)

HandleRequest(HTTPRequest, HTTPResponse);调用

现在看看是怎么响应客户端的：

function TWebRequestHandler.HandleRequest(Request: TWebRequest;

Response: TWebResponse): Boolean;

var

I: Integer;

WebModules: TWebModuleList;

WebModule: TComponent;

WebAppServices: IWebAppServices;

GetWebAppServices: IGetWebAppServices;

begin

Result := False;

WebModules := ActivateWebModules;

继续：

function TWebRequestHandler.ActivateWebModules: TWebModuleList;

begin

………………

FWebModuleFactories.AddFactory(TDefaultWebModuleFactory.Create(WebModuleClass));

把TWebModule1加入工厂中,并创建TwebModuleList对象。

if FWebModuleFactories.ItemCount > 0 then

begin

Result := TWebModuleList.Create(FWebModuleFactories);

………………..

继续：

if Assigned(WebModules) then

try

WebModules.AutoCreateModules;

procedure TWebModuleList.AutoCreateModules

….... AddModule(Factory.GetModule);

调用：TWebModule1.create并加入TwebModuleList中。

function TDefaultWebModuleFactory.GetModule: TComponent;

begin

Result := FComponentClass.Create(nil);

end;

constructor TWebModule.Create(AOwner: TComponent);调用

constructor TCustomWebDispatcher.Create(AOwner: TComponent);

之后又创建了THTTPSoapDispatcher，创建是在Treader类中创建的，有兴趣的朋友就追踪一下吧，这里实在是太麻烦。我也追了很久才发现。就懒得贴上来了。内容太多。

继续创建了TWSDLHTMLPublish

在回到TWebRequestHandler.HandleRequest函数中：

。。。

Result := WebAppServices.HandleRequest;

最后调用了：

function TCustomWebDispatcher.HandleRequest(

Request: TWebRequest; Response: TWebResponse): Boolean;

begin

FRequest := Request;

FResponse := Response;

Result := DispatchAction(Request, Response);

end;

注意HandleRequest函数，这里是关键部分：

function TCustomWebDispatcher.DispatchAction(Request: TWebRequest;

Response: TWebResponse): Boolean;

…………………

while not Result and (I

begin

if Supports(IInterface(FDispatchList.Items[I]), IWebDispatch, Dispatch) then

begin

Result := DispatchHandler(Self, Dispatch,

Request, Response, False);

end;

Inc(I);

end;

继续：

function DispatchHandler(Sender: TObject; Dispatch: IWebDispatch; Request: TWebRequest; Response: TWebResponse;

DoDefault: Boolean): Boolean;

begin

Result := False;

if (Dispatch.Enabled and ((Dispatch.MethodType = mtAny) or

(Dispatch.MethodType = Dispatch.MethodType)) and

Dispatch.Mask.Matches(Request.InternalPathInfo)) then

begin

Result := Dispatch.DispatchRequest(Sender, Request, Response);

end;

http调用在到达服务器后，WebModule父类TCustomWebDispatcher
会对其进行分析，抽取参数等信息。然后在TCustomWebDispatcher.HandleRequest
方法中调用TCustomWebDispatcher.DispatchAction方法，将调用
根据其path info重定向到相应的处理方法去。而DispatchAction方法将
Action重定向到FDispatchList字段中所有的实现了IWebDispatch接口的组件。

而THTTPSoapDispatcher正是实现了IWebDispatch，其将在
TCustomWebDispatcher.InitModule方法中被自动检测到并加入FDispatchList字段

具体如下：

procedure TCustomWebDispatcher.InitModule(AModule: TComponent);
var
I: Integer;
Component: TComponent;
DispatchIntf: IWebDispatch;
begin
if AModule nil then
for I := 0 to AModule.ComponentCount - 1 do
begin
Component := AModule.Components[I];
if Supports(IInterface(Component), IWebDispatch, DispatchIntf) then
FDispatchList.Add(Component);
end;
end;
...
THTTPSoapDispatcher = class(THTTPSoapDispatchNode, IWebDispatch)
因此Web Service程序的http请求处理实际上是由THTTPSoapDispatcher进行的。

我们接着看看THTTPSoapDispatcher.DispatchRequest方法中对SOAP
协议的处理，关键代码如下
function THTTPSoapDispatcher.DispatchRequest(Sender: TObject;

Request: TWebRequest; Response: TWebResponse): Boolean;

var

…..

http信息被封装在TwebRequest里：我们来看是怎么进行分析的：

SoapAction := Request.GetFieldByName(SHTTPSoapAction);

首先得到SOAPAction信息, 这个SOAPAction大家应该比较熟悉了，前面讲过，这里主要是根据相应信息调用方法：() 具体的内容例如：urn:MyFirstWSIntf-IMyFirstWS

….

if SoapAction = '' then

SoapAction := Request.GetFieldByName('HTTP_' + UpperCase(SHTTPSoapAction)); { do not localize }

CGI或者Apache的处理方式。如果不是SOAP请求，就默认HTTP请求。

记录请求的路径。

Path := Request.PathInfo;

XMLStream := TMemoryStream.Create;//把客户端的请求流化。

ReqStream := TWebRequestStream.Create(Request);

创建一个响应的流信息,以例把结果返回客户端

RStream := TMemoryStream.Create; 创建返回信息的流。

try

FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);

这句是最重要的：

它把ＨＴＴＰ的调用方法，委托给THTTPSoapPascalInvoker.DispatchSOAP来处理。

FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);

IHTTPSoapDispatch = interface

['{9E733EDC-7639-4DAF-96FF-BCF141F7D8F2}']

procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;

Response: TStream; var BindingType: TWebServiceBindingType);

end;

父类实现的接口：

THTTPSoapDispatchNode = class(TComponent)

private

procedure SetSoapDispatcher(const Value: IHTTPSoapDispatch);

protected

FSoapDispatcher: IHTTPSoapDispatch;

procedure Notification(AComponent: TComponent; Operation: TOperation); override;

public

procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;

Response: TStream); virtual;

published

property Dispatcher: IHTTPSoapDispatch read FSoapDispatcher write SetSoapDispatcher;

end;

也被THTTPSoapPascalInvoker实现。所以THTTPSoapDispatcher中的Dispatcher接口的实例其实是：THTTPSoapPascalInvoker

THTTPSoapPascalInvoker = class(TSoapPascalInvoker, IHTTPSoapDispatch)

public

procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;

Response: TStream; var BindingType: TWebServiceBindingType); virtual;

end;

FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);

相应于调用了：

procedure THTTPSoapPascalInvoker.DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;

Response: TStream; var BindingType: TWebServiceBindingType);

var

IntfInfo: PTypeInfo;

PascalBind: IHTTPSOAPToPasBind;

InvClassType: TClass;

ActionMeth: String;

MD: TIntfMetaData;

if not PascalBind.BindToPascalByPath(Path, InvClassType, IntfInfo, ActionMeth)or (InvClassType = nil) then

调用:

function THTTPSOAPToPasBind.BindToPascalByPath(Path: String;

var AClass: TClass; var IntfInfo: PTypeInfo; var AMeth: String): Boolean;

begin

Result := InvRegistry.GetInfoForURI(Path, '', AClass, IntfInfo, AMeth);

end;

由InvRegistry的注册信息，返回相应的类名，接口信息等信息。

这了这些准备信息，下步才是真正的调用。

Invoke(InvClassType, IntfInfo, ActionMeth, Request, Response, BindingType);

函数最后一句：调用了父类：这里是真正工作的地方：

这里了仔细认真研究一下：

procedure TSoapPascalInvoker.Invoke(AClass: TClass; IntfInfo: PTypeInfo; MethName: string; const Request: TStream;

Response: TStream; var BindingType: TWebServiceBindingType);

var

Inv: TInterfaceInvoker;

Obj: TObject;

InvContext: TInvContext;

IntfMD: TIntfMetaData;

MethNum: Integer;

SOAPHeaders: ISOAPHeaders;

Handled: Boolean;

begin

try

GetIntfMetaData(IntfInfo, IntfMD, True);得到接口ＲＴＴＬ信息；

InvContext := TInvContext.Create;　　　　构造调用堆栈。

{ Convert XML to Invoke Context }

FConverter.MsgToInvContext(Request, IntfMD, MethNum, InvContext, FHeadersIn);

这个函数请见前面的参考InvContextToMsg, 把TinvContext内容转化成XML封包。

这个函数是逆操作，把XML内容转化成Context。

try

Obj := InvRegistry.GetInvokableObjectFromClass(AClass);

搜寻注册信息，创建实例：

if Obj = nil then

raise Exception.CreateFmt(SNoClassRegistered, [IntfMD.Name]);

……………..

Inv := TInterfaceInvoker.Create;

Inv.Invoke(Obj, IntfMD, MethNum, InvContext);

真正调用的地方：

源代码为：

这段代码，就是根据对象，接口信息等，把ＣＯＮtext的信息压入相应参数，应调用。

有时间再仔细研究。

procedure TInterfaceInvoker.Invoke(const Obj: TObject;

IntfMD: TIntfMetaData; const MethNum: Integer;

const Context: TInvContext);

var

MethPos: Integer;

Unk: IUnknown;

IntfEntry: PInterfaceEntry;

IntfVTable: Pointer;

RetIsOnStack, RetIsInFPU, RetInAXDX: Boolean;

I: Integer;

RetP : Pointer;

MD : TIntfMethEntry;

DataP: Pointer;

Temp, Temp1: Integer;

RetEAX: Integer;

RetEDX: Integer;

TotalParamBytes: Integer;

ParamBytes: Integer;

begin

{$IFDEF LINUX}

try

{$ENDIF}

TotalParamBytes := 0;

MD := IntfMD.MDA[MethNUm];//得到方法的动态数组信息：

if not Obj.GetInterface(IntfMD.IID, Unk) then

raise Exception.CreateFmt(SNoInterfaceGUID,

[Obj.ClassName, GUIDToString(IntfMD.IID)]);

IntfEntry := Obj.GetInterfaceEntry(IntfMD.IID);//得到接口的动态数组信息

IntfVTable := IntfEntry.VTable;//指向VTB表的指针

MethPos := MD.Pos * 4; { Pos is absolute to whole VMT } //定位

if MD.ResultInfo nil then

begin

RetIsInFPU := RetInFPU(MD.ResultInfo);

RetIsOnStack := RetOnStack(MD.ResultInfo);

RetInAXDX := IsRetInAXDX(MD.ResultInfo);

RetP := Context.GetResultPointer; //根据context 得到返回参数的地址。

end else

begin

RetIsOnStack := False;

RetIsInFPU := False;

RetInAXDX := False;

end;

if MD.CC in [ccCDecl, ccStdCall, ccSafeCall] then

begin

if (MD.ResultInfo nil) and (MD.CC = ccSafeCall) then

asm PUSH DWORD PTR [RetP] end; //把函数返回参数压入堆栈中。

for I := MD.ParamCount - 1 downto 0 do //遍历参数。

begin

DataP := Context.GetParamPointer(I); //指向一个参数地址：

if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then{基本类型}

asm

PUSH DWORD PTR [DataP] //压入堆栈。

end

else

begin

ParamBytes := GetStackTypeSize(MD.Params[I].Info, MD.CC); {特殊类型}

PushStackParm(DataP, ParamBytes);

Inc(TotalParamBytes, ParamBytes);

end;

asm PUSH DWORD PTR [Unk] end; //压入Iunknown指针

if RetIsOnStack and (MD.CC ccSafeCall) then

asm PUSH DWORD PTR [RetP] end;

end

else if MD.CC = ccPascal then

begin

for I := 0 to MD.ParamCount - 1 do

begin

DataP := Context.GetParamPointer(I);

if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then

asm

PUSH DWORD PTR [DataP]

end

else

begin

// PushStackParm(DataP, GetStackTypeSize(MD.Params[I].Info, MD.CC));

ParamBytes := GetStackTypeSize(MD.Params[I].Info, MD.CC);

PushStackParm(DataP, ParamBytes);

Inc(TotalParamBytes, ParamBytes);

end;

if RetIsOnStack then

asm PUSH DWORD PTR [RetP] end;

asm PUSH DWORD PTR [Unk] end;

end else

raise Exception.CreateFmt(SUnsupportedCC, [CallingConventionName[MD.CC]]);

if MD.CC ccSafeCall then

begin

asm

MOV DWORD PTR [Temp], EAX //把ＥＡＸ保存到临时变量中

MOV DWORD PTR [Temp1], ECX//把ＥCＸ保存到临时变量中

MOV EAX, MethPos //函数定位的地方

MOV ECX, [IntfVtable] //虚拟表的入口

MOV ECX, [ECX + EAX] //真正调用的地址

CALL ECX

MOV DWORD PTR [RetEAX], EAX//把结果返回的信息保存在变量RetEAX（低位）

MOV DWORD PTR [RetEDX], EDX//把结果返回的信息保存在变量RetEDX（高位）

MOV EAX, DWORD PTR [Temp] //恢复寄存器ＥＡＸ

MOV ECX, DWORD PTR [Temp1]　　 //恢复寄存器ＥＣＸ

end;

end else

begin

asm

MOV DWORD PTR [Temp], EAX

MOV DWORD PTR [Temp1], ECX

MOV EAX, MethPos

MOV ECX, [IntfVtable]

MOV ECX, [ECX + EAX]

CALL ECX

CALL System.@CheckAutoResult

MOV DWORD PTR [RetEAX], EAX

MOV DWORD PTR [RetEDX], EDX

MOV EAX, DWORD PTR [Temp]

MOV ECX, DWORD PTR [Temp1]

end;

if MD.CC = ccCDecl then/如果是ＣＣＤＥＣＬ方式，必须自己清除使用的堆栈。

asm

MOV EAX, DWORD PTR [TotalParamBytes]

ADD ESP, EAX

end;

//调用后，返回参数的处理：

if MD.ResultInfo nil then

begin

if MD.CC ccSafeCall then//返回类型不为ccSafeCall时，必须进行处理。

begin

if RetIsInFPU then//tkFloat类型：

begin

GetFloatReturn(RetP, GetTypeData(MD.ResultInfo).FloatType);

end else if not RetIsOnStack then

begin

if RetInAXDX then//tkInt64整型６４位类型处理：

asm

PUSH EAX

PUSH ECX

MOV EAX, DWORD PTR [RetP]

MOV ECX, DWORD PTR [RetEAX]

MOV [EAX], ECX

MOV ECX, DWORD PTR [RetEDX]

MOV [EAX + 4], ECX

POP ECX

POP EAX

end

else

asm //堆栈类型：

PUSH EAX //EAX入栈

PUSH ECX //ECX入栈

MOV EAX, DWORD PTR [RetP] //返回地址ＭＯＶ到ＥＡＸ

MOV ECX, DWORD PTR [RetEAX]// RetEAX中是调用后得到的值

MOV [EAX], ECX　　　　　　　　//把调用后的结果写入返回的地址中　

POP ECX //ECX出栈

POP EAX //EAX出栈(先入后出)

end;

{$IFDEF LINUX}

except

// This little bit of code is required to reset the stack back to a more

// resonable state since the exception unwinder is completely unaware of

// the stack pointer adjustments made in this function.

asm

MOV EAX, DWORD PTR [TotalParamBytes]

ADD ESP, EAX

end;

raise;

end;

{$ENDIF}

end;

FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);

返回调用后的内存块为。

Response.ContentStream := RStream;

然后再发送给客户端。

到这里，基本上客户端和服务器端都进行了分析。

上一篇远程调用技术代码追踪(webservice)

<script type="text/javascript" id="bdshare_js" data="type=tools&uid=1536434"></script><script type="text/javascript" id="bdshell_js"></script><script type="text/javascript"> document.getElementById("bdshell_js").src = "http://bdimg.share.baidu.com/static/js/shell_v2.js?cdnversion=" + Math.ceil(new Date()/3600000) </script>

主题推荐

webservice 技术 http服务器 web服务器 web服务

猜你在找

查看评论

* 以上用户言论只代表其个人观点，不代表CSDN网站的观点或立场

分享到：

TCP/IP详解卷一笔记 | 高性能网站性能优化

2008-06-10 12:52
浏览 624
评论(0)
查看更多

发表评论

您还没有登录,请您登录后再发表评论

最近访客更多访客>>

博主相关

文章分类

社区版块

存档分类

最新评论