查看: 2357|回复: 16
VCL组合框功能扩
阅读权限228
在线时间 小时
签到天数：19 天结帖率： (2/2)
易语言VCL组合框功能扩展源码例程程序结合易语言VCLBase支持库，调用API函数实现VCL高级组合框的功能扩展。
VCL高级组合框_取现行选中项
VCL高级组合框_取项目文本
VCL高级组合框_置现行选中项
(2.63 KB, 下载次数: 82)
14:34 上传
点击文件名下载附件
下载积分: 精币 -1 枚
这个有点意思了&
奉上小小红包希望笑纳
奉上小小红包希望笑纳
您可以选择打赏方式支持楼主
阅读权限20
在线时间 小时
试试看！我谢了
阅读权限70
在线时间 小时
签到天数: 18 天结帖率： (2/5)
下来学习学习。
阅读权限30
在线时间 小时
结帖率： (1/5)
取现行选中项
阅读权限90
在线时间 小时
签到天数: 20 天结帖率： (11/11)
VCL组合框功能扩展源码例程
阅读权限30
在线时间 小时
结帖率： (9/9)
阅读权限10
在线时间 小时
好东西 学習中
阅读权限50
在线时间 小时
结帖率： (11/15)
牛逼& & 学习了
阅读权限50
在线时间 小时
结帖率： (7/10)
看看再说啦~~
阅读权限140
在线时间 小时
结帖率： (1/2)
拒绝任何人以任何形式在本论坛发表与中华人民共和国法律相抵触的言论，本站内容均为会员发表，并不代表精易立场!
揭阳精易科技有限公司申明:我公司所有的培训课程版权归精易所有，任何人以任何方式翻录、盗版、破解本站培训课程，我们必将通过法律途径解决！
公司简介：揭阳市揭东区精易科技有限公司致力于易语言教学培训/易语言学习交流社区的建设与软件开发，多年来为中小企业编写过许许多多各式软件，并把多年积累的开发经验逐步录制成视频课程供学员学习，让学员全面系统化学习易语言编程，少走弯路，减少对相关技术的研究与摸索时间，从而加快了学习进度！
防范网络诈骗，远离网络犯罪
违法和不良信息举报电话，企业QQ： ，邮箱：
Powered by03-源代码分析
最近阅读了SocketConn的源码和WebService 的源码，把追踪的过程写了下来，方便大家学习。毕竟这需要精力，时间和毅力。感谢煮茶待英雄博志区和三层数据库讨论区兄弟们的支持，特别是julian兄弟，不是他，我可能没耐心继续下去。如果有时间，大家可以继续完善。从socket和Websevice的底层实现细节，我们发现BORLAND的工程师们的构思和实现的过程。我觉得这对我们的学习应该是非常重要的。学会思考。学会读源码，学会分析。
希望和我交往的朋友可通过QQ或Email联系我。Wu_.cn
另见：《远程调用技术代码追踪(socket) 》
关注我的：《远程调用技术代码追踪(第三方控件) 》
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& &远程调用技术内幕
有关WebService的相关的知识，我就不说了，我直接分析源码。有问题的地方请参考李维的书。
initialization
InvRegistry.RegisterInterface(TypeInfo(IMyFirstWS), 'urn:MyFirstWSIntf-IMyFirstWS', 'utf-8');
看过李维的分布式架构的应该都知道，WEB服务端对类和接口进行了注册，客户端这里也进行了注册。然后客户端把数据通过HTTP传输到服务器端，服务器端通过拆包，去到注册管理的类中寻找相应的接口，并创建一个相应的对象，把客户端的数据压进去，调用后，把数据再传回来。
在调用这句的时候，TinvokableClassRegistry类已经创建了，由于inquire_v1也引用了InvRegistry注册，所以在哪里被引用的时候已经被创建了。
function InvRegistry: TInvokableClassR
&if not Assigned(InvRegistryV) then
&&& InitIR;
&Result :=&InvRegistryV;
初次引用会调用InitIR方法。
procedure InitIR;
&InvRegistryV := TInvokableClassRegistry.C
&RemTypeRegistryV := TRemotableClassRegistry.C
&RemClassRegistryV:= RemTypeR
&InitBuiltI&//定们到这一句：
&InitMoreBuiltI
先看InvRegistryV := TInvokableClassRegistry.C，这个类是用来注册，相应的接口及类，
并能够根据soap封包内容找到相应的接口及方法。
TRemotableClassRegistry&&&&&& = TRemotableTypeR
所对应的是TremotableTypeRegistry, 这个类主要是对数据类型进行注册。
大致来了解一下这个类。
TInvokableClassRegistry = class(TInterfacedObject)
&&& FLock: TRTLCriticalS
&&& FRegClasses: array of InvRegClassE
FRegIntfs: array of InvRegIntfE
这里可以看到，声明了两个动态数组。分别用来放接口注册，及类注册信息。
TCreateInstanceProc = procedure(out obj: TObject);
InvRegClassEntry = record
&&& ClassType: TC
&&& Proc: TCreateInstanceP
它包含了webservice实现类的指针，以建立实现类的factory函数指针。
InvRegIntfEntry = record
&&& Name:&&&&&&&&&&&&&&&&&&&&&&&&&&&& { Native name of interface&&& }
&&& ExtName: W&&&&&&&&&&&&&&&&&&&&& { PortTypeName&&&&&&&&&&&&&&& }
&&& UnitName:&&&&&&&&&&&&&&&&&&&&&&&& { Filename of interface&&&&&& }
&&& GUID: TGUID;&&&&&&&&&&&&&&&&&&&&&&&&&&&&& { GUID of interface&&&&&&&&&& }
&&&Info: PTypeI&&&&&&&&&&&&&&&&&&&&&&&&& { Typeinfo of interface&&&&&& }
&&& DefImpl: TC&&&&&&&&&&&&&&&&&&&&&&&&& { Metaclass of implementation }
&&& Namespace: W&&&&&&&&&&&&&&&&&&& { XML Namespace of type&&&&&& }
&&& WSDLEncoding: WideS&&&&&&&&&&&&&&&& { Encoding&&&&&&&&&&&&&&&&&&& }
&&& Documentation:&&&&&&&&&&&&&&&&&&& { Description of interface&&& }
&&& SOAPAction:&&&&&&&&&&&&&&&&&&&&&& { SOAPAction of interface&&&& }
&&& ReturnParamNames:&&&&&&&&&&&&&&&& { Return Parameter names&&&&& }
&&& InvokeOptions: TIntfInvokeO&&&&&&& { Invoke Options&&&&&&&&&&&&& }
&&& MethNameMap: array of ExtNameMapI&&&&&&&&&&&& { Renamed methods&&&& }
&&& MethParamNameMap: array of MethParamNameMapI&{ Renamed parameters&}
&&& IntfHeaders: array of IntfHeaderI&&&&& { Headers&&&&&&&&&&&&&&&&&&& }
&&& IntfExceptions: array of IntfExceptionI{ Exceptions&&&&&&&&&&&&&&&& }
&&& UDDIOperator: S&&&&&&&&&&&&&&&&&&&&& { UDDI Registry of this porttype }
&&& UDDIBindingKey: S&&&&&&&&&&&&&&&&&&& { UDDI Binding key&&&&&&&&&& }
看到它里面有很多东西，接口名称，单元名，GUID等信息。
&procedure InitBuiltI
&{ DO NOT LOCALIZE }
&RemClassRegistry.RegisterXSInfo(TypeInfo(System.Boolean), XMLSchemaNameSpace, 'boolean');
对于处理结构型数据，需要进行SOAP封包类型的转换
开发人员在使用这种自定义数据类型前必须对其进行注册，分别是RegisterXSClass和RegisterXSInfo。前一个方法是注册从Tremotable继承下来的类，后一个不需要是从TremotablXS继承下来的类。
InitBuiltI&&
&InitMoreBuiltI
这三个函数类似，都是注册一些基本类型等。
看看到底怎么处理的,(这里注册一个BOOLEAN类型)
RemClassRegistry.RegisterXSInfo(TypeInfo(System.Boolean), XMLSchemaNameSpace, 'boolean');
procedure TRemotableTypeRegistry.RegisterXSInfo(Info: PTypeI const URI: WideString = '';
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& const Name: WideString = '';
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& const ExtName: WideString = '');&
Index := GetEntry(Info, Found, Name);
&&& if Found then
&&& if AppNameSpacePrefix && '' then
&&&&& AppURI := AppNameSpacePrefix + '-';
&&& if URI = '' then
&&&&& if Info.Kind = tkDynArray then
&&&&& begin
&&&&&&& UnitName := GetTypeData(Info).DynUnitN
&&&&&&& URIMap[Index].URI := 'urn:' + AppURI +&UnitN
&&&&& else if Info.Kind = tkEnumeration then
&&&&& begin
&&&&&&& UnitName := GetEnumUnitName(Info);
&&&&&&& URIMap[Index].URI := 'urn:' + AppURI +&UnitN
&&& &&else if Info.Kind = tkClass then
&&&&&&& URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(Info).UnitName
&&&&& else
&&&&&&& URIMap[Index].URI := 'urn:' + AppURI;
&&&&& URIMap[Index].URI := URI;
&&& if Name && '' then
&&&&& URIMap[Index].Name := Name
&&&&& URIMap[Index].Name := Info.N
&&& URIMap[Index].ExtName := ExtN
&&& URIMap[Index].Info := I
&&& if Info.Kind = tkClass then
&&&&& URIMap[Index].ClassType := GetTypeData(Info).ClassT
看研究一下GetEntry函数，这里以后多次用到，发现这个函数是TremotableClassRegistry类的，说明实际的注册还是在TremotableClassRegistry这个类完成的。
function TRemotableClassRegistry.GetEntry(Info: PTypeI var Found: B const Name: WideString): I
&Result := FindEntry(Info, Found, Name);
&if not Found then
&&& SetLength(URIMap, Result + 1);
这个函数功能是搜索类型是否已注册，否则，动态数组加1，分配空间进行注册。
看看FindEntry (这里传进来的info是TypeInfo(System.Boolean), name: Boolean)
function TRemotableClassRegistry.FindEntry(Info: PTypeI var Found: B const Name: WideString): I
&Result := 0;
&Found := F
&while Result & Length(URIMap) do
&&& if (Info && nil) and (URIMap[Result].Info = Info) then
&&&&& if (Name = '') or (URIMap[Result].Name = Name) then
&&&&& begin
&&&&&&& Found := T
&&& Inc(Result);
这个函数的功能是遍历整个动态数组TremRegEntry，利用TypeInfo信息和名字进行搜索，查看是否已进行注册。
看看URIMAP的定义：
URIMAP:&& array of TRemRegE
&TObjMultiOptions = (ocDefault, ocMultiRef, ocNoMultiRef);
&TRemRegEntry = record
&&& ClassType: TC&//类信息
&&& Info: PtypeI&&& // typeInfo信息（RTTL）
&&& URI: WideS&& //
&&& Name: WideS&//
&&& ExtName: WideS //
&&& IsScalar: B&&& //
&&& MultiRefOpt: TObjMultiO //
&&& SerializationOpt: TSerializationO
&&& PropNameMap: array of ExtNameMapI&&&&&&&&&&&& { Renamed properties }
继续RegisterXSInfo函数：
这是对动态数组的uri赋值：
if AppNameSpacePrefix && '' then
&&&&& AppURI := AppNameSpacePrefix + '-';
&&& if URI = '' then
&&&&& if Info.Kind = tkDynArray then
&&&&& begin
&&&&&&& UnitName := GetTypeData(Info).DynUnitN
&&&&&&& URIMap[Index].URI := 'urn:' + AppURI +&UnitN
&&&&& else if Info.Kind = tkEnumeration then
&&&&& begin
&&&&&&& UnitName := GetEnumUnitName(Info);
&&&&&&& URIMap[Index].URI := 'urn:' + AppURI +&UnitN
&&&&& else if Info.Kind = tkClass then
&&&&&&& URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(Info).UnitName
&&&&& else
&&&&&&& URIMap[Index].URI := 'urn:' + AppURI;
&&&&& URIMap[Index].URI := URI;
&&& if Name && '' then
&&&&& URIMap[Index].Name := Name
&&&&& URIMap[Index].Name := Info.N
这句比较关键：
URIMap[Index].Info := I
把RTTL信息保存在URL动态数组中。
总结一下：一些基本类型，都是通过这种方式，把URI，及INFO信息保存在动态数组中的。
为什么要进行登记，因为WEBSERVICE中的数据类型要转换成DELPHI的PAS类型，用URI标记的XML文件，传输之后，根据这张对照表，就可以分配相应的空间。另外这些类型的注册信息是放在：TremRegEntry动态数组中的。和我们自己定义的接口及类是不同的。
FRegClasses: array of InvRegClassE
&FRegIntfs: array of InvRegIntfE&这是注册自己定义接口及类的动态数组。
再来分析：
InitBuiltIns函数中的：
RemClassRegistry.RegisterXSClass(TSOAPAttachment, XMLSchemaNamespace, 'base64Binary', '', False, ocNoMultiRef);
大致和基本类型差不多。
procedure TRemotableTypeRegistry.RegisterXSClass(AClass: TC const URI: WideString = '';
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& const Name: WideString = '';
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& &&&&&&&&&&const ExtName: WideString = '';
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& IsScalar: Boolean = F
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& MultiRefOpt: TObjMultiOptions = ocDefault);
&AppURI: WideS
&&& Index := GetEntry(AClass.ClassInfo, Found, Name);
&&& if not Found then
&&&&& 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.ClassN
&&&&& URIMap[Index].ExtName := ExtN
&&&&& URIMap[Index].ClassType := AC
&&&&& URIMap[Index].Info := AClass.ClassI
&&&&& URIMap[Index].IsScalar := IsS
&&&&& URIMap[Index].MultiRefOpt := MultiRefO
前面都是说系统类型的注册。下面看看我们自己定义的接口，是如何注册的：
procedure TInvokableClassRegistry.RegisterInterface(Info: PTypeI const Namespace: InvS
&&&&&&&&&&&&&&&&&&& const WSDLEncoding: InvS const Doc: const ExtName: InvString);
&&& for I := 0 to Length(FRegIntfs) - 1 do
&&&&& if FRegIntfs[I].Info = Info then
Index := Length(FRegIntfs);
SetLength(FRegIntfs, Index + 1);
GetIntfMetaData(Info, IntfMD, True);
&&& FRegIntfs[Index].GUID := IntfMD.IID;
&&& FRegIntfs[Index].Info := I
&&& FRegIntfs[Index].Name := IntfMD.N
&&& FRegIntfs[Index].UnitName := IntfMD.UnitN
&&& FRegIntfs[Index].Documentation := D
&&& FRegIntfs[Index].ExtName := ExtN
&&& FRegIntfs[Index].WSDLEncoding := WSDLE
&&& 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
&&&&& FRegIntfs[Index].Namespace := N
&&&&& FRegIntfs[Index].InvokeOptions := FRegIntfs[Index].InvokeOptions + [ioHasNamespace];
&&& if FRegIntfs[Index].DefImpl = nil then
&&&&& { NOTE: First class that implements this interface wins!! }
&&&&& for I := 0 to Length(FRegClasses) - 1 do
&&&&& begin
&&&&&&& Table :=&FRegClasses[I].ClassType.GetInterfaceT
&&&&&&& if (Table = nil) then
&&&&&&& begin
&&&&&&&&& Table := FRegClasses[I].ClassType.ClassParent.GetInterfaceT
&&&&&&& for J := 0 to Table.EntryCount - 1 do
&&&&&&& begin
&&&&&&&&& if IsEqualGUID(IntfMD.IID, Table.Entries[J].IID) then
&&&&&&&&& begin
&&&&&&&&&&& FRegIntfs[Index].DefImpl := FRegClasses[I].ClassT
&&&&&&&&&&& E
for I := 0 to Length(FRegIntfs) - 1 do
&&&&& if FRegIntfs[I].Info = Info then
遍历FRegIntfs: array of InvRegIntfE数组，根据TypeInfo信息判断该接口是否已注册。
Index := Length(FRegIntfs);
SetLength(FRegIntfs, Index + 1);
新增一个数组元素。
GetIntfMetaData(Info, IntfMD, True);
//得到接口的RTTL信息，然后动态增加到注册的动态数组中。
&&& FRegIntfs[Index].GUID := IntfMD.IID;
&&& FRegIntfs[Index].Info := I
&&& FRegIntfs[Index].Name := IntfMD.N
&&& FRegIntfs[Index].UnitName := IntfMD.UnitN
&&& FRegIntfs[Index].Documentation := D
&&& FRegIntfs[Index].ExtName := ExtN
FRegIntfs[Index].WSDLEncoding := WSDLE
DefImpl里存放的是classType信息：
if FRegIntfs[Index].DefImpl = nil then
&&&&& for I := 0 to Length(FRegClasses) - 1 do
&&&&& begin
&&&&&&& Table :=&FRegClasses[I].ClassType.GetInterfaceT
&&&&&&& if (Table = nil) then
&&&&&&& begin
&&&&&&&&& Table := FRegClasses[I].ClassType.ClassParent.GetInterfaceT
&&&&&&& for J := 0 to Table.EntryCount - 1 do
&&&&&&& begin
&&&&&&&&& if IsEqualGUID(IntfMD.IID, Table.Entries[J].IID) then
&&&&&&&&& begin
&&&&&&&&&&& FRegIntfs[Index].DefImpl := FRegClasses[I].ClassT
&&&&&&&&&&& E
&&&& &&&&&
注意这里：
FRegClasses: array of InvRegClassE
到注册类的动态数组中去搜寻接口的实现类是否注册，如果注册，便把实现类的指针拷贝到DefImpl数据字段。
顺便看一下类是怎么注册的：
procedure TInvokableClassRegistry.RegisterInvokableClass(AClass: TC CreateProc: TCreateInstanceProc);
&Index, I, J: I
&Table: PInterfaceT
Table := AClass.GetInterfaceT
&&&&&。。。。。。
&&& Index := Length(FRegClasses);
&&& SetLength(FRegClasses, Index + 1);
&&& FRegClasses[Index].ClassType := AC
&&& FRegClasses[Index].Proc := CreateP
&&& for I := 0 to Table.EntryCount - 1 do
&&&&& 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 := AC
可以看到和注册接口非常相似。在调用上面方法时，会传入实现类的指针及factory函数指针，调用GetInterfaceTable判断是否实现接口。否则为NIL， 然后在FregClasses增加一元素，把值写入。最后再到FregIntfs是搜寻此实现类的接口是否已经注册。是的话，就把指针储存在FRegIntfs[J].DefImpl中。
InvRegistry.RegisterDefaultSOAPAction(TypeInfo(IMyFirstWS), 'urn:MyFirstWSIntf-IMyFirstWS#%operationName%');
procedure TInvokableClassRegistry.RegisterDefaultSOAPAction(Info: PTypeI const DefSOAPAction: InvString);
&&& I := GetIntfIndex(Info);
&&& if I &= 0 then
FRegIntfs[I].SOAPAction := DefSOAPA&
//值为：urn:MyFirstWSIntf-IMyFirstWS#%operationName
&&&&& FRegIntfs[I].InvokeOptions := FRegIntfs[I].InvokeOptions + [ioHasDefaultSOAPAction];
设置接口的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);
&inherited Create(AOwner);
&{ Converter }
&&FDomConverter := GetDefaultC
&FConverter := FDomConverter as IOPC
&{ WebNode }
&FHTTPWebNode := GetDefaultWebN
&FWebNode := FHTTPWebNode as IWebN
继续到父类中TRIO查看相应代码：
constructor TRIO.Create(AOwner: TComponent);
&inherited Create(AOwner);
&FInterfaceBound := F
&FContext := TInvContext.C
&FSOAPHeaders := TSOAPHeaders.Create(Self);
&FHeadersInbound := THeaderList.C
&FHeadersOutBound:= THeaderList.C
&FHeadersOutbound.OwnsObjects := F
&(FSOAPHeaders as IHeadersSetter).SetHeadersInOut(FHeadersInbound, FHeadersOutBound);
创建了TinvContext，这个对象是用来创建一个和服务器端一样的调用环境。
客户端的参数信息一个个的填入这个环境中。
创建一个TSOAPHeaders头对象。
constructor THTTPRIO.Create(AOwner: TComponent);
&inherited Create(AOwner);
&{ Converter }
&FDomConverter := GetDefaultC
&FConverter := FDomConverter as IOPC
&{ WebNode }
&FHTTPWebNode := GetDefaultWebN
&FWebNode := FHTTPWebNode as IWebN
function THTTPRIO.GetDefaultConverter: TOPToSoapDomC
&if (FDefaultConverter = nil) then
&&& FDefaultConverter := TOPToSoapDomConvert.Create(Self);
&&& FDefaultConverter.Name := 'Converter1';&&&&&&&&&&&&&&&& { do not localize }
&&& FDefaultConverter.SetSubComponent(True);
&Result := FDefaultC
而TOPToSoapDomConvert可以把Object Pascal的呼叫和參數自動轉換為SOAP封裝的格式資訊，再藉由THTTPReqResp傳送HTTP封包。
function THTTPRIO.GetDefaultWebNode: THTTPReqR
&if (FDefaultWebNode = nil) then
&&& FDefaultWebNode := THTTPReqResp.Create(Self);
&&& FDefaultWebNode.Name := 'HTTPWebNode1';&&&&&&&&&&&&&&& { do not localize }
&&& FDefaultWebNode.SetSubComponent(True);
&Result := FDefaultWebN
//用来传送HTTP的封包。
function THTTPRIO.GetDefaultConverter: TOPToSoapDomC
&if (FDefaultConverter = nil) then
&&& FDefaultConverter := TOPToSoapDomConvert.Create(Self);
&&& FDefaultConverter.Name := 'Converter1';&&&&&&&&&&&&&&&& { do not localize }
&&& FDefaultConverter.SetSubComponent(True);
&Result := FDefaultC
FHTTPWebNode := GetDefaultWebN
function THTTPRIO.GetDefaultWebNode: THTTPReqR
&if (FDefaultWebNode = nil) then
&&& FDefaultWebNode := THTTPReqResp.Create(Self);
&&& FDefaultWebNode.Name := 'HTTPWebNode1';&&&&&&&&&&&&&&& { do not localize }
&&& FDefaultWebNode.SetSubComponent(True);
&Result := FDefaultWebN
创建了一个THTTPReqResp，用于HTTP通信。
MyHTTPRIO.URL :='http://localhost/soap/MyCGI.exe/soap/IMyFirstWS';
procedure THTTPRIO.SetURL(Value: string);
&if Assigned(FHTTPWebNode) then
&&& FHTTPWebNode.URL := V
&&& if Value && '' then
&&&&& WSDLLocation := '';
&&&&& ClearDependentWSDLV
procedure THTTPReqResp.SetURL(const Value: string);
&if Value && '' then
&&& FUserSetURL := True
&&& FUserSetURL := F
&InitURL(Value);
&Connect(False);
procedure THTTPReqResp.InitURL(const Value: string);
&&& InternetCrackUrl(P, 0, 0, URLComp);
&&& FURLScheme := URLComp.nS
&&& FURLPort := URLComp.nP
&&& FURLHost := Copy(Value, URLComp.lpszHostName - P + 1, URLComp.dwHostNameLength);
&FURL := V
设置THTTPReqResp的属性。和HTTP服务器通信。
procedure THTTPReqResp.Connect(Value: Boolean);
if Assigned(FInetConnect) then
&&&&& InternetCloseHandle(FInetConnect);
&&& FInetConnect :=
&&& if Assigned(FInetRoot) then
&&&&& InternetCloseHandle(FInetRoot);
&&& FInetRoot :=
FConnected := F
Value 为FLASE。
ShowMessage(( MyHTTPRIO As IMyFirstWS ).GetObj);
利用AS转换成webservice的接口。用转换后的接口到客户端的InvRegInftEntry表格中搜寻WEBSERVICE服务接口，根据RTTL生成SOAP封包。
procedure _IntfCast(var Dest: II const Source: II const IID: TGUID);
先看这一句：CALL&&& DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface
function THTTPRIO.QueryInterface(const IID: TGUID; out Obj): HR
&UDDIOperator, UDDIBindingKey:
&Result := inherited QueryInterface(IID, Obj);
&if Result = 0 then
&&& if IsEqualGUID(IID, FIID) then
&&&&& FHTTPWebNode.SoapAction := InvRegistry.GetActionURIOfIID(IID);
&&&&& if InvRegistry.GetUDDIInfo(IID, UDDIOperator, UDDIBindingKey) then
&&&&& begin
&&&&&&& FHTTPWebNode.UDDIOperator := UDDIO
&&&&&&& FHTTPWebNode.UDDIBindingKey := UDDIBindingK
Result := inherited QueryInterface(IID, Obj);//跟踪一下这一句：
这句比较重要，要重点分析。
这里创建了虚拟表格。
function TRIO.QueryInterface(const IID: TGUID; out Obj): HR
&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
&&&&& Result := 0;
&&&&& FInterfaceBound := T
&&&&& Pointer(Obj) := IntfTableP;
&&&&& InterlockedIncrement(FRefCount);
看看GenVTable函数：
function TRIO.GenVTable(const IID: TGUID): B
Info := InvRegistry.GetInterfaceTypeInfo(IID);
这个函数是去到TinvokableClassRegistry中搜寻该接口是否注册，注册过的接口则返回typeinfo信息赋给指针。
function TInvokableClassRegistry.GetInterfaceTypeInfo(const AGUID: TGUID): P
&Result :=
&&& for I := 0 to Length(FRegIntfs) - 1 do
&&&&& if IsEqualGUID(AGUID, FRegIntfs[I].GUID) then
&&&&& begin
&&&&&&& Result := FRegIntfs[I].I
继续：通过infotype得到RTTL信息。
&&& GetIntfMetaData(Info, IntfMD, True);
&&& HasRTTI := F
&TObjFunc = function: Integer of O&
&TQIFunc =&function(const IID: TGUID; out Obj): HR
&PProc = ^TP
TCracker = record
&&& case integer of
&&&&& 0: (Fn: TProc);
&&&&& 1: (Ptr: Pointer);
&&&&& 2: (ObjFn: TObjFunc);
&&&&& 3: (QIFn: TQIFunc);
&Crack.Fn := GenericS
&StubAddr := Crack.P
&地址指向函数TRIO.GenericStub函数。
Crack.Fn结构的指针指向
这段代码的意思是用C/stdcall等方式调用函数。
从左到右，从右到左压入堆栈。调整TRIO.IntfTable的指针,最后调用TRIO.Generic
procedure TRIO.GenericS
&&&&&&& 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 }
&&&&&&& SUB&&&& EAX, OFFSET TRIO.IntfT&{ Adjust intf pointer to object pointer }
&&&&&&& JMP&&&& TRIO.Generic
&Crack.Fn := ErrorE
&ErrorStubAddr := Crack.P
//首先分配vtable空间，接口数加3， 因为有Iunknown接口。
&GetMem(IntfTable, (Length(IntfMD.MDA) + NumEntriesInIInterface) * 4);
&IntfTableP := @IntfT
&然后把地址赋给IntfTableP变量
&GetMem(IntfStubs, (Length( IntfMD.MDA) + NumEntriesInIInterface) * StubSize );
&分配存根接口空间。
&这是解释&
IntfTable: P&&&&&&&&&&&& { Generated vtable for the object&& }
&&& IntfTableP: P&&&&&&&&&&& { Pointer to the generated vtable&& }
&&& IntfStubs: P&&&&&&&&&&&& { Pointer to generated vtable thunks}
//Load the IUnknown vtable 分配指针，加入三个接口Iunknown
&VTable := PPointer(IntfTable);
&Crack.QIFn := _QIFromI
&QI查询指针赋值给 Crack结构体
&VTable^ := Crack.P 赋给VT指针
&IncPtr(VTable, 4);&&&&增加一个指针。
&Crack.ObjFn := _AddRefFromI
&VTable^ := Crack.P
&IncPtr(VTable, 4);
&Crack.ObjFn := _ReleaseFromI
&VTable^ := Crack.P
&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
&&& CallStubIdx := 0;
&&& if not IntfMD.MDA[I].HasRTTI then
&&&&& GenByte($FF);&{ FF15xxxxxxxx Call [mem]&&& }
&&&&& GenByte($15);
&&&&& Crack.Fn := ErrorE
&&&&& GenDWORD(LongWord(@ErrorStubAddr));
&&& end else
&&&&& { PUSH the method ID }
&&&&& GenPushI(I);&
//定位这里：看看函数做了什么：
CallStub: array[0..StubSize-1] of B
I=3。CallStubIdx=2
procedure TRIO.GenPushI(I: Integer);
&if I & 128 then
&&& CallStub[CallStubIdx] := $6A;
&&& CallStub[CallStubIdx + 1] := I;
&&& Inc(CallStubIdx, 2);
&&& CallStub[CallStubIdx] := $68;
&&& PInteger(@CallStub[CallStubIdx + 1])^ := I;
&&& Inc(CallStubIdx, 5);
登记函数调用信息, 数组增加一元素。
遍历接口信息，函数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);
&&&&& 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. }
&&&&&&& GenR
&&&&& 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 ));
//每个参数分配空间。
&&&&&&& 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);
//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
&&&&& P^ := CallStub[J];
&&&&& IncPtr(P);
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
&&&&& P^ := $CC;
&&&&& IncPtr(P);
增加Thunk指向存根相应调用信息：
&&& { Finally, put the new thunk entry into the vtable slot.&}
&&& VTable^ := T
IncPtr(VTable, 4);
把thunk指针赋给vtable之后，压入堆栈。
IncPtr(Thunk, StubSize);
把存根相应调用信息压入堆栈。
然后继续下一个函数的相应操作。
procedure IncPtr(var P; I: Integer = 1);
&&&&&&& ADD&&&& [EAX], EDX
总结一下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: PTypeI var Operator, BindingKey: string): B
procedure _IntfCast(var Dest: II const Source: II const IID: TGUID);
这里，继续：
procedure TRIO.GenericS
JMP&&&& TRIO.Generic
//这里是最重要的地方：这个函数完成了。打包，传递，并返回服务器端结果。我们仔细研究一下。
function TRIO.Generic(CallID: I Params: Pointer): Int64;
MethMD := IntfMD.MDA[CallID];&//得到方法相应的属性。
FContext.SetMethodInfo(MethMD);&// FContext 产生虚拟的表函数表格。
procedure TInvContext.SetMethodInfo(const MD: TIntfMethEntry);
&SetLength(DataP, MD.ParamCount + 1);
&SetLength(Data, (MD.ParamCount + 1) * MAXINLINESIZE);
if MethMd.CC && ccSafeCall then
&&& if RetOnStack(MethMD.ResultInfo) then
&&&&& 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 else
&&&&& RetP := @R
&&& FContext.SetResultPointer(RetP);
//把相应的返回信息压入Fcontext中。
for&J := 0 to&MethMD.ParamCount - 1 do
&&& FContext.SetParamPointer(ParamIdx, P);
&&& with MethMD.Params[J] do
&&&&& 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!! }
&&&&& else if IsParamByRef(Flags, Info, MethMD.CC) then
&&&&&&& IncPtr(P, 4)
&&&&& else
&&&&&&& IncPtr(P, GetStackTypeSize(Info, MethMD.CC));
&&& Inc(ParamIdx, LeftRightOrder);
//把相应的参数压入Fcontext中。
//转换成XML封包，并写入流中，这里就是具体打包的地方：
大家看清楚了：
Req := FConverter.InvContextToMsg(IntfMD, MethNum, FContext, FHeadersOutBound);
现在来好好研究一下它是怎么转换成XML封包的。
function TOPToSoapDomConvert.InvContextToMsg(const IntfMD: TIntfMetaD MethNum: I
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&Con: TInvC Headers: THeaderList): TS
MethMD := IntfMD.MDA[MethNum];
首先得到方法的动态信息。
XMLDoc := NewXMLD&看看这句：
function TOPToSoapDomConvert.NewXMLDocument: IXMLD
&Result := XMLDoc.NewXMLD
&Result.Options := Result.Options + [doNodeAutoIndent];
&Result.ParseOptions := Result.ParseOptions + [poPreserveWhiteSpace];
function NewXMLDocument(Version: DOMString = '1.0'): IXMLD
&Result := TXMLDocument.Create(nil);
&Result.Active := T
&if Version && '' then
&&& Result.Version := V
创建了一个TXMLDocument对象用于读写XML。
procedure TXMLDocument.SetActive(const Value: Boolean);
&&&&& CheckDOM;
&&&&& FDOMDocument := DOMImplementation.createDocument('', '', nil);
&&&&&&& LoadD
&&&&& except
&&&&&&& ReleaseDoc(False);
&&&&& DoAfterO
&&&&& DoBeforeC
&&&&& ReleaseD
&&&&& DoAfterC
procedure TXMLDocument.CheckDOM;
&if not Assigned(FDOMImplementation) then
&&& if Assigned(FDOMVendor) then
&&&&& FDOMImplementation := FDOMVendor.DOMImplementation
&&&&& FDOMImplementation := GetDOM(DefaultDOMVendor);
在TXMLDocument内部使用了Abstract Factory模式
Abstract Factory希望不用指定具体的类，但为了找到它们，在TXMLDocument是通过指定一个字符串，也就是我们点击DOMVendor时出现的哪几个字符串．
GetDOM函数如下：
Result := GetDOMVendor(VendorDesc).DOMI
//根据传递进去的名字，创建相应在的实例：
function GetDOMVendor(VendorDesc: string): TDOMV
&if VendorDesc = '' then
&&& VendorDesc := DefaultDOMV
&if (VendorDesc = '') and (DOMVendorList.Count & 0) then
&&& Result := DOMVendorList[0]
&&& Result := DOMVendorList.Find(VendorDesc);
&if not Assigned(Result) then
&&&raise Exception.CreateFmt(SNoMatchingDOMVendor, [VendorDesc]);
最后取得一个IDOMImplementation，它有一个createDocument（&.）:IDOMD函数，这个函数将返回一个IDOMD接口让IXMLDoucment使用。
//由此可见，默认状态下是创建DOM，微软的XML解析器。
function DOMVendorList: TDOMVendorL
&if not Assigned(DOMVendors) then
&&& DOMVendors := TDOMVendorList.C
&Result := DOMV
function TDOMVendorList.GetVendors(Index: Integer): TDOMV
&Result := FVendors[Index];
如果为空，就返回默认的。
function TMSDOMImplementationFactory.DOMImplementation: IDOMI
&Result := TMSDOMImplementation.Create(nil);
再返回到函数：
procedure TXMLDocument.SetActive(const Value: Boolean);
&FDOMDocument := DOMImplementation.createDocument('', '', nil);
function TMSDOMImplementation.createDocument(const namespaceURI,
&qualifiedName: DOMS doctype: IDOMDocumentType): IDOMD
&Result := TMSDOMDocument.Create(MSXMLDOMDocumentCreate);
在如果使用MSXML,接口对应的是TMSDOMDocument，TMSDOMDocument是实际上是调用MSXML技术，下面是调用MS COM的代码
function CreateDOMDocument: IXMLDOMD
&Result := TryObjectCreate([CLASS_DOMDocument40, CLASS_DOMDocument30,
&&& CLASS_DOMDocument26, msxml.CLASS_DOMDocument]) as IXMLDOMD
&if not Assigned(Result) then
&&& raise DOMException.Create(SMSDOMNotInstalled);
再返回到函数：
procedure TXMLDocument.SetActive(const Value: Boolean);
//因为是新建的TXMLDocument，所以装内空数据,立即返回。
procedure TXMLDocument.LoadD
&UnicodeEncodings: array[0..2] of string = ('UTF-16', 'UCS-2', 'UNICODE');
&Status: B
&ParseError: IDOMParseE
&StringStream: TStringS
Status := T { No load, just create empty doc. }
创建空的文档：
&if not Status then
&&& DocSource := xdsN
&&& ParseError := DOMDocument as IDOMParseE
&&& 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);
&SetModified(False);
设置不能修改。因为空文档。
继续返回到
function NewXMLDocument(Version: DOMString = '1.0'): IXMLD
&if Version && '' then
&&& Result.Version := V
procedure TXMLDocument.SetVersion(const Value: DOMString);
&SetPrologValue(Value, xpVersion);
procedure TXMLDocument.SetPrologValue(const Value: V
&&& PrologNode := GetPrologN
&&& PrologAttrs := InternalSetPrologValue(PrologNode, Value, PrologItem);
&&& NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);
&&& if Assigned(PrologNode) then
&&&&& Node.ChildNodes.ReplaceNode(PrologNode, NewPrologNode)
&&&&& ChildNodes.Insert(0, NewPrologNode);
NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);
这句调用了：
function TXMLDocument.CreateNode(const NameOrData: DOMS
&NodeType: TNodeType = ntE const AddlData: DOMString = ''): IXMLN
&Result := TXMLNode.Create(CreateDOMNode(FDOMDocument, NameOrData,
&&& NodeType, AddlData), nil, Self);
在返回到这个函数中：
function TOPToSoapDomConvert.InvContextToMsg(const IntfMD: TIntfMetaD MethNum: I
&&&&&&&&&&&&&&&&&&&& &&&&&&&&&&&&&&&&&&&&&&&&Con: TInvC Headers: THeaderList): TS
BodyNode := Envelope.MakeBody(EnvNode);
if not (soLiteralParams in Options) then
&&& SoapMethNS := GetSoapNS(IntfMD);
&&& ExtMethName := InvRegistry., MethMD.Name)；
//创建一个SOAP的body:
function TSoapEnvelope.MakeBody(ParentNode: IXMLNode): IXMLN
&& Result := ParentNode.AddChild(SSoapNameSpacePre + ':' + SSoapBody, SSoapNameSpace);
SoapMethNS := GetSoapNS(IntfMD);&返回：'urn:MyFirstWSIntf-IMyFirstWS'
ExtMethName := InvRegistry., MethMD.Name);
得到调用方法名。剩下的部分就是把参数打包。生成SOAP的源文件。然后写到内存流中。
再回到函数中：InvContextToMsg
&Result := TMemoryStream.Create();
&DOMToStream(XMLDoc, Result);
把内存块的数据，转化成XML。
具体的函数如下：
procedure TOPToSoapDomConvert.DOMToStream(const XMLDoc: IXMLD Stream: TStream);
&XMLWString: WideS
&StrStr: TStringS
&& if (FEncoding = '') or (soUTF8EncodeXML in Options) then
&&& XMLDoc.SaveToXML(XMLWString);
&&& StrStr := TStringStream.Create(UTF8Encode(XMLWString));
&&&&& Stream.CopyFrom(StrStr, 0);
&&& finally
&&&&& StrStr.F
&&& XMLDoc.SaveToStream(Stream);
我们跟踪之后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
FWebNode.BeforeExecute(IntfMD, MethMD, MethNum-3, nil);
THTTPReqResp.BeforeExecute
。。。。。
MethName := InvRegistry., MethMD.Name);
FSoapAction := InvRegistry., MethName, MethodIndex);
得到方法名和FsoapAction
FBindingType := btSOAP
DoBeforeExecute&// TRIO.
if Assigned(FOnBeforeExecute) then
Resp := GetResponseStream(RespBindingType);
继续返回到TRIO.Generic函数中执行：
&& FWebNode.Execute(Req, Resp);
比较重要的部分：
这个函数就是THTTPReqResp向IIS发出请求。并返回信息：
procedure THTTPReqResp.Execute(const Request: TS Response: TStream);
&&& Context := Send(Request);
&&&&&& &Receive(Context, Response);
&&&&& except
&&&&&&& on Ex: ESOAPHTTPException do
&&&&&&& begin
&&&&&&&&& Connect(False);
&&&&&&&&& if not CanRetry or not IsErrorStatusCode(Ex.StatusCode) then
&&&&&&&&&&&
&&&&&&&&& { Trigger UDDI Lookup }
&&&&&&&&& LookUpUDDI := T
&&&&&&&&& PrevError := Ex.M
&&&&&&& else
&&&&&&& begin
&&&&&&&&& Connect(False);
&&& finally
&&&&& if Context && 0&then
&&&&&&& InternetCloseHandle(Pointer(Context));
现在看看Send函数，看看到底如何发送数据给WEB服务器的。
function THTTPReqResp.Send(const ASrc: TStream): I
&Request: HINTERNET;
&RetVal, Flags: DW
&ActionHeader:
&ContentHeader:
&BuffSize, Len: I
&INBuffer: INTERNET_BUFFERS;
&Buffer: TMemoryS
&StrStr: TStringS
&{ Connect }
&Connect(True);
&Flags := INTERNET_FLAG_KEEP_CONNECTION or INTERNET_FLAG_NO_CACHE_WRITE;
&if FURLScheme = INTERNET_SCHEME_HTTPS then
&&& 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);
&Request :=
&&& 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
&&&&& 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:= GetSOAPActionH
&&&&&& &HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
&&& end else { Assume btSOAP }
&&&&& { SOAPAction header }
&&&&& if not (soNoSOAPActionHeader in FInvokeOptions) then
&&&&& begin
&&&&& &&ActionHeader:= GetSOAPActionH
&&&&&&& HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
&&&&& if UseUTF8InHeader then
&&&&&&& ContentHeader := Format(ContentTypeTemplate, [ContentTypeUTF8])
&&&&& else
&&&&&&& ContentHeader := Format(ContentTypeTemplate, [ContentTypeNoUTF8]);
&&& { 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.S
&&& if BuffSize & FMaxSinglePostSize then
&&&&& Buffer := TMemoryStream.C
&&&&&&& Buffer.SetSize(FMaxSinglePostSize);
&&&&&&& { Init Input Buffer }
&&&&&&& INBuffer.dwStructSize := SizeOf(INBuffer);
&&&&&&& INBuffer.Next :=
&&&&&&& INBuffer.lpcszHeader :=
&&&&&&& INBuffer.dwHeadersLength := 0;
&&&&&&& INBuffer.dwHeadersTotal := 0;
&&&&&&& INBuffer.lpvBuffer :=
&&&&&&& INBuffer.dwBufferLength := 0;
&&&&&&& INBuffer.dwBufferTotal := BuffS
&&&&&&& 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.P
&&&&&&&&&&& if Len & FMaxSinglePostSize then
&&&&&&&&&&&&& Len := FMaxSinglePostS
&&&&&&&&&&& { Bail out if zip.. }
&&&&&&&&&&& if Len = 0 then
&&&&&&&&&&&&&
&&&&&&&&&&& { 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.A
&&&&&&&&&&&&& ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
&&&&&&&&&&&
&&&&&&&&&&& { Posting Data Event }
&&&&&&&&&&& if Assigned(FOnPostingData) then
&&&&&&&&&&&&& FOnPostingData(ASrc.Position, BuffSize);
&&&&&&& finally
&&&&&&&&& Check(not HttpEndRequest(Request, nil, 0, 0));
&&&&& finally
&&&&&&& Buffer.F
&&& end else
&&&&& StrStr := TStringStream.Create('');
&&&&&&& 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:
&&&&&&&&&&& ERROR_CANCELLED: SysUtils.A
&&&&&&&&&&& ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
&&&&& finally
&&&&&&& StrStr.F
&&& if (Request && nil) then
&&&&& InternetCloseHandle(Request);
&&& Connect(False);
&Result := Integer(Request);
function THTTPReqResp.Send(const ASrc: TStream): I
先调用了：
procedure THTTPReqResp.Connect(Value: Boolean);
if InternetAttemptConnect(0) && ERROR_SUCCESS then
&&&&& SysUtils.A
这个函数可以说非常简单，只是尝试计算机连接到网络。
FInetRoot := InternetOpen(PChar(FAgent), AccessType, PChar(FProxy), PChar(FProxyByPass), 0);
创建HINTERNET句柄，并初始化WinInet的API函数：
Check(not Assigned(FInetRoot));
&&&&& FInetConnect := InternetConnect(FInetRoot, PChar(FURLHost), FURLPort, PChar(FUserName),
&&&&&&& PChar(FPassword), INTERNET_SERVICE_HTTP, 0, Cardinal(Self));
&&& //创建一个特定的会话：
&&&&& Check(not Assigned(FInetConnect));
&&&&& FConnected := T
&&& except
&&&&& InternetCloseHandle(FInetRoot);
&&&&& FInetRoot :=
这里已经创建了一个会话：
继续返回function THTTPReqResp.Send(const ASrc: TStream): I函数之中：
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:= GetSOAPActionH
&&&&&&& HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
为请求添加一个或多个标头。可以看到标点的信息为：
'SOAPAction: "urn:MyFirstWSIntf-IMyFirstWS#GetObj"'
HttpAddRequestHeaders(Request, PChar(ContentHeader), Length(ContentHeader), HTTP_ADDREQ_FLAG_ADD);
继续加入标头'Content-Type: text/xml'信息：
&&&&& StrStr := TStringStream.Create('');
&&&&&&& 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): TS
Receive(Context, Response);
procedure&THTTPReqResp.Receive(Context: I Resp: TS IsGet: Boolean);
&Size, Downloaded, Status, Len, Index: DW
//获取请求信息：
&HttpQueryInfo(Pointer(Context), HTTP_QUERY_CONTENT_TYPE, @FContentType[1], Size, Index);
&&& Check(not InternetQueryDataAvailable(Pointer(Context), Size, 0, 0));
&&& if Size & 0 then
&&&&& 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)
&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: I Params: Pointer): Int64;函数中继续查看：
RespXML := R
返回信息的内存流
FConverter.ProcessResponse(RespXML, IntfMD, MethMD, FContext, FHeadersInbound);
再次把SOAP封包转换成PASCEL调用：
procedure TOPToSoapDomConvert.ProcessResponse(const Resp: TS
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& const IntfMD: TIntfMetaD
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& const MD: TIntfMethE
&&&&&&&&&&&&&&&&&& &&&&&&&&&&&&&&&&&&&&&&&&&&&Context: TInvC
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& Headers: THeaderList);
&XMLDoc: IXMLD
&XMLDoc := NewXMLD
&XMLDoc.Encoding := FE
&Resp.Position := 0;
&XMLDoc.LoadFromStream(Resp);
&ProcessResponse(XMLDoc, IntfMD, MD, Context, Headers);
procedure TOPToSoapDomConvert.ProcessResponse(const XMLDoc: IXMLD
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& const IntfMD: TIntfMetaD
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& &&&&&&&&&&&const MD: TIntfMethE
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& Context: TInvC
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& Headers: THeaderList);
&ProcessSuccess(RespNode, IntfMD, MD, Context);
ProcessSuccess函数如下：
&for I := 0 to RespNode.childNodes.Count - 1 do
&&&&& Node := RespNode.childNodes[I];
&&&&& { Skip non-valid nodes }
&&&&& if Node.NodeType && ntElement then
// 处理返回值：
&&&&& if I = RetIndex then
&&&&& begin
&&&&&&& InvData := InvContext.GetResultP
&&&&&&& ByRef := IsParamByRef([pfOut], MD.ResultInfo, MD.CC);
&&&&&&& ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);
ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);
把SOAP的结果，写入返回区地址空间。
procedure TSOAPDomConv.ConvertSoapToNativeData(DataP: P TypeInfo: PTypeI
&Context: TDataC RootNode, Node: IXMLN Translate, ByRef: B
&NumIndirect: Integer);
&TypeUri, TypeName: InvS
&IsNull: B
&Node := GetDataNode(RootNode, Node, ID);
&IsNull := NodeIsNull(Node);
&if TypeInfo.Kind = tkVariant then
&&& if NumIndirect & 1 then
&&&&& DataP := Pointer(PInteger(DataP)^);
&&& if IsNull then
&&&&& Variant(PVarData(DataP)^) := NULL;
&&& end else
&&&&& ConvertSoapToVariant(Node, DataP);
&if TypeInfo.Kind = tkDynArray then
&&& 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
&&&&& DataP := Pointer(PInteger(DataP)^);
&&&&& PInteger(DataP)^ := Integer(P);
&if TypeInfo.Kind = tkClass then
&&& Obj := ConvertSOAPToObject(RootNode, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, NumIndirect);
&&& if NumIndirect = 1 then
&&&&& PTObject(DataP)^ := Obj
&&&else if NumIndirect = 2 then
&&&&& DataP := Pointer(PInteger(DataP)^);
&&&&& PTObject(DataP)^ := O
&&& if Translate then
&&&&& if NumIndirect & 1 then
&&&&&&& DataP := Pointer(PInteger(DataP)^);
&&&&& if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, IsNull) then
&&&&&&& raise ESOAPDomConvertError.CreateFmt(STypeMismatchInParam, [node.nodeName]);
作为整型数据，处理方式为：
if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, IsNull) then
function&TTypeTranslator.CastSoapToNative(Info: PTypeI const SoapData: WideS NatData: P IsNull: Boolean): B
&ParamTypeData: PTypeD
&DecimalSeparator := '.';
&Result := T
&if IsNull and (Info.Kind = tkVariant) then
&&& Variant(PVarData(NatData)^) := NULL;
&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));
&&& 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));
&&&&&&& ftComp:
&&&&&&&&& PComp(NatData)^ := StrToFloatEx(Trim(SoapData));
&&&&&&& ftCurr:
&&&&&&&&& PCurrency(NatData)^ := StrToFloatEx(Trim(SoapData));
&&&&&&& ftExtended:
&&&&&&&&& PExtended(NatData)^ := StrToFloatEx(Trim(SoapData));
&&& tkWString:
&&&&& PWideString(NatData)^ := SoapD
&&& tkString:
&&&&& PShortString(NatData)^ := SoapD
&&& tkLString:
&&&&& PString(NatData)^ := SoapD
&&& 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- 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);
PWideString(NatData)^ := SoapD
通过把值赋给了相应的指针地址：
另外在看一下传对象时的情况：
Obj := ConvertSOAPToObject(RootNode, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, NumIndirect);
if Assigned(Obj) and&LegalRef then
&&&&& if (NodeClass && nil) and (NodeClass && Obj.ClassType) then
&&&&&&& Obj := NodeClass.C
&&& end else
&&& if (NodeClass && nil) and NodeClass.InheritsFrom(AClass) then
&&&&& Obj := TRemotableClass(NodeClass).Create
&&&&& Obj := TRemotableClass(AClass).C
Result := O
可以理解，经过双边注册过之后，才可以传递对象。
现在研究一下服务器端的代码：
先大概简单介绍一下WEB服务器应用程序的工作模式：
&这里的WEB服务器就是IIS。
也就是说WEB服务器会把客户的HTTP请求消息，传递给CGI程序。然后由CGI进行处理：
CGIApp单元中的：
procedure InitA
&Application := TCGIApplication.Create(nil);
//创建一个CGI的应用程序
constructor TWebApplication.Create(AOwner: TComponent);
&WebReq.WebRequestHandlerProc := WebRequestH
&inherited Create(AOwner);
&Classes.ApplicationHandleException := HandleE
&if IsLibrary then
&&& IsMultiThread := T
&&& OldDllProc := DLLP
&&& DLLProc := DLLExitP
&&& AddExitProc(DoneVCLApplication);
constructor TWebRequestHandler.Create(AOwner: TComponent);
&inherited Create(AOwner);
&FCriticalSection := TCriticalSection.C
&FActiveWebModules := TList.C
&FInactiveWebModules := TList.C
&FWebModuleFactories := TWebModuleFactoryList.C
&FMaxConnections := 32;
&FCacheConnections := T
procedure TCGIApplication.R
&HTTPRequest: TCGIR
&HTTPResponse: TCGIR
&inherited R
&if IsConsole then
&&& Rewrite(Output);
&&& Reset(Input);
&&& HTTPRequest := NewR
&&&&& HTTPResponse := NewResponse(HTTPRequest);
&&&&&&& HandleRequest(HTTPRequest, HTTPResponse);
&&&&& finally
&&&&&&& HTTPResponse.F
&&& finally
&&&&& HTTPRequest.F
&&& HandleServerException(ExceptObject, FOutputFileName);
HTTPResponse := NewResponse(HTTPRequest);
function TCGIApplication.GetFactory: TCGIF
&if not Assigned(FFactory) then
&&& FFactory := TCGIFactory.C
&Result := FF
function TCGIFactory.NewRequest: TCGIR
&&& Result := TCGIRequest.Create&&&
//创建TCGIRequest
HTTPResponse := NewResponse(HTTPRequest);
Result := TCGIResponse.Create(CGIRequest)
HandleRequest(HTTPRequest, HTTPResponse);调用
现在看看是怎么响应客户端的：
function TWebRequestHandler.HandleRequest(Request: TWebR
&Response: TWebResponse): B
&WebModules: TWebModuleL
&WebModule: TC
&WebAppServices: IWebAppS
&GetWebAppServices: IGetWebAppS
&Result := F
&WebModules := ActivateWebM
function TWebRequestHandler.ActivateWebModules: TWebModuleL
FWebModuleFactories.AddFactory(TDefaultWebModuleFactory.Create(WebModuleClass));
把TWebModule1加入工厂中,并创建TwebModuleList对象。
&&&&&&& if FWebModuleFactories.ItemCount & 0 then
&&&&&&& begin
&&&&&&&&& Result := TWebModuleList.Create(FWebModuleFactories);
&if Assigned(WebModules) then
WebModules.AutoCreateM
procedure TWebModuleList.AutoCreateModules
&.... AddModule(Factory.GetModule);
调用：TWebModule1.create并加入TwebModuleList中。
function TDefaultWebModuleFactory.GetModule: TC
&Result := FComponentClass.Create(nil);
constructor TWebModule.Create(AOwner: TComponent);调用
constructor TCustomWebDispatcher.Create(AOwner: TComponent);
之后又创建了THTTPSoapDispatcher，创建是在Treader类中创建的，有兴趣的朋友就追踪一下吧，这里实在是太麻烦。我也追了很久才发现。就懒得贴上来了。内容太多。
继续创建了TWSDLHTMLPublish
在回到TWebRequestHandler.HandleRequest函数中：
Result := WebAppServices.HandleR
最后调用了：
function TCustomWebDispatcher.HandleRequest(
&Request: TWebR Response: TWebResponse): B
&FRequest := R
&FResponse := R
&Result := DispatchAction(Request, Response);
注意HandleRequest函数，这里是关键部分：
function TCustomWebDispatcher.DispatchAction(Request: TWebR
&Response: TWebResponse): B
while not Result and (I & FDispatchList.Count) do
&&& if Supports(IInterface(FDispatchList.Items[I]), IWebDispatch, Dispatch) then
&&&&& Result := DispatchHandler(Self, Dispatch,
&&&&&&& Request, Response, False);
&&& Inc(I);
function DispatchHandler(Sender: TO Dispatch: IWebD Request: TWebR Response: TWebR
&DoDefault: Boolean): B
&Result := F
&if (Dispatch.Enabled and ((Dispatch.MethodType = mtAny) or
&&& (Dispatch.MethodType = Dispatch.MethodType)) and
&&& Dispatch.Mask.Matches(Request.InternalPathInfo)) then
&&& Result := Dispatch.DispatchRequest(Sender, Request, Response);
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: I& Component: TC& DispatchIntf: IWebDbegin& if AModule && nil then& & for I := 0 ponentCount - 1 do& & begin& & & Component := ponents[I];& & & if Supports(IInterface(Component), IWebDispatch, DispatchIntf) then& & & & FDispatchList.Add(Component);& &...& THTTPSoapDispatcher = class(THTTPSoapDispatchNode, IWebDispatch)&&因此Web Service程序的http请求处理实际上是由THTTPSoapDispatcher进行的。
我们接着看看THTTPSoapDispatcher.DispatchRequest方法中对SOAP协议的处理，关键代码如下function THTTPSoapDispatcher.DispatchRequest(Sender: TO
&Request: TWebR Response: TWebResponse): B
&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.PathI
XMLStream := TMemoryStream.C&//把客户端的请求流化。
ReqStream := TWebRequestStream.Create(Request);
创建一个响应的流信息,以例把结果返回客户端
RStream := TMemoryStream.C 创建返回信息的流。
&&&&&& 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: WideS const Request: TS
&&&&&&&&&&&&&&&&&&&&&&&&&& Response: TS var BindingType: TWebServiceBindingType);
父类实现的接口：
THTTPSoapDispatchNode = class(TComponent)
&&& procedure SetSoapDispatcher(const Value: IHTTPSoapDispatch);
&protected
&&& FSoapDispatcher: IHTTPSoapD
&&& procedure Notification(AComponent: TC Operation: TOperation);
&&& procedure DispatchSOAP(const Path, SoapAction: WideS const Request: TS
&&&&& Response: TStream);
&published
&&& property Dispatcher: IHTTPSoapDispatch read FSoapDispatcher write SetSoapD
也被THTTPSoapPascalInvoker实现。所以THTTPSoapDispatcher中的Dispatcher接口的实例其实是：THTTPSoapPascalInvoker
THTTPSoapPascalInvoker = class(TSoapPascalInvoker, IHTTPSoapDispatch)
&&& procedure DispatchSOAP(const Path, SoapAction: WideS const Request: TS
&&&&& &&&&&&&&&&&&&&&&&&&&&Response: TS var BindingType: TWebServiceBindingType);
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
相应于调用了：
procedure THTTPSoapPascalInvoker.DispatchSOAP(const Path, SoapAction: WideS const Request: TS
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& Response: TS var BindingType: TWebServiceBindingType);
&IntfInfo: PTypeI
&PascalBind: IHTTPSOAPToPasB
&InvClassType: TC
&ActionMeth: S
&&MD: TIntfMetaD
if not PascalBind.BindToPascalByPath(Path, InvClassType, IntfInfo, ActionMeth)&or (InvClassType = nil) then
function THTTPSOAPToPasBind.BindToPascalByPath(Path: S
&var AClass: TC var IntfInfo: PTypeI var AMeth: String): B
&Result := InvRegistry.GetInfoForURI(Path, '', AClass, IntfInfo, AMeth);
由InvRegistry的注册信息，返回相应的类名，接口信息等信息。
这了这些准备信息，下步才是真正的调用。
Invoke(InvClassType, IntfInfo, ActionMeth, Request, Response, BindingType);
函数最后一句：调用了父类：这里是真正工作的地方：
这里了仔细认真研究一下：
procedure TSoapPascalInvoker.Invoke(AClass: TC IntfInfo: PTypeI MethName: const Request: TS
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& Response: TS var BindingType: TWebServiceBindingType);
&Inv: TInterfaceI
&InvContext: TInvC
&IntfMD: TIntfMetaD
&MethNum: I
&SOAPHeaders: ISOAPH
&Handled: B
GetIntfMetaData(IntfInfo, IntfMD, True);&得到接口ＲＴＴＬ信息；
InvContext := TInvContext.C　　　　构造调用堆栈。
&& { Convert XML to Invoke Context }
&&&&&&&&& FConverter.MsgToInvContext(Request, IntfMD, MethNum, InvContext, FHeadersIn);
这个函数请见前面的参考InvContextToMsg, 把TinvContext内容转化成XML封包。
这个函数是逆操作，把XML内容转化成Context。
Obj := InvRegistry.GetInvokableObjectFromClass(AClass);
搜寻注册信息，创建实例：
&&&&&&&&&&& if Obj = nil then
raise Exception.CreateFmt(SNoClassRegistered, [IntfMD.Name]);
Inv := TInterfaceInvoker.C
Inv.Invoke(Obj, IntfMD, MethNum, InvContext);
真正调用的地方：
源代码为：
这段代码，就是根据对象，接口信息等，把ＣＯＮtext的信息压入相应参数，应调用。
有时间再仔细研究。
procedure TInterfaceInvoker.Invoke(const Obj: TO
&&&&& IntfMD: TIntfMetaD const MethNum: I
&&&&& const Context: TInvContext);
&MethPos: I
&IntfEntry: PInterfaceE
&IntfVTable: P
&RetIsOnStack, RetIsInFPU, RetInAXDX: B
&MD : TIntfMethE
&Temp, Temp1: I
&RetEAX: I
&RetEDX: I
&TotalParamBytes: I
&ParamBytes: I
{$IFDEF LINUX}
&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.VT&//指向VTB表的指针
&MethPos := MD.Pos * 4; { Pos is absolute to whole VMT } //定位
&if MD.ResultInfo && nil then
&&& RetIsInFPU := RetInFPU(MD.ResultInfo);
&&& RetIsOnStack := RetOnStack(MD.ResultInfo);
&&& RetInAXDX := IsRetInAXDX(MD.ResultInfo);
&&& RetP := Context.GetResultP&&&& //根据context& 得到返回参数的地址。
&&& RetIsOnStack := F
&&& RetIsInFPU := F
&&& RetInAXDX := F
&if MD.CC in [ccCDecl, ccStdCall, ccSafeCall] then
&&& if (MD.ResultInfo && nil) and (MD.CC = ccSafeCall) then
&&&&& asm PUSH DWORD PTR [RetP]&&& //把函数返回参数压入堆栈中。
&&& for I := MD.ParamCount - 1 downto 0 do&& //遍历参数。
&&&&& DataP := Context.GetParamPointer(I);&&& //指向一个参数地址：
&&&&& if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then&{基本类型}
&&&&&&& PUSH DWORD PTR [DataP]&&&&&& //压入堆栈。
&&&&& else
&&&&& begin
&&&&&&& ParamBytes := GetStackTypeSize(MD.Params[I].Info, MD.CC);&&& {特殊类型}
&&&&&&& PushStackParm(DataP, ParamBytes);
&&&&&&& Inc(TotalParamBytes, ParamBytes);
&&& asm PUSH DWORD PTR [Unk]&&&&&&&& //压入Iunknown指针
&&& if RetIsOnStack and (MD.CC && ccSafeCall) then
&&&&& asm PUSH DWORD PTR [RetP]
&else if MD.CC = ccPascal then
&&& for I := 0 to MD.ParamCount - 1 do
&&&&& DataP := Context.GetParamPointer(I);
&&&&& if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then
&&&&&&&& PUSH DWORD PTR [DataP]
&&&&& 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);
&&& if RetIsOnStack then
&&&&& asm PUSH DWORD PTR [RetP]
&&& asm PUSH DWORD PTR [Unk]
&&&& raise Exception.CreateFmt(SUnsupportedCC, [CallingConventionName[MD.CC]]);
&if MD.CC && ccSafeCall then
&&&&& 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]　　 //恢复寄存器ＥＣＸ
&&&&& 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]
&if MD.CC = ccCDecl then&/如果是ＣＣＤＥＣＬ方式，必须自己清除使用的堆栈。
&&& MOV EAX, DWORD PTR [TotalParamBytes]
&&& ADD ESP, EAX
//调用后，返回参数的处理：
&if MD.ResultInfo && nil then&
&&& if MD.CC && ccSafeCall then&//返回类型不为ccSafeCall时，必须进行处理。
&&&&& 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出栈&(先入后出)
{$IFDEF LINUX}
&&& // 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.
&&&&& MOV EAX, DWORD PTR [TotalParamBytes]
&&&&& ADD ESP, EAX
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
返回调用后的内存块为。
Response.ContentStream := RS
然后再发送给客户端。
到这里，基本上客户端和服务器端都进行了分析。
参考知识库
* 以上用户言论只代表其个人观点，不代表CSDN网站的观点或立场
访问：3270次
排名：千里之外