optosoapdomconv.pas

Delphi的Soap一些使用功能控件

    procedure SetObjectInstance(const Obj: TObject);

    property ElemNodeNamespace: InvString read GetElementNamespace write SetElementNamespace;
    property UnqualifiedElement: Boolean read GetUnqualifiedElement write SetUnqualifiedElement;
    property ObjectMetaclass: TClass read GetObjectMetaclass write SetObjectMetaclass;
    property ObjectInstance: TObject read GetObjectInstance write SetObjectInstance;
  end;
{$IFEND}

const
  IS_OPTN = $0001;
  IS_UNBD = $0002;
  IS_NLBL = $0004;
  IS_UNQL = $0008;
  IS_ATTR = $0010;
  IS_TEXT = $0020;
  IS_ANY  = $0040;
  IS_REF  = $0080;

{$IF defined(DEXTER_UP) and defined(FIX_ELEM_NODE_NS)}

procedure TSOAPDomConvHelper.SetNodeTypeEx(RootNode, InstNode: IXMLNode; const ElemURI, TypeName: InvString; Forced: Boolean);
var
  Pre: InvString;
begin
  if (not (soSendUntyped in Options) and not (soDocument in Options)) or Forced then
  begin
    { Namespace prefix of Typename }
    if ElemURI <> '' then
      Pre := FindPrefixForURI(RootNode, InstNode, ElemURI, True)
    else
      Pre := '';

    InstNode.SetAttributeNS(SSoapType, XMLSchemaInstNameSpace, MakeNodeName(Pre, TypeName));
  end;
end;

function TSOAPDomConvHelper.GetElementNamespace: InvString;
begin
  Result := TSoapDataListEx(FAttachments).FElemNodeNamespace
end;

procedure TSOAPDomConvHelper.SetElementNamespace(const ANamespace: InvString);
begin
  TSoapDataListEx(FAttachments).FElemNodeNamespace := ANamespace;
end;

function  TSOAPDomConvHelper.GetUnqualifiedElement: Boolean;
begin
  Result := TSoapDataListEx(FAttachments).FUnqualifiedElem;
end;

procedure TSOAPDomConvHelper.SetUnqualifiedElement(Flag: Boolean);
begin
  TSoapDataListEx(FAttachments).FUnqualifiedElem := Flag;
end;

function  TSOAPDomConvHelper.GetObjectMetaclass: TClass;
begin
  Result := TSoapDataListEx(FAttachments).FObjectMetaclass;
end;

procedure TSOAPDomConvHelper.SetObjectMetaclass(const Cls: TClass);
begin
  TSoapDataListEx(FAttachments).FObjectMetaclass := Cls;
end;

function  TSOAPDomConvHelper.GetObjectInstance: TObject;
begin
  Result := TSoapDataListEx(FAttachments).FObjectInstance;
end;

procedure TSOAPDomConvHelper.SetObjectInstance(const Obj: TObject);
begin
  TSoapDataListEx(FAttachments).FObjectInstance := Obj;
end;

{$IFEND}


procedure TConvertAttachment.SetCacheFile(const Value: string);
  begin
  SetSourceFile('');
  InternalSetCacheFile(Value);
end;

{$IFDEF FASTER_CONVERTER}
constructor TRefCache.Create;
begin
  FNodes := TInterfaceList.Create;
  FHREFs := TStringList.Create;
  FHREFs.Sorted := True;

  FMHREFs := TStringList.Create;
  FMHREFs.Sorted := True;
end;

destructor TRefCache.Destroy;
begin
  FHREFs.Free;
  FMHREFs.Free;
  FNodes := nil;
end;
{$ENDIF}

{ util function }

function ntElementChildCount(const Node: IXMLNode): Integer;
{$IFDEF FASTER_CONVERTER}
 overload;
{$ENDIF}
var
  I: Integer;
begin
  Result := 0;
  if (Node = nil) or (Node.ChildNodes = nil) then
    Exit;
  for I := 0 to Node.ChildNodes.Count-1 do
    if Node.ChildNodes[I].NodeType = ntElement then
      Inc(Result);
end;

{$IFDEF FASTER_CONVERTER}
function ntElementChild(const Node: IXMLNode;
    Index: Integer; var IndexPrev, IndexNodePrev: integer): IXMLNode; overload;
var
  I, J: Integer;
begin
  Result := nil;
  if (Node = nil) or (Node.ChildNodes = nil) then
   Exit;
  J := succ(IndexPrev);
  for I := succ(IndexNodePrev) to Node.ChildNodes.Count-1 do
  begin
   if Node.ChildNodes[I].NodeType = ntElement then
   begin
     if (J = Index) then
     begin
       Result := Node.ChildNodes[I];
       IndexPrev := J;
       IndexNodePrev := I;
       Exit;
     end else
       Inc(J);
   end;
  end;
end;
{$ENDIF}

function ntElementChild(const Node: IXMLNode; Index: Integer): IXMLNode;
{$IFDEF FASTER_CONVERTER}
overload;
{$ENDIF}
var
  I, J: Integer;
begin
  Result := nil;
  if (Node = nil) or (Node.ChildNodes = nil) then
    Exit;
  J := 0;
  for I := 0 to Node.ChildNodes.Count-1 do
    if Node.ChildNodes[I].NodeType = ntElement then
    begin
      if (J = Index) then
      begin
        Result := Node.ChildNodes[I];
        Exit;
      end else
        Inc(J);
    end;
end;


procedure ParseDims(DimString: InvString; var Dims: TSOAPArrayDesc);
var
  I, J: Integer;
  CurDim, NumDims, SubDims, SubDim: Integer;
  StrLen: Integer;
  DimSize: InvString;
begin
  CurDim := 0;
  NumDims := 0;
  StrLen := Length(DimString);
  for I := 1 to StrLen do
    if DimString[I] = '[' then      { do not localize }
      Inc(NumDims);
  SetLength(Dims, NumDims);
  I := 1;
  while I < StrLen do
  begin
    if DimString[I] = '[' then       { do not localize }
    begin
      DimSize := '';
      Inc(I);
      SubDims := 1;
      SubDim := 0;
      if DimString[I] = ']' then               { do not localize }
        SetLength(Dims[CurDim].Dims, 1);
      while (DimString[I] <> ']') and (I < StrLen) do     { do not localize }
      begin
        J := I;
        while (DimString[J] <> ']') and (J < StrLen) do       { do not localize }
        begin
          if DimString[J] = ',' then
            Inc(SubDims);
          Inc(J);
        end;
        SetLength(Dims[CurDim].Dims, SubDims);
        if SubDims > 1 then
        begin
          Dims[CurDim].MultiDim := True;
          while (DimString[I] <> ']') and (I < StrLen) do     { do not localize }
          begin
            DimSize := '';
            while (DimString[I] <> ',') and (DimString[I] <> ']') and (I < StrLen) do   { do not localize }
            begin
              DimSize := DimSize + DimString[I];
              Inc(I);
            end;
            if DimString[I] = ',' then
              Inc(I);
            if trim(DimSize) <> '' then
              Dims[CurDim].Dims[SubDim] := StrToInt(trim(DimSize))
            else
              Dims[CurDim].Dims[SubDim] := 0;
            Inc(SubDim);
          end
        end else
        begin
          while (DimString[I] <> ']') and (I < StrLen) do      { do not localize }
          begin
            DimSize := DimSize + DimString[I];
            Inc(I);
          end;
          if trim(DimSize) <> '' then
            Dims[CurDim].Dims[SubDim] := StrToInt(trim(DimSize))
          else
            Dims[CurDim].Dims[SubDim] := 0;
        end;
      end;
      Inc(I);
      Inc(CurDim);
    end else
      Inc(I);
  end;
end;

{ TOPToSoapDomConvert }

type
  PTObject = ^TObject;


{ Server Receives Message }
procedure TOPToSoapDomConvert.MsgToInvContext(const Request: InvString;
  const IntfMD: TIntfMetaData; var MethNum: Integer; Context: TInvContext);
var
  Stream: TStream;
begin
  Stream := TMemoryStream.Create;
  try
    Stream.Write(Request[1], Length(Request) * 2);
    Stream.Position := 0;
    MsgToInvContext(Stream, IntfMD, MethNum, Context, nil);
  finally
    Stream.Free;
  end;
end;

procedure TSoapDomConv.ReadHeader(const EnvNode, HdrNode: IXMLNode; Headers: THeaderList);
var
  HeaderName, HeaderNamespace: InvString;
  HeaderProcessor: IDOMHeaderProcessor;
  HeaderHandled, AbortRequest: Boolean;
  HeaderClsType: TClass;
  HeaderObject: TObject;
  HeaderNode: IXMLNode;
  ID: InvString;
begin
  HeaderNode := GetDataNode(EnvNode, HdrNode, ID);

  { Find out if we have something into which we can serialize this node }
  HeaderName := ExtractLocalName(HeaderNode.NodeName);
  HeaderNamespace := HeaderNode.NamespaceURI;

  HeaderClsType := InvRegistry.GetHeaderClass(HeaderName, HeaderNamespace);
  if HeaderClsType <> nil then
  begin
    if HeaderClsType.InheritsFrom(TRemotable) then
      HeaderObject := TRemotableClass(HeaderClsType).Create
    else
      HeaderObject := HeaderClsType.Create;
    ConvertSoapToNativeData(HeaderObject, HeaderClsType.ClassInfo, nil, EnvNode, HeaderNode, False, True, 0);
    Headers.Add(HeaderObject);
  end else
  begin
    { Old -D6- Header processing logic - left here simply because....}
    AbortRequest := False;
    HeaderProcessor := FindHeaderProcessor(HeaderNamespace, HeaderName, '');
    if HeaderProcessor <> nil then
      HeaderProcessor.ProcessHeader(HeaderNode, HeaderHandled, AbortRequest)
    else
    begin
      UnhandledNode(Format('%s:%s', [HeaderNamespace, HeaderName]), HeaderNode.XML);
      DefaultProcessHeader(HeaderNode, HeaderHandled, AbortRequest);
    end;
    if AbortRequest then
      raise ESOAPDomConvertError.CreateFmt(SHeaderError, [HeaderNamespace, HeaderName]);
  end;
end;

procedure TSoapDomConv.WriteHeader(const Header: TObject; RootNode, ParentNode: IXMLNode);
begin
  Options := Options + [soXXXXHdr];
  try
    ConvertNativeDataToSoap(RootNode, ParentNode,
                            Header.ClassName,
                            Header.ClassInfo,
                            Header, 0);
  finally
    Options := Options - [soXXXXHdr];
  end;
end;

{$IFDEF FASTER_CONVERTER}
procedure BuildHREFList(Converter: TSOAPDomConv; Node: IXMLNode);
var
  I: Integer;
  V: Variant;
  RefCache: TRefCache;
begin
{$IFDEF HIGHLANDER_UP}
  RefCache := Converter.FRefCache;
{$ELSE}
  RefCache := TRefCache(Converter.RefMap[0].Instance);
{$ENDIF}
  V := Node.Attributes[SXMLID];
  if not VarIsNull(V) then
  begin
    I := RefCache.FNodes.Add(Node);
    RefCache.FHREFs.AddObject(SHREFPre + V, TObject(I));
  end;

  if Node.HasChildNodes then
    for I := 0 to Node.ChildNodes.Count - 1 do
      BuildHREFList(Converter, Node.ChildNodes[I]);
end;

procedure CreateHREFList(Converter: TSOAPDomConv; Node: IXMLNode);
var
  RefCache: TRefCache;
begin
{$IFDEF HIGHLANDER_UP}
  RefCache := Converter.FRefCache;
{$ELSE}
  RefCache := TRefCache(Converter.RefMap[0].Instance);
{$ENDIF}
  RefCache.FHREFs.Clear;
  RefCache.FNodes.Clear;