远程调用技术代码追踪(webservice)
发布时间：2020-12-17 02:52:56 所属栏目：安全 来源：网络整理
导读：最近阅读了SocketConn的源码和WebService 的源码，把追踪的过程写了下来，方便大家学习。毕竟这需要精力，时间和毅力。感谢煮茶待英雄博志区和三层数据库讨论区兄弟们的支持，特别是julian兄弟，不是他，我可能没耐心继续下去。如果有时间，大家可以继续完善
|
最近阅读了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),'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,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,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,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,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,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+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,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;
?
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,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',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'<SOAP-ENV: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'?<SOAP-ENV:Body SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">'#$D#$A'
??? <NS1: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'??? </NS1:GetObj>'#$D#$A'?</SOAP-ENV:Body>'#$D#$A'</SOAP-ENV:Envelope>'#$D#$A
?
?
转化后继续调用Generic函数：
。。。。
FWebNode.BeforeExecute(IntfMD,MethMD,MethNum-3,nil);
?
if (BindingType = btMIME) then
begin
。。。
FWebNode.BeforeExecute(IntfMD,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
????? 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;
????? end;
??? finally
????? if Context <> 0?then
??????? InternetCloseHandle(Pointer(Context));
??? end;
?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,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,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,
??????????????????????????????????? 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,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,@StrStr.DataString[1],Length(StrStr.DataString)));
????????? RetVal := InternetErrorDlg(GetDesktopWindow(),
??????????? 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;
??????? end;
????? finally
??????? StrStr.Free;
????? end;
??? 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,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,
?????????????????????????????? nil,0{Integer(Self)});
Check(not Assigned(Request));。
打开一个HTTP的请求。向WEB服务器提出请求：
。。
if not (soNoSOAPActionHeader in FInvokeOptions) then
????? begin
??????? ActionHeader:= GetSOAPActionHeader;
??????? HttpAddRequestHeaders(Request,HTTP_ADDREQ_FLAG_ADD);
end;
。。。
为请求添加一个或多个标头。可以看到标点的信息为：
'SOAPAction: "urn:MyFirstWSIntf-IMyFirstWS#GetObj"'
?
?
HttpAddRequestHeaders(Request,HTTP_ADDREQ_FLAG_ADD);
继续加入标头'Content-Type: text/xml'信息：
?
????? StrStr := TStringStream.Create('');
????? try
??????? StrStr.CopyFrom(ASrc,Length(StrStr.DataString)));
建立到internet 的连接，并将请求发送到指定的站点。
这句执行完后的图如下（用工具跟踪的结果）：
?
看看前面的soap生成的字符 StrStr的结果如下，发现后半部分是一样的。
?
继续
function THTTPReqResp.Execute(const Request: TStream): TStream;
Receive(Context,Response);
?
?
procedure?THTTPReqResp.Receive(Context: Integer; Resp: TStream; IsGet: Boolean);
var
?Size,Downloaded,Status,Index: DWord;
?S: string;
begin
?
?..
//获取请求信息：
?HttpQueryInfo(Pointer(Context),HTTP_QUERY_CONTENT_TYPE,@FContentType[1],Size,Index);
?
?repeat
??? Check(not InternetQueryDataAvailable(Pointer(Context),0));
??? if Size > 0 then
??? begin
????? SetLength(S,Size);
Check(not InternetReadFile(Pointer(Context),@S[1],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'<SOAP-ENV: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'?<SOAP-ENV:Body SOAP-ENC:encodingStyle="http://schemas.xmlsoap.org/soap/envelope/">'#$D#$A'
??? <NS1:GetObjResponse xmlns:NS1="urn:MyFirstWSIntf-IMyFirstWS">'#$D#$A'????? <return xsi:type="xsd:string">12</return>'#$D#$A'??? </NS1:GetObjResponse>'#$D#$A'?</SOAP-ENV:Body>'#$D#$A'</SOAP-ENV:Envelope>'#$D#$A
?
最后关闭HTTP会话句柄：
?InternetCloseHandle(Pointer(Context));
?
在返回function TRIO.Generic(CallID: Integer; Params: Pointer): Int64;函数中继续查看：
?
RespXML := Resp;
返回信息的内存流
FConverter.ProcessResponse(RespXML,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,MD,Context,Headers);
end;
?
procedure TOPToSoapDomConvert.ProcessResponse(const XMLDoc: IXMLDocument;
????????????????????????????????????????????? const IntfMD: TIntfMetaData;
?????????????????????????????????? ???????????const MD: TIntfMethEntry;
????????????????????????????????????????????? Context: TInvContext;
????????????????????????????????????????????? Headers: THeaderList);
var
?ProcessSuccess(RespNode,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,InvContext,RespNode,Node,True,ByRef,1);
?
?
ConvertSoapToNativeData(InvData,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,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,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),IsNull) then
??????? raise ESOAPDomConvertError.CreateFmt(STypeMismatchInParam,[node.nodeName]);
??? end;
?end;
end;
?
作为整型数据，处理方式为：
if not TypeTranslator.CastSoapToNative(TypeInfo,IsNull) then
?
function?TTypeTranslator.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;
end;
?
PWideString(NatData)^ := SoapData;
通过把值赋给了相应的指针地址：
?
另外在看一下传对象时的情况：
Obj := ConvertSOAPToObject(RootNode,NumIndirect);
?
?
if Assigned(Obj) and?LegalRef 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;
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 < FDispatchList.Count) do
?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,Response);
?end;
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),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,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,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,AMeth);
end;
由InvRegistry的注册信息，返回相应的类名，接口信息等信息。
这了这些准备信息，下步才是真正的调用。
Invoke(InvClassType,ActionMeth,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,True);?得到接口ＲＴＴＬ信息；
InvContext := TInvContext.Create; 构造调用堆栈。
?? { Convert XML to Invoke Context }
????????? FConverter.MsgToInvContext(Request,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,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,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;
??? 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.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);
????? end;
??? 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;
?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;
????? end;
??? end;
?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;?
（编辑：李大同） 【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容! |