procedure TXMLDocument.CheckDOM;
begin
if not Assigned(FDOMImplementation) then
if Assigned(FDOMVendor) then
FDOMImplementation := FDOMVendor.DOMImplementation
else
FDOMImplementation := GetDOM(DefaultDOMVendor);
end;
在TXMLDocument内部使用了Abstract Factory模式
Abstract Factory希望不用指定具体的类，但为了找到它们，在TXMLDocument是通过指定一个字符串，也就是我们点击DOMVendor时出现的哪几个字符串．
GetDOM函数如下：
Result := GetDOMVendor(VendorDesc).DOMImplementation;
//根据传递进去的名字，创建相应在的实例：
function GetDOMVendor(VendorDesc: string): TDOMVendor;
begin
if VendorDesc = '' then
VendorDesc := DefaultDOMVendor;
if (VendorDesc = '') and (DOMVendorList.Count > 0) then
Result := DOMVendorList[0]
else
Result := DOMVendorList.Find(VendorDesc);
if not Assigned(Result) then
raise Exception.CreateFmt(SNoMatchingDOMVendor, [VendorDesc]);
end;
最后取得一个IDOMImplementation，它有一个createDocument（….）:IDOMDocument;函数，这个函数将返回一个IDOMDocument;接口让IXMLDoucment使用。
//由此可见，默认状态下是创建DOM，微软的XML解析器。
function DOMVendorList: TDOMVendorList;
begin
if not Assigned(DOMVendors) then
DOMVendors := TDOMVendorList.Create;
Result := DOMVendors;
end;
function TDOMVendorList.GetVendors(Index: Integer): TDOMVendor;
begin
Result := FVendors[Index];
end;
如果为空，就返回默认的。
function TMSDOMImplementationFactory.DOMImplementation: IDOMImplementation;
begin
Result := TMSDOMImplementation.Create(nil);
end;
再返回到函数：
procedure TXMLDocument.SetActive(const Value: Boolean);
FDOMDocument := DOMImplementation.createDocument('', '', nil);
继续：
function TMSDOMImplementation.createDocument(const namespaceURI,
qualifiedName: DOMString; doctype: IDOMDocumentType): IDOMDocument;
begin
Result := TMSDOMDocument.Create(MSXMLDOMDocumentCreate);
end;
在如果使用MSXML,接口对应的是TMSDOMDocument，TMSDOMDocument是实际上是调用MSXML技术，下面是调用MS COM的代码
function CreateDOMDocument: IXMLDOMDocument;
begin
Result := TryObjectCreate([CLASS_DOMDocument40, CLASS_DOMDocument30,
CLASS_DOMDocument26, msxml.CLASS_DOMDocument]) as IXMLDOMDocument;
if not Assigned(Result) then
raise DOMException.Create(SMSDOMNotInstalled);
end;
再返回到函数：
procedure TXMLDocument.SetActive(const Value: Boolean);
..
LoadData
//因为是新建的TXMLDocument，所以装内空数据,立即返回。
procedure TXMLDocument.LoadData;
const
UnicodeEncodings: array[0..2] of string = ('UTF-16', 'UCS-2', 'UNICODE');
var
Status: Boolean;
ParseError: IDOMParseError;
StringStream: TStringStream;
Msg: string;
begin
…
Status := True; { No load, just create empty doc. }
创建空的文档：
if not Status then
begin
DocSource := xdsNone;
ParseError := DOMDocument as IDOMParseError;
with ParseError do
Msg := Format('%s%s%s: %d%s%s', [Reason, SLineBreak, SLine,
Line, SLineBreak, Copy(SrcText, 1, 40)]);
raise EDOMParseError.Create(ParseError, Msg);
end;
SetModified(False);
end;
设置不能修改。因为空文档。
继续返回到
function NewXMLDocument(Version: DOMString = '1.0'): IXMLDocument;
begin
if Version <> '' then
Result.Version := Version;
end;
procedure TXMLDocument.SetVersion(const Value: DOMString);
begin
SetPrologValue(Value, xpVersion);
end;
procedure TXMLDocument.SetPrologValue(const Value: Variant;
….
PrologNode := GetPrologNode;
PrologAttrs := InternalSetPrologValue(PrologNode, Value, PrologItem);
NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);
if Assigned(PrologNode) then
Node.ChildNodes.ReplaceNode(PrologNode, NewPrologNode)
else
ChildNodes.Insert(0, NewPrologNode);
end;
NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);
这句调用了：
function TXMLDocument.CreateNode(const NameOrData: DOMString;
NodeType: TNodeType = ntElement; const AddlData: DOMString = ''): IXMLNode;
begin
Result := TXMLNode.Create(CreateDOMNode(FDOMDocument, NameOrData,
NodeType, AddlData), nil, Self);
end;
在返回到这个函数中：
function TOPToSoapDomConvert.InvContextToMsg(const IntfMD: TIntfMetaData; MethNum: Integer;
Con: TInvContext; Headers: THeaderList): TStream;
BodyNode := Envelope.MakeBody(EnvNode);
if not (soLiteralParams in Options) then
begin
SoapMethNS := GetSoapNS(IntfMD);
ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name)；
;;;;;
//创建一个SOAP的body:
function TSoapEnvelope.MakeBody(ParentNode: IXMLNode): IXMLNode;
begin
Result := ParentNode.AddChild(SSoapNameSpacePre + ':' + SSoapBody, SSoapNameSpace);
end;
SoapMethNS := GetSoapNS(IntfMD); 返回：'urn:MyFirstWSIntf-IMyFirstWS'
ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);
得到调用方法名。剩下的部分就是把参数打包。生成SOAP的源文件。然后写到内存流中。
再回到函数中：InvContextToMsg
Result := TMemoryStream.Create();
DOMToStream(XMLDoc, Result);
把内存块的数据，转化成XML。
具体的函数如下：
procedure TOPToSoapDomConvert.DOMToStream(const XMLDoc: IXMLDocument; Stream: TStream);
var
XMLWString: WideString;
StrStr: TStringStream;
begin
if (FEncoding = '') or (soUTF8EncodeXML in Options) then
begin
XMLDoc.SaveToXML(XMLWString);
StrStr := TStringStream.Create(UTF8Encode(XMLWString));
try
Stream.CopyFrom(StrStr, 0);
finally
StrStr.Free;
end;
end else
XMLDoc.SaveToStream(Stream);
end;
我们跟踪之后StrStr的结果如下：
'<?xml version="1.0"?>'#$D#$A'<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, MethMD, MethNum-3, nil);
THTTPReqResp.BeforeExecute
。。。。。
MethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);
FSoapAction := InvRegistry.GetActionURIOfInfo(IntfMD.Info, MethName, MethodIndex);
得到方法名和FsoapAction
FBindingType := btSOAP
DoBeforeExecute // TRIO.
if Assigned(FOnBeforeExecute) then
退出：
继续：
Resp := GetResponseStream(RespBindingType);
继续返回到TRIO.Generic函数中执行：
try
FWebNode.Execute(Req, Resp);
比较重要的部分：
这个函数就是THTTPReqResp向IIS发出请求。并返回信息：
procedure THTTPReqResp.Execute(const Request: TStream; Response: TStream);
begin
…
Context := Send(Request);
try
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,
nil, nil, Flags, 0{Integer(Self)});
Check(not Assigned(Request));
{ Timeouts }
if FConnectTimeout > 0 then
Check(InternetSetOption(Request, INTERNET_OPTION_CONNECT_TIMEOUT, Pointer(@FConnectTimeout), SizeOf(FConnectTimeout)));
if FSendTimeout > 0 then
Check(InternetSetOption(Request, INTERNET_OPTION_SEND_TIMEOUT, Pointer(@FSendTimeout), SizeOf(FSendTimeout)));
if FReceiveTimeout > 0 then
Check(InternetSetOption(Request, INTERNET_OPTION_RECEIVE_TIMEOUT, Pointer(@FReceiveTimeout), SizeOf(FReceiveTimeout)));
{ Setup packet based on Content-Type/Binding }
if FBindingType = btMIME then
begin
ContentHeader := Format(ContentHeaderMIME, [FMimeBoundary]);
ContentHeader := Format(ContentTypeTemplate, [ContentHeader]);
HttpAddRequestHeaders(Request, PChar(MIMEVersion), Length(MIMEVersion), HTTP_ADDREQ_FLAG_ADD);
{ SOAPAction header }
{ NOTE: It's not really clear whether this should be sent in the case
of MIME Binding. Investigate interoperability ?? }
if not (soNoSOAPActionHeader in FInvokeOptions) then
begin
ActionHeader:= GetSOAPActionHeader;
HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
end;
end else { Assume btSOAP }
begin
{ SOAPAction header }
if not (soNoSOAPActionHeader in FInvokeOptions) then
begin
ActionHeader:= GetSOAPActionHeader;
HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
end;
if UseUTF8InHeader then
ContentHeader := Format(ContentTypeTemplate, [ContentTypeUTF8])
else
ContentHeader := Format(ContentTypeTemplate, [ContentTypeNoUTF8]);
end;
{ Content-Type }
HttpAddRequestHeaders(Request, PChar(ContentHeader), Length(ContentHeader), HTTP_ADDREQ_FLAG_ADD);
{ Before we pump data, see if user wants to handle something - like set Basic-Auth data?? }
if Assigned(FOnBeforePost) then
FOnBeforePost(Self, Request);
ASrc.Position := 0;
BuffSize := ASrc.Size;
if BuffSize > FMaxSinglePostSize then
begin
Buffer := TMemoryStream.Create;
try
Buffer.SetSize(FMaxSinglePostSize);
{ Init Input Buffer }
INBuffer.dwStructSize := SizeOf(INBuffer);
INBuffer.Next := nil;
INBuffer.lpcszHeader := nil;
INBuffer.dwHeadersLength := 0;
INBuffer.dwHeadersTotal := 0;
INBuffer.lpvBuffer := nil;
INBuffer.dwBufferLength := 0;
INBuffer.dwBufferTotal := BuffSize;
INBuffer.dwOffsetLow := 0;
INBuffer.dwOffsetHigh := 0;
{ Start POST }
Check(not HttpSendRequestEx(Request, @INBuffer, nil,
HSR_INITIATE or HSR_SYNC, 0));
try
while True do
begin
{ Calc length of data to send }
Len := BuffSize - ASrc.Position;
if Len > FMaxSinglePostSize then
Len := FMaxSinglePostSize;
{ Bail out if zip.. }
if Len = 0 then
break;
{ Read data in buffer and write out}
Len := ASrc.Read(Buffer.Memory^, Len);
if Len = 0 then
raise ESOAPHTTPException.Create(SInvalidHTTPRequest);
Check(not InternetWriteFile(Request, @Buffer.Memory^, Len, RetVal));
RetVal := InternetErrorDlg(GetDesktopWindow(), Request, GetLastError,
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, P);
case RetVal of
ERROR_SUCCESS: ;
ERROR_CANCELLED: SysUtils.Abort;
ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
end;
{ Posting Data Event }
if Assigned(FOnPostingData) then
FOnPostingData(ASrc.Position, BuffSize);
end;
finally
Check(not HttpEndRequest(Request, nil, 0, 0));
end;
finally
Buffer.Free;
end;
end else
begin
StrStr := TStringStream.Create('');
try
StrStr.CopyFrom(ASrc, 0);
while True do
begin
Check(not HttpSendRequest(Request, nil, 0, @StrStr.DataString[1], Length(StrStr.DataString)));
RetVal := InternetErrorDlg(GetDesktopWindow(), Request, GetLastError,
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, P);
case RetVal of
ERROR_SUCCESS: break;
ERROR_CANCELLED: SysUtils.Abort;
ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
end;
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, 0, Cardinal(Self));
//创建一个特定的会话：
Check(not Assigned(FInetConnect));
FConnected := True;
except
InternetCloseHandle(FInetRoot);
FInetRoot := nil;
raise;
end;
这里已经创建了一个会话：
继续返回function THTTPReqResp.Send(const ASrc: TStream): Integer;函数之中：
。。。。
Request := HttpOpenRequest(FInetConnect, 'POST', PChar(FURLSite), nil,
nil, nil, Flags, 0{Integer(Self)});
Check(not Assigned(Request));。
打开一个HTTP的请求。向WEB服务器提出请求：
。。
if not (soNoSOAPActionHeader in FInvokeOptions) then
begin
ActionHeader:= GetSOAPActionHeader;
HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
end;
。。。
为请求添加一个或多个标头。可以看到标点的信息为：
'SOAPAction: "urn:MyFirstWSIntf-IMyFirstWS#GetObj"'
HttpAddRequestHeaders(Request, PChar(ContentHeader), Length(ContentHeader), HTTP_ADDREQ_FLAG_ADD);
继续加入标头'Content-Type: text/xml'信息：
StrStr := TStringStream.Create('');
try
StrStr.CopyFrom(ASrc, 0);
while True do
begin
Check(not HttpSendRequest(Request, nil, 0, @StrStr.DataString[1], Length(StrStr.DataString)));
建立到internet 的连接，并将请求发送到指定的站点。
这句执行完后的图如下（用工具跟踪的结果）：
看看前面的soap生成的字符 StrStr的结果如下，发现后半部分是一样的。
继续
function THTTPReqResp.Execute(const Request: TStream): TStream;
Receive(Context, Response);
procedure THTTPReqResp.Receive(Context: Integer; Resp: TStream; IsGet: Boolean);
var
Size, Downloaded, Status, Len, Index: DWord;
S: string;
begin
..
//获取请求信息：
HttpQueryInfo(Pointer(Context), HTTP_QUERY_CONTENT_TYPE, @FContentType[1], Size, Index);
repeat
Check(not InternetQueryDataAvailable(Pointer(Context), Size, 0, 0));
if Size > 0 then
begin
SetLength(S, Size);
Check(not InternetReadFile(Pointer(Context), @S[1], Size, Downloaded));
//下载数据：
Resp.Write(S[1], Size);
{ Receiving Data event }
if Assigned(FOnReceivingData) then
FOnReceivingData(Size, Downloaded)
end;
until Size = 0;
S的结果如下和刚才跟踪器里的是一模一样的：
'<?xml version="1.0"?>'#$D#$A'<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, IntfMD, MethMD, FContext, FHeadersInbound);
再次把SOAP封包转换成PASCEL调用：
procedure TOPToSoapDomConvert.ProcessResponse(const Resp: TStream;
const IntfMD: TIntfMetaData;
const MD: TIntfMethEntry;
Context: TInvContext;
Headers: THeaderList);
var
XMLDoc: IXMLDocument;
begin
XMLDoc := NewXMLDocument;
XMLDoc.Encoding := FEncoding;
Resp.Position := 0;
XMLDoc.LoadFromStream(Resp);
ProcessResponse(XMLDoc, IntfMD, MD, Context, Headers);
end;
procedure TOPToSoapDomConvert.ProcessResponse(const XMLDoc: IXMLDocument;
const IntfMD: TIntfMetaData;
const MD: TIntfMethEntry;
Context: TInvContext;
Headers: THeaderList);
var
ProcessSuccess(RespNode, IntfMD, MD, Context);
ProcessSuccess函数如下：
….
for I := 0 to RespNode.childNodes.Count - 1 do
begin
Node := RespNode.childNodes[I];
{ Skip non-valid nodes }
if Node.NodeType <> ntElement then
continue;
// 处理返回值：
if I = RetIndex then
begin
InvData := InvContext.GetResultPointer;
ByRef := IsParamByRef([pfOut], MD.ResultInfo, MD.CC);
ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);
ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);
把SOAP的结果，写入返回区地址空间。
procedure TSOAPDomConv.ConvertSoapToNativeData(DataP: Pointer; TypeInfo: PTypeInfo;
Context: TDataContext; RootNode, Node: IXMLNode; Translate, ByRef: Boolean;
NumIndirect: Integer);
var
TypeUri, TypeName: InvString;
IsNull: Boolean;
Obj: TObject;
P: Pointer;
I: Integer;
ID: InvString;
begin
Node := GetDataNode(RootNode, Node, ID);
IsNull := NodeIsNull(Node);
if TypeInfo.Kind = tkVariant then
begin
if NumIndirect > 1 then
DataP := Pointer(PInteger(DataP)^);
if IsNull then
begin
Variant(PVarData(DataP)^) := NULL;
end else
ConvertSoapToVariant(Node, DataP);
end else
if TypeInfo.Kind = tkDynArray then
begin
P := DataP;
for I := 0 to NumIndirect - 2 do
P := Pointer(PInteger(P)^);
P := ConvertSoapToNativeArray(P, TypeInfo, RootNode, Node);
if NumIndirect = 1 then
PInteger(DataP)^ := Integer(P)
else if NumIndirect = 2 then
begin
DataP := Pointer(PInteger(DataP)^);
PInteger(DataP)^ := Integer(P);
end;
end else
if TypeInfo.Kind = tkClass then
begin
Obj := ConvertSOAPToObject(RootNode, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, NumIndirect);
if NumIndirect = 1 then
PTObject(DataP)^ := Obj
else if NumIndirect = 2 then
begin
DataP := Pointer(PInteger(DataP)^);
PTObject(DataP)^ := Obj;
end;
end else
begin
if Translate then
begin
if NumIndirect > 1 then
DataP := Pointer(PInteger(DataP)^);
if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, IsNull) then
raise ESOAPDomConvertError.CreateFmt(STypeMismatchInParam, [node.nodeName]);
end;
end;
end;
作为整型数据，处理方式为：
if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, 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, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, 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, Request, 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), IWebDispatch, DispatchIntf) then
FDispatchList.Add(Component);
end;
end;
...
THTTPSoapDispatcher = class(THTTPSoapDispatchNode, IWebDispatch)
因此Web Service程序的http请求处理实际上是由THTTPSoapDispatcher进行的。
我们接着看看THTTPSoapDispatcher.DispatchRequest方法中对SOAP
协议的处理，关键代码如下
function THTTPSoapDispatcher.DispatchRequest(Sender: TObject;
Request: TWebRequest; Response: TWebResponse): Boolean;
var
…..
http信息被封装在TwebRequest里：我们来看是怎么进行分析的：
SoapAction := Request.GetFieldByName(SHTTPSoapAction);
首先得到SOAPAction信息, 这个SOAPAction大家应该比较熟悉了，前面讲过，这里主要是根据相应信息调用方法：() 具体的内容例如：urn:MyFirstWSIntf-IMyFirstWS
….
if SoapAction = '' then
SoapAction := Request.GetFieldByName('HTTP_' + UpperCase(SHTTPSoapAction)); { do not localize }
CGI或者Apache的处理方式。如果不是SOAP请求，就默认HTTP请求。
记录请求的路径。
Path := Request.PathInfo;
XMLStream := TMemoryStream.Create; //把客户端的请求流化。
ReqStream := TWebRequestStream.Create(Request);
创建一个响应的流信息,以例把结果返回客户端
RStream := TMemoryStream.Create; 创建返回信息的流。
try
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
这句是最重要的：
它把ＨＴＴＰ的调用方法，委托给THTTPSoapPascalInvoker.DispatchSOAP来处理。
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
IHTTPSoapDispatch = interface
['{9E733EDC-7639-4DAF-96FF-BCF141F7D8F2}']
procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
Response: TStream; var BindingType: TWebServiceBindingType);
end;
父类实现的接口：
THTTPSoapDispatchNode = class(TComponent)
private
procedure SetSoapDispatcher(const Value: IHTTPSoapDispatch);
protected
FSoapDispatcher: IHTTPSoapDispatch;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
Response: TStream); virtual;
published
property Dispatcher: IHTTPSoapDispatch read FSoapDispatcher write SetSoapDispatcher;
end;
也被THTTPSoapPascalInvoker实现。所以THTTPSoapDispatcher中的Dispatcher接口的实例其实是：THTTPSoapPascalInvoker
THTTPSoapPascalInvoker = class(TSoapPascalInvoker, IHTTPSoapDispatch)
public
procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
Response: TStream; var BindingType: TWebServiceBindingType); virtual;
end;
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
相应于调用了：
procedure THTTPSoapPascalInvoker.DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
Response: TStream; var BindingType: TWebServiceBindingType);
var
IntfInfo: PTypeInfo;
PascalBind: IHTTPSOAPToPasBind;
InvClassType: TClass;
ActionMeth: String;
MD: TIntfMetaData;
if not PascalBind.BindToPascalByPath(Path, InvClassType, IntfInfo, ActionMeth) or (InvClassType = nil) then
调用:
function THTTPSOAPToPasBind.BindToPascalByPath(Path: String;
var AClass: TClass; var IntfInfo: PTypeInfo; var AMeth: String): Boolean;
begin
Result := InvRegistry.GetInfoForURI(Path, '', AClass, IntfInfo, AMeth);
end;
由InvRegistry的注册信息，返回相应的类名，接口信息等信息。
这了这些准备信息，下步才是真正的调用。
Invoke(InvClassType, IntfInfo, ActionMeth, Request, Response, BindingType);
函数最后一句：调用了父类：这里是真正工作的地方：
这里了仔细认真研究一下：
procedure TSoapPascalInvoker.Invoke(AClass: TClass; IntfInfo: PTypeInfo; MethName: string; const Request: TStream;
Response: TStream; var BindingType: TWebServiceBindingType);
var
Inv: TInterfaceInvoker;
Obj: TObject;
InvContext: TInvContext;
IntfMD: TIntfMetaData;
MethNum: Integer;
SOAPHeaders: ISOAPHeaders;
Handled: Boolean;
begin
try
GetIntfMetaData(IntfInfo, IntfMD, True); 得到接口ＲＴＴＬ信息；
InvContext := TInvContext.Create; 构造调用堆栈。
{ Convert XML to Invoke Context }
FConverter.MsgToInvContext(Request, IntfMD, MethNum, InvContext, FHeadersIn);
这个函数请见前面的参考InvContextToMsg, 把TinvContext内容转化成XML封包。
这个函数是逆操作，把XML内容转化成Context。
try
Obj := InvRegistry.GetInvokableObjectFromClass(AClass);
搜寻注册信息，创建实例：
if Obj = nil then
raise Exception.CreateFmt(SNoClassRegistered, [IntfMD.Name]);
……………..
Inv := TInterfaceInvoker.Create;
Inv.Invoke(Obj, IntfMD, MethNum, InvContext);
真正调用的地方：
源代码为：
这段代码，就是根据对象，接口信息等，把ＣＯＮtext的信息压入相应参数，应调用。
有时间再仔细研究。
procedure TInterfaceInvoker.Invoke(const Obj: TObject;
IntfMD: TIntfMetaData; const MethNum: Integer;
const Context: TInvContext);
var
MethPos: Integer;
Unk: IUnknown;
IntfEntry: PInterfaceEntry;
IntfVTable: Pointer;
RetIsOnStack, RetIsInFPU, RetInAXDX: Boolean;
I: Integer;
RetP : Pointer;
MD : TIntfMethEntry;
DataP: Pointer;
Temp, Temp1: Integer;
RetEAX: Integer;
RetEDX: Integer;
TotalParamBytes: Integer;
ParamBytes: Integer;
begin
{$IFDEF LINUX}
try
{$ENDIF}
TotalParamBytes := 0;
MD := IntfMD.MDA[MethNUm]; //得到方法的动态数组信息：
if not Obj.GetInterface(IntfMD.IID, Unk) then
raise Exception.CreateFmt(SNoInterfaceGUID,
[Obj.ClassName, GUIDToString(IntfMD.IID)]);
IntfEntry := Obj.GetInterfaceEntry(IntfMD.IID); //得到接口的动态数组信息
IntfVTable := IntfEntry.VTable; //指向VTB表的指针
MethPos := MD.Pos * 4; { Pos is absolute to whole VMT } //定位
if MD.ResultInfo <> nil then
begin
RetIsInFPU := RetInFPU(MD.ResultInfo);
RetIsOnStack := RetOnStack(MD.ResultInfo);
RetInAXDX := IsRetInAXDX(MD.ResultInfo);
RetP := Context.GetResultPointer; //根据context 得到返回参数的地址。
end else
begin
RetIsOnStack := False;
RetIsInFPU := False;
RetInAXDX := False;
end;
if MD.CC in [ccCDecl, ccStdCall, ccSafeCall] then
begin
if (MD.ResultInfo <> nil) and (MD.CC = ccSafeCall) then
asm PUSH DWORD PTR [RetP] end; //把函数返回参数压入堆栈中。
for I := MD.ParamCount - 1 downto 0 do //遍历参数。
begin
DataP := Context.GetParamPointer(I); //指向一个参数地址：
if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then {基本类型}
asm
PUSH DWORD PTR [DataP] //压入堆栈。
end
else
begin
ParamBytes := GetStackTypeSize(MD.Params[I].Info, MD.CC); {特殊类型}
PushStackParm(DataP, ParamBytes);
Inc(TotalParamBytes, ParamBytes);
end;
end;
asm PUSH DWORD PTR [Unk] end; //压入Iunknown指针
if RetIsOnStack and (MD.CC <> ccSafeCall) then
asm PUSH DWORD PTR [RetP] end;
end
else if MD.CC = ccPascal then
begin
for I := 0 to MD.ParamCount - 1 do
begin
DataP := Context.GetParamPointer(I);
if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then
asm
PUSH DWORD PTR [DataP]
end
else
begin
// PushStackParm(DataP, GetStackTypeSize(MD.Params[I].Info, MD.CC));
ParamBytes := GetStackTypeSize(MD.Params[I].Info, MD.CC);
PushStackParm(DataP, ParamBytes);
Inc(TotalParamBytes, ParamBytes);
end;
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;
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
返回调用后的内存块为。
Response.ContentStream := RStream;
然后再发送给客户端。
到这里，基本上客户端和服务器端都进行了分析。
begin
if not Assigned(FDOMImplementation) then
if Assigned(FDOMVendor) then
FDOMImplementation := FDOMVendor.DOMImplementation
else
FDOMImplementation := GetDOM(DefaultDOMVendor);
end;
在TXMLDocument内部使用了Abstract Factory模式
Abstract Factory希望不用指定具体的类，但为了找到它们，在TXMLDocument是通过指定一个字符串，也就是我们点击DOMVendor时出现的哪几个字符串．
GetDOM函数如下：
Result := GetDOMVendor(VendorDesc).DOMImplementation;
//根据传递进去的名字，创建相应在的实例：
function GetDOMVendor(VendorDesc: string): TDOMVendor;
begin
if VendorDesc = '' then
VendorDesc := DefaultDOMVendor;
if (VendorDesc = '') and (DOMVendorList.Count > 0) then
Result := DOMVendorList[0]
else
Result := DOMVendorList.Find(VendorDesc);
if not Assigned(Result) then
raise Exception.CreateFmt(SNoMatchingDOMVendor, [VendorDesc]);
end;
最后取得一个IDOMImplementation，它有一个createDocument（….）:IDOMDocument;函数，这个函数将返回一个IDOMDocument;接口让IXMLDoucment使用。
//由此可见，默认状态下是创建DOM，微软的XML解析器。
function DOMVendorList: TDOMVendorList;
begin
if not Assigned(DOMVendors) then
DOMVendors := TDOMVendorList.Create;
Result := DOMVendors;
end;
function TDOMVendorList.GetVendors(Index: Integer): TDOMVendor;
begin
Result := FVendors[Index];
end;
如果为空，就返回默认的。
function TMSDOMImplementationFactory.DOMImplementation: IDOMImplementation;
begin
Result := TMSDOMImplementation.Create(nil);
end;
再返回到函数：
procedure TXMLDocument.SetActive(const Value: Boolean);
FDOMDocument := DOMImplementation.createDocument('', '', nil);
继续：
function TMSDOMImplementation.createDocument(const namespaceURI,
qualifiedName: DOMString; doctype: IDOMDocumentType): IDOMDocument;
begin
Result := TMSDOMDocument.Create(MSXMLDOMDocumentCreate);
end;
在如果使用MSXML,接口对应的是TMSDOMDocument，TMSDOMDocument是实际上是调用MSXML技术，下面是调用MS COM的代码
function CreateDOMDocument: IXMLDOMDocument;
begin
Result := TryObjectCreate([CLASS_DOMDocument40, CLASS_DOMDocument30,
CLASS_DOMDocument26, msxml.CLASS_DOMDocument]) as IXMLDOMDocument;
if not Assigned(Result) then
raise DOMException.Create(SMSDOMNotInstalled);
end;
再返回到函数：
procedure TXMLDocument.SetActive(const Value: Boolean);
..
LoadData
//因为是新建的TXMLDocument，所以装内空数据,立即返回。
procedure TXMLDocument.LoadData;
const
UnicodeEncodings: array[0..2] of string = ('UTF-16', 'UCS-2', 'UNICODE');
var
Status: Boolean;
ParseError: IDOMParseError;
StringStream: TStringStream;
Msg: string;
begin
…
Status := True; { No load, just create empty doc. }
创建空的文档：
if not Status then
begin
DocSource := xdsNone;
ParseError := DOMDocument as IDOMParseError;
with ParseError do
Msg := Format('%s%s%s: %d%s%s', [Reason, SLineBreak, SLine,
Line, SLineBreak, Copy(SrcText, 1, 40)]);
raise EDOMParseError.Create(ParseError, Msg);
end;
SetModified(False);
end;
设置不能修改。因为空文档。
继续返回到
function NewXMLDocument(Version: DOMString = '1.0'): IXMLDocument;
begin
if Version <> '' then
Result.Version := Version;
end;
procedure TXMLDocument.SetVersion(const Value: DOMString);
begin
SetPrologValue(Value, xpVersion);
end;
procedure TXMLDocument.SetPrologValue(const Value: Variant;
….
PrologNode := GetPrologNode;
PrologAttrs := InternalSetPrologValue(PrologNode, Value, PrologItem);
NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);
if Assigned(PrologNode) then
Node.ChildNodes.ReplaceNode(PrologNode, NewPrologNode)
else
ChildNodes.Insert(0, NewPrologNode);
end;
NewPrologNode := CreateNode('xml', ntProcessingInstr, PrologAttrs);
这句调用了：
function TXMLDocument.CreateNode(const NameOrData: DOMString;
NodeType: TNodeType = ntElement; const AddlData: DOMString = ''): IXMLNode;
begin
Result := TXMLNode.Create(CreateDOMNode(FDOMDocument, NameOrData,
NodeType, AddlData), nil, Self);
end;
在返回到这个函数中：
function TOPToSoapDomConvert.InvContextToMsg(const IntfMD: TIntfMetaData; MethNum: Integer;
Con: TInvContext; Headers: THeaderList): TStream;
BodyNode := Envelope.MakeBody(EnvNode);
if not (soLiteralParams in Options) then
begin
SoapMethNS := GetSoapNS(IntfMD);
ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name)；
;;;;;
//创建一个SOAP的body:
function TSoapEnvelope.MakeBody(ParentNode: IXMLNode): IXMLNode;
begin
Result := ParentNode.AddChild(SSoapNameSpacePre + ':' + SSoapBody, SSoapNameSpace);
end;
SoapMethNS := GetSoapNS(IntfMD); 返回：'urn:MyFirstWSIntf-IMyFirstWS'
ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);
得到调用方法名。剩下的部分就是把参数打包。生成SOAP的源文件。然后写到内存流中。
再回到函数中：InvContextToMsg
Result := TMemoryStream.Create();
DOMToStream(XMLDoc, Result);
把内存块的数据，转化成XML。
具体的函数如下：
procedure TOPToSoapDomConvert.DOMToStream(const XMLDoc: IXMLDocument; Stream: TStream);
var
XMLWString: WideString;
StrStr: TStringStream;
begin
if (FEncoding = '') or (soUTF8EncodeXML in Options) then
begin
XMLDoc.SaveToXML(XMLWString);
StrStr := TStringStream.Create(UTF8Encode(XMLWString));
try
Stream.CopyFrom(StrStr, 0);
finally
StrStr.Free;
end;
end else
XMLDoc.SaveToStream(Stream);
end;
我们跟踪之后StrStr的结果如下：
'<?xml version="1.0"?>'#$D#$A'<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, MethMD, MethNum-3, nil);
THTTPReqResp.BeforeExecute
。。。。。
MethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);
FSoapAction := InvRegistry.GetActionURIOfInfo(IntfMD.Info, MethName, MethodIndex);
得到方法名和FsoapAction
FBindingType := btSOAP
DoBeforeExecute // TRIO.
if Assigned(FOnBeforeExecute) then
退出：
继续：
Resp := GetResponseStream(RespBindingType);
继续返回到TRIO.Generic函数中执行：
try
FWebNode.Execute(Req, Resp);
比较重要的部分：
这个函数就是THTTPReqResp向IIS发出请求。并返回信息：
procedure THTTPReqResp.Execute(const Request: TStream; Response: TStream);
begin
…
Context := Send(Request);
try
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,
nil, nil, Flags, 0{Integer(Self)});
Check(not Assigned(Request));
{ Timeouts }
if FConnectTimeout > 0 then
Check(InternetSetOption(Request, INTERNET_OPTION_CONNECT_TIMEOUT, Pointer(@FConnectTimeout), SizeOf(FConnectTimeout)));
if FSendTimeout > 0 then
Check(InternetSetOption(Request, INTERNET_OPTION_SEND_TIMEOUT, Pointer(@FSendTimeout), SizeOf(FSendTimeout)));
if FReceiveTimeout > 0 then
Check(InternetSetOption(Request, INTERNET_OPTION_RECEIVE_TIMEOUT, Pointer(@FReceiveTimeout), SizeOf(FReceiveTimeout)));
{ Setup packet based on Content-Type/Binding }
if FBindingType = btMIME then
begin
ContentHeader := Format(ContentHeaderMIME, [FMimeBoundary]);
ContentHeader := Format(ContentTypeTemplate, [ContentHeader]);
HttpAddRequestHeaders(Request, PChar(MIMEVersion), Length(MIMEVersion), HTTP_ADDREQ_FLAG_ADD);
{ SOAPAction header }
{ NOTE: It's not really clear whether this should be sent in the case
of MIME Binding. Investigate interoperability ?? }
if not (soNoSOAPActionHeader in FInvokeOptions) then
begin
ActionHeader:= GetSOAPActionHeader;
HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
end;
end else { Assume btSOAP }
begin
{ SOAPAction header }
if not (soNoSOAPActionHeader in FInvokeOptions) then
begin
ActionHeader:= GetSOAPActionHeader;
HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
end;
if UseUTF8InHeader then
ContentHeader := Format(ContentTypeTemplate, [ContentTypeUTF8])
else
ContentHeader := Format(ContentTypeTemplate, [ContentTypeNoUTF8]);
end;
{ Content-Type }
HttpAddRequestHeaders(Request, PChar(ContentHeader), Length(ContentHeader), HTTP_ADDREQ_FLAG_ADD);
{ Before we pump data, see if user wants to handle something - like set Basic-Auth data?? }
if Assigned(FOnBeforePost) then
FOnBeforePost(Self, Request);
ASrc.Position := 0;
BuffSize := ASrc.Size;
if BuffSize > FMaxSinglePostSize then
begin
Buffer := TMemoryStream.Create;
try
Buffer.SetSize(FMaxSinglePostSize);
{ Init Input Buffer }
INBuffer.dwStructSize := SizeOf(INBuffer);
INBuffer.Next := nil;
INBuffer.lpcszHeader := nil;
INBuffer.dwHeadersLength := 0;
INBuffer.dwHeadersTotal := 0;
INBuffer.lpvBuffer := nil;
INBuffer.dwBufferLength := 0;
INBuffer.dwBufferTotal := BuffSize;
INBuffer.dwOffsetLow := 0;
INBuffer.dwOffsetHigh := 0;
{ Start POST }
Check(not HttpSendRequestEx(Request, @INBuffer, nil,
HSR_INITIATE or HSR_SYNC, 0));
try
while True do
begin
{ Calc length of data to send }
Len := BuffSize - ASrc.Position;
if Len > FMaxSinglePostSize then
Len := FMaxSinglePostSize;
{ Bail out if zip.. }
if Len = 0 then
break;
{ Read data in buffer and write out}
Len := ASrc.Read(Buffer.Memory^, Len);
if Len = 0 then
raise ESOAPHTTPException.Create(SInvalidHTTPRequest);
Check(not InternetWriteFile(Request, @Buffer.Memory^, Len, RetVal));
RetVal := InternetErrorDlg(GetDesktopWindow(), Request, GetLastError,
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, P);
case RetVal of
ERROR_SUCCESS: ;
ERROR_CANCELLED: SysUtils.Abort;
ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
end;
{ Posting Data Event }
if Assigned(FOnPostingData) then
FOnPostingData(ASrc.Position, BuffSize);
end;
finally
Check(not HttpEndRequest(Request, nil, 0, 0));
end;
finally
Buffer.Free;
end;
end else
begin
StrStr := TStringStream.Create('');
try
StrStr.CopyFrom(ASrc, 0);
while True do
begin
Check(not HttpSendRequest(Request, nil, 0, @StrStr.DataString[1], Length(StrStr.DataString)));
RetVal := InternetErrorDlg(GetDesktopWindow(), Request, GetLastError,
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, P);
case RetVal of
ERROR_SUCCESS: break;
ERROR_CANCELLED: SysUtils.Abort;
ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
end;
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, 0, Cardinal(Self));
//创建一个特定的会话：
Check(not Assigned(FInetConnect));
FConnected := True;
except
InternetCloseHandle(FInetRoot);
FInetRoot := nil;
raise;
end;
这里已经创建了一个会话：
继续返回function THTTPReqResp.Send(const ASrc: TStream): Integer;函数之中：
。。。。
Request := HttpOpenRequest(FInetConnect, 'POST', PChar(FURLSite), nil,
nil, nil, Flags, 0{Integer(Self)});
Check(not Assigned(Request));。
打开一个HTTP的请求。向WEB服务器提出请求：
。。
if not (soNoSOAPActionHeader in FInvokeOptions) then
begin
ActionHeader:= GetSOAPActionHeader;
HttpAddRequestHeaders(Request, PChar(ActionHeader), Length(ActionHeader), HTTP_ADDREQ_FLAG_ADD);
end;
。。。
为请求添加一个或多个标头。可以看到标点的信息为：
'SOAPAction: "urn:MyFirstWSIntf-IMyFirstWS#GetObj"'
HttpAddRequestHeaders(Request, PChar(ContentHeader), Length(ContentHeader), HTTP_ADDREQ_FLAG_ADD);
继续加入标头'Content-Type: text/xml'信息：
StrStr := TStringStream.Create('');
try
StrStr.CopyFrom(ASrc, 0);
while True do
begin
Check(not HttpSendRequest(Request, nil, 0, @StrStr.DataString[1], Length(StrStr.DataString)));
建立到internet 的连接，并将请求发送到指定的站点。
这句执行完后的图如下（用工具跟踪的结果）：
看看前面的soap生成的字符 StrStr的结果如下，发现后半部分是一样的。
继续
function THTTPReqResp.Execute(const Request: TStream): TStream;
Receive(Context, Response);
procedure THTTPReqResp.Receive(Context: Integer; Resp: TStream; IsGet: Boolean);
var
Size, Downloaded, Status, Len, Index: DWord;
S: string;
begin
..
//获取请求信息：
HttpQueryInfo(Pointer(Context), HTTP_QUERY_CONTENT_TYPE, @FContentType[1], Size, Index);
repeat
Check(not InternetQueryDataAvailable(Pointer(Context), Size, 0, 0));
if Size > 0 then
begin
SetLength(S, Size);
Check(not InternetReadFile(Pointer(Context), @S[1], Size, Downloaded));
//下载数据：
Resp.Write(S[1], Size);
{ Receiving Data event }
if Assigned(FOnReceivingData) then
FOnReceivingData(Size, Downloaded)
end;
until Size = 0;
S的结果如下和刚才跟踪器里的是一模一样的：
'<?xml version="1.0"?>'#$D#$A'<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, IntfMD, MethMD, FContext, FHeadersInbound);
再次把SOAP封包转换成PASCEL调用：
procedure TOPToSoapDomConvert.ProcessResponse(const Resp: TStream;
const IntfMD: TIntfMetaData;
const MD: TIntfMethEntry;
Context: TInvContext;
Headers: THeaderList);
var
XMLDoc: IXMLDocument;
begin
XMLDoc := NewXMLDocument;
XMLDoc.Encoding := FEncoding;
Resp.Position := 0;
XMLDoc.LoadFromStream(Resp);
ProcessResponse(XMLDoc, IntfMD, MD, Context, Headers);
end;
procedure TOPToSoapDomConvert.ProcessResponse(const XMLDoc: IXMLDocument;
const IntfMD: TIntfMetaData;
const MD: TIntfMethEntry;
Context: TInvContext;
Headers: THeaderList);
var
ProcessSuccess(RespNode, IntfMD, MD, Context);
ProcessSuccess函数如下：
….
for I := 0 to RespNode.childNodes.Count - 1 do
begin
Node := RespNode.childNodes[I];
{ Skip non-valid nodes }
if Node.NodeType <> ntElement then
continue;
// 处理返回值：
if I = RetIndex then
begin
InvData := InvContext.GetResultPointer;
ByRef := IsParamByRef([pfOut], MD.ResultInfo, MD.CC);
ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);
ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);
把SOAP的结果，写入返回区地址空间。
procedure TSOAPDomConv.ConvertSoapToNativeData(DataP: Pointer; TypeInfo: PTypeInfo;
Context: TDataContext; RootNode, Node: IXMLNode; Translate, ByRef: Boolean;
NumIndirect: Integer);
var
TypeUri, TypeName: InvString;
IsNull: Boolean;
Obj: TObject;
P: Pointer;
I: Integer;
ID: InvString;
begin
Node := GetDataNode(RootNode, Node, ID);
IsNull := NodeIsNull(Node);
if TypeInfo.Kind = tkVariant then
begin
if NumIndirect > 1 then
DataP := Pointer(PInteger(DataP)^);
if IsNull then
begin
Variant(PVarData(DataP)^) := NULL;
end else
ConvertSoapToVariant(Node, DataP);
end else
if TypeInfo.Kind = tkDynArray then
begin
P := DataP;
for I := 0 to NumIndirect - 2 do
P := Pointer(PInteger(P)^);
P := ConvertSoapToNativeArray(P, TypeInfo, RootNode, Node);
if NumIndirect = 1 then
PInteger(DataP)^ := Integer(P)
else if NumIndirect = 2 then
begin
DataP := Pointer(PInteger(DataP)^);
PInteger(DataP)^ := Integer(P);
end;
end else
if TypeInfo.Kind = tkClass then
begin
Obj := ConvertSOAPToObject(RootNode, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, NumIndirect);
if NumIndirect = 1 then
PTObject(DataP)^ := Obj
else if NumIndirect = 2 then
begin
DataP := Pointer(PInteger(DataP)^);
PTObject(DataP)^ := Obj;
end;
end else
begin
if Translate then
begin
if NumIndirect > 1 then
DataP := Pointer(PInteger(DataP)^);
if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, IsNull) then
raise ESOAPDomConvertError.CreateFmt(STypeMismatchInParam, [node.nodeName]);
end;
end;
end;
作为整型数据，处理方式为：
if not TypeTranslator.CastSoapToNative(TypeInfo, GetNodeAsText(Node), DataP, 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, Node, GetTypeData(TypeInfo).ClassType, TypeURI, TypeName, DataP, 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, Request, 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), IWebDispatch, DispatchIntf) then
FDispatchList.Add(Component);
end;
end;
...
THTTPSoapDispatcher = class(THTTPSoapDispatchNode, IWebDispatch)
因此Web Service程序的http请求处理实际上是由THTTPSoapDispatcher进行的。
我们接着看看THTTPSoapDispatcher.DispatchRequest方法中对SOAP
协议的处理，关键代码如下
function THTTPSoapDispatcher.DispatchRequest(Sender: TObject;
Request: TWebRequest; Response: TWebResponse): Boolean;
var
…..
http信息被封装在TwebRequest里：我们来看是怎么进行分析的：
SoapAction := Request.GetFieldByName(SHTTPSoapAction);
首先得到SOAPAction信息, 这个SOAPAction大家应该比较熟悉了，前面讲过，这里主要是根据相应信息调用方法：() 具体的内容例如：urn:MyFirstWSIntf-IMyFirstWS
….
if SoapAction = '' then
SoapAction := Request.GetFieldByName('HTTP_' + UpperCase(SHTTPSoapAction)); { do not localize }
CGI或者Apache的处理方式。如果不是SOAP请求，就默认HTTP请求。
记录请求的路径。
Path := Request.PathInfo;
XMLStream := TMemoryStream.Create; //把客户端的请求流化。
ReqStream := TWebRequestStream.Create(Request);
创建一个响应的流信息,以例把结果返回客户端
RStream := TMemoryStream.Create; 创建返回信息的流。
try
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
这句是最重要的：
它把ＨＴＴＰ的调用方法，委托给THTTPSoapPascalInvoker.DispatchSOAP来处理。
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
IHTTPSoapDispatch = interface
['{9E733EDC-7639-4DAF-96FF-BCF141F7D8F2}']
procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
Response: TStream; var BindingType: TWebServiceBindingType);
end;
父类实现的接口：
THTTPSoapDispatchNode = class(TComponent)
private
procedure SetSoapDispatcher(const Value: IHTTPSoapDispatch);
protected
FSoapDispatcher: IHTTPSoapDispatch;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
Response: TStream); virtual;
published
property Dispatcher: IHTTPSoapDispatch read FSoapDispatcher write SetSoapDispatcher;
end;
也被THTTPSoapPascalInvoker实现。所以THTTPSoapDispatcher中的Dispatcher接口的实例其实是：THTTPSoapPascalInvoker
THTTPSoapPascalInvoker = class(TSoapPascalInvoker, IHTTPSoapDispatch)
public
procedure DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
Response: TStream; var BindingType: TWebServiceBindingType); virtual;
end;
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
相应于调用了：
procedure THTTPSoapPascalInvoker.DispatchSOAP(const Path, SoapAction: WideString; const Request: TStream;
Response: TStream; var BindingType: TWebServiceBindingType);
var
IntfInfo: PTypeInfo;
PascalBind: IHTTPSOAPToPasBind;
InvClassType: TClass;
ActionMeth: String;
MD: TIntfMetaData;
if not PascalBind.BindToPascalByPath(Path, InvClassType, IntfInfo, ActionMeth) or (InvClassType = nil) then
调用:
function THTTPSOAPToPasBind.BindToPascalByPath(Path: String;
var AClass: TClass; var IntfInfo: PTypeInfo; var AMeth: String): Boolean;
begin
Result := InvRegistry.GetInfoForURI(Path, '', AClass, IntfInfo, AMeth);
end;
由InvRegistry的注册信息，返回相应的类名，接口信息等信息。
这了这些准备信息，下步才是真正的调用。
Invoke(InvClassType, IntfInfo, ActionMeth, Request, Response, BindingType);
函数最后一句：调用了父类：这里是真正工作的地方：
这里了仔细认真研究一下：
procedure TSoapPascalInvoker.Invoke(AClass: TClass; IntfInfo: PTypeInfo; MethName: string; const Request: TStream;
Response: TStream; var BindingType: TWebServiceBindingType);
var
Inv: TInterfaceInvoker;
Obj: TObject;
InvContext: TInvContext;
IntfMD: TIntfMetaData;
MethNum: Integer;
SOAPHeaders: ISOAPHeaders;
Handled: Boolean;
begin
try
GetIntfMetaData(IntfInfo, IntfMD, True); 得到接口ＲＴＴＬ信息；
InvContext := TInvContext.Create; 构造调用堆栈。
{ Convert XML to Invoke Context }
FConverter.MsgToInvContext(Request, IntfMD, MethNum, InvContext, FHeadersIn);
这个函数请见前面的参考InvContextToMsg, 把TinvContext内容转化成XML封包。
这个函数是逆操作，把XML内容转化成Context。
try
Obj := InvRegistry.GetInvokableObjectFromClass(AClass);
搜寻注册信息，创建实例：
if Obj = nil then
raise Exception.CreateFmt(SNoClassRegistered, [IntfMD.Name]);
……………..
Inv := TInterfaceInvoker.Create;
Inv.Invoke(Obj, IntfMD, MethNum, InvContext);
真正调用的地方：
源代码为：
这段代码，就是根据对象，接口信息等，把ＣＯＮtext的信息压入相应参数，应调用。
有时间再仔细研究。
procedure TInterfaceInvoker.Invoke(const Obj: TObject;
IntfMD: TIntfMetaData; const MethNum: Integer;
const Context: TInvContext);
var
MethPos: Integer;
Unk: IUnknown;
IntfEntry: PInterfaceEntry;
IntfVTable: Pointer;
RetIsOnStack, RetIsInFPU, RetInAXDX: Boolean;
I: Integer;
RetP : Pointer;
MD : TIntfMethEntry;
DataP: Pointer;
Temp, Temp1: Integer;
RetEAX: Integer;
RetEDX: Integer;
TotalParamBytes: Integer;
ParamBytes: Integer;
begin
{$IFDEF LINUX}
try
{$ENDIF}
TotalParamBytes := 0;
MD := IntfMD.MDA[MethNUm]; //得到方法的动态数组信息：
if not Obj.GetInterface(IntfMD.IID, Unk) then
raise Exception.CreateFmt(SNoInterfaceGUID,
[Obj.ClassName, GUIDToString(IntfMD.IID)]);
IntfEntry := Obj.GetInterfaceEntry(IntfMD.IID); //得到接口的动态数组信息
IntfVTable := IntfEntry.VTable; //指向VTB表的指针
MethPos := MD.Pos * 4; { Pos is absolute to whole VMT } //定位
if MD.ResultInfo <> nil then
begin
RetIsInFPU := RetInFPU(MD.ResultInfo);
RetIsOnStack := RetOnStack(MD.ResultInfo);
RetInAXDX := IsRetInAXDX(MD.ResultInfo);
RetP := Context.GetResultPointer; //根据context 得到返回参数的地址。
end else
begin
RetIsOnStack := False;
RetIsInFPU := False;
RetInAXDX := False;
end;
if MD.CC in [ccCDecl, ccStdCall, ccSafeCall] then
begin
if (MD.ResultInfo <> nil) and (MD.CC = ccSafeCall) then
asm PUSH DWORD PTR [RetP] end; //把函数返回参数压入堆栈中。
for I := MD.ParamCount - 1 downto 0 do //遍历参数。
begin
DataP := Context.GetParamPointer(I); //指向一个参数地址：
if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then {基本类型}
asm
PUSH DWORD PTR [DataP] //压入堆栈。
end
else
begin
ParamBytes := GetStackTypeSize(MD.Params[I].Info, MD.CC); {特殊类型}
PushStackParm(DataP, ParamBytes);
Inc(TotalParamBytes, ParamBytes);
end;
end;
asm PUSH DWORD PTR [Unk] end; //压入Iunknown指针
if RetIsOnStack and (MD.CC <> ccSafeCall) then
asm PUSH DWORD PTR [RetP] end;
end
else if MD.CC = ccPascal then
begin
for I := 0 to MD.ParamCount - 1 do
begin
DataP := Context.GetParamPointer(I);
if IsParamByRef(MD.Params[I].Flags,MD.Params[I].Info, MD.CC) then
asm
PUSH DWORD PTR [DataP]
end
else
begin
// PushStackParm(DataP, GetStackTypeSize(MD.Params[I].Info, MD.CC));
ParamBytes := GetStackTypeSize(MD.Params[I].Info, MD.CC);
PushStackParm(DataP, ParamBytes);
Inc(TotalParamBytes, ParamBytes);
end;
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;
FSoapDispatcher.DispatchSOAP(Path, SoapAction, XMLStream, RStream, BindingTypeIn);
返回调用后的内存块为。
Response.ContentStream := RStream;
然后再发送给客户端。
到这里，基本上客户端和服务器端都进行了分析。
浙公网安备 33010602011771号