webservexp.pas

delphi7 webservice soap 补丁

      if ((URI <> SXMLSchemaURI_2000_10) and (URI <> SXMLSchemaURI_1999) and (URI <> SXMLSchemaURI_2001))  then
      begin
        Prefix := GetPrefixForTypeInfo(ParamTypeInfo);
        Result := MakeNodeName(Prefix, GetXMLSchemaTypeName(ParamTypeInfo));
      end
      else
      begin
        { We always publish 2001 XMLSchema currently }
        URI := SXMLSchemaURI_2001;
        Prefix := GetPrefixForURI(Definition, URI);
        Result := MakeNodeName(Prefix, TypeName);
      end;
      bHasComplexTypes := True;
    end;
  else
    RemTypeRegistry.TypeInfoToXSD(ParamTypeInfo, URI, TypeName);
    if TypeName <> '' then
    begin
      Prefix := GetPrefixForURI(Definition, URI);
      Result := MakeNodeName(Prefix, TypeName);
    end
    else { When all fails - anything goes!! }
    begin
      Prefix := GetPrefixForURI(Definition, SXMLSchemaURI_2001);
      Result := MakeNodeName(Prefix, SAnyType);
    end;
  end;
end;

function TWebServExp.GetXMLSchemaTypeName(const ParamTypeInfo: PTypeInfo): WideString;
var
  URI: WideString;
begin
  Result := '';
  RemTypeRegistry.TypeInfoToXSD(ParamTypeInfo, URI, Result);
  if Result = '' then
    Result := ParamTypeInfo.Name;
end;

function GetAliasBaseTypeInfo(const ParamType: TTypeKind): PTypeInfo;
begin
  case ParamType of
    tkInteger:  Result := TypeInfo(System.Integer);
    tkInt64:    Result := TypeInfo(System.Int64);
    tkLString:  Result := TypeInfo(System.String);
    tkWString:  Result := TypeInfo(System.WideString);
  else
    Result := nil;
  end;
end;

function TWebServExp.IsComplexType(const ParamTypeInfo: PTypeInfo): Boolean;
var
  Name, URI: WideString;
  IsScalar: Boolean;
  Kind: TTypeKind;
begin
  Kind := ParamTypeInfo.Kind;
  Result := IsComplexType(Kind);

  { If not, could it be that we have an alias }
  if Result = False then
  begin
    { Handle a few alias kinds }
    if GetAliasBaseTypeInfo(Kind) <> nil then
    begin
      RemTypeRegistry.InfoToURI(ParamTypeInfo, URI, Name, IsScalar);
      { Provided the typeinfos don't map back to the XMLNamespace }
      if URI <> XMLSchemaNameSpace then
        Result := True;
    end;
  end;
end;

function TWebServExp.IsComplexType(const ParamType: TTypeKind ):Boolean;
begin
  case ParamType of
    tkClass, tkDynArray, tkEnumeration, tkSet:
      Result := True;
  else
    Result := False;
  end;
end;

function TWebServExp.GetPrefixForURI(Def: IDefinition; const URI: WideString): WideString;
var
  NameSpaceNode: IXMLNode;
begin

  Result := '';
  if Definition <> nil then
  begin
    NamespaceNode := Def.FindNamespaceDecl(URI);
    if NamespaceNode <> nil then
    begin
      Result := NamespaceNode.LocalName;
      exit;
    end;
    Result := AddNamespaceURI(Def as IXMLNode, URI);
  end;
end;


function TWebServExp.GetPrefixForURI(SchemaDef: IXMLSchemaDef; const URI: WideString): WideString;
var
  NameSpaceNode: IXMLNode;
begin
  Result := '';
  { Check if the XMLSchema root has it }
  NamespaceNode := SchemaDef.FindNamespaceDecl(URI);
  if NamespaceNode <> nil then
  begin
    Result := NamespaceNode.LocalName;
    exit;
  end
  else
  begin
    { Check if its a WSDL and if the root has it }
    if Definition <> nil then
    begin
      NamespaceNode := Definition.FindNamespaceDecl(URI);
      if NamespaceNode <> nil then
      begin
        Result := NamespaceNode.LocalName;
        exit;
      end
      else
        Result := AddNamespaceURI(Definition as IXMLNode, URI);
    end
    else
      Result := AddNamespaceURI(SchemaDef as IXMLNode, URI);
  end;
end;

function TWebServExp.AddNamespaceURI(RootNode: IXMLNode; const URI: WideString): WideString;
begin
  Result := RootNode.OwnerDocument.GeneratePrefix(RootNode);
  RootNode.DeclareNamespace(Result, URI);
end;


function TWebServExp.GetNodeNameForURI(SchemaDef: IXMLSchemaDef; const URI: WideString): WideString;
var
  NameSpaceNode: IXMLNode;
begin

  Result := '';
  { Check if the XMLSchema root has it }
  NamespaceNode := SchemaDef.FindNamespaceDecl(URI);
  if NamespaceNode <> nil then
  begin
    Result := NamespaceNode.NodeName;
    exit;
  end
  else
  begin
    { Check if its a WSDL and if the root has it }
    if Definition <> nil then
    begin
      NamespaceNode := Definition.FindNamespaceDecl(URI);
      if NamespaceNode <> nil then
        Result := NamespaceNode.NodeName;
    end;
  end;
end;


procedure TWebServExp.GenerateDerivedClassSchema(SchemaDef: IXMLSchemaDef; const ParentTypeInfo: PTypeinfo; const Namespace:WideString);
var
  Count, Index: Integer;
  RegEntry: TRemRegEntry;
begin
  Count := RemClassRegistry.GetURICount;
  for Index := 0 to Count -1 do
  begin
    RegEntry := RemClassRegistry.GetURIMap(Index);
    if RegEntry.ClassType <> nil then
    begin
      if RegEntry.ClassType.InheritsFrom(GetTypeData(ParentTypeInfo).ClassType)
       and (RegEntry.ClassType <> GetTypeData(ParentTypeInfo).ClassType) then
      begin
        GenerateXMLSchema(SchemaDef, RegEntry.Info, ParentTypeInfo, Namespace);
      end;
    end;
  end;
end;

(*
{ Similar to TypInfo's GetPropInfos except that we don't walk up the base classes }
procedure GetPropInfosInternal(TypeInfo: PTypeInfo; PropList: PPropList); assembler;
asm
        { ->    EAX Pointer to type info        }
        {       EDX Pointer to prop list        }
        { <-    nothing                         }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        XOR     ECX,ECX
        MOV     ESI,EAX
        MOV     CL,[EAX].TTypeInfo.Name.Byte[0]
        MOV     EDI,EDX
        XOR     EAX,EAX
        MOVZX   ECX,[ESI].TTypeInfo.Name[ECX+1].TTypeData.PropCount
        REP     STOSD

@outerLoop:
        MOV     CL,[ESI].TTypeInfo.Name.Byte[0]
        LEA     ESI,[ESI].TTypeInfo.Name[ECX+1]
        MOV     CL,[ESI].TTypeData.UnitName.Byte[0]
        MOVZX   EAX,[ESI].TTypeData.UnitName[ECX+1].TPropData.PropCount
        TEST    EAX,EAX
        JE      @parent
        LEA     EDI,[ESI].TTypeData.UnitName[ECX+1].TPropData.PropList

@innerLoop:

        MOVZX   EBX,[EDI].TPropInfo.NameIndex
        MOV     CL,[EDI].TPropInfo.Name.Byte[0]
        CMP     dword ptr [EDX+EBX*4],0
        JNE     @alreadySet
        MOV     [EDX+EBX*4],EDI

@alreadySet:
        LEA     EDI,[EDI].TPropInfo.Name[ECX+1]
        DEC     EAX
        JNE     @innerLoop

@parent:
@exit:
        POP     EDI
        POP     ESI
        POP     EBX
end;

function GetPropListInternal(TypeInfo: PTypeInfo; out PropList: PPropList): Integer;
begin
  Result := GetTypeData(TypeInfo)^.PropCount;
  if Result > 0 then
  begin
    GetMem(PropList, Result * SizeOf(Pointer));
    FillChar(PropList^, Result * SizeOf(Pointer), 0);
    GetPropInfosInternal(TypeInfo, PropList);
  end;
end;

{ Similar to TypInfo's IsStoredProp although this version only handles cases
  where the attribute was assigned 'true' or 'false' directly }
function IsStoredPropInternal(Instance: TObject; PropInfo: PPropInfo): Boolean;
asm
        { ->    EAX Pointer to Instance         }
        {       EDX Pointer to prop info        }
        { <-    AL  Function result             }

        MOV     ECX,[EDX].TPropInfo.StoredProc
        TEST    ECX,0FFFFFF00H
        JE      @@returnCL
        MOV     CL, 1
@@returnCL:
        MOV     AL,CL
@@exit:
end;

{ Returns the TypeInfo of a class member }
function GetMemberTypeInfo(const ObjectTypeInfo: PTypeInfo; const MemberName: string): PTypeInfo;
var
  PropList: PPropList;
  Size, Props: Integer;
begin
  Result := nil;
  Size := GetPropListInternal(ObjectTypeInfo, PropList);
  try
    for Props := 0 to Size -1 do
    begin
      if PropList[Props] <> nil then
      begin
        { Either there's a match or send the only member's TypeInfo back }
        if SameText(PropList[Props].Name, MemberName) or ((MemberName = '') and (Size = 1)) then
        begin
          Result := PropList[Props].PropType^;
          Exit;
        end;
      end;
    end;
  finally
    if Size > 0 then
      FreeMem(PropList);
  end;
end;
 *)

procedure TWebServExp.GenerateClassSchema(SchemaDef: IXMLSchemaDef;
                                          const ATypeInfo, ParentInfo: PTypeinfo;
                                          const Namespace: WideString);
var
  Size, Props: integer;
  PropList: PPropList;
  ComplexType: IXMLComplexTypeDef;
  ElementType: IXMLElementDef;
  AttributeType: IXMLAttributeDef;
  ParamType: string;
  BaseName, Pre, PropName: WideString;
  AncInfo: PTypeInfo;
  SerialOpts: TSerializationOptions;
begin
  Size := GetPropListFlat(ATypeInfo, PropList);
  try
    { Catch case where class is simply an alias wrapper for a simple type }
    SerialOpts := RemClassRegistry.SerializeOptions(GetTypeData(ATypeInfo).ClassType);
    if (xoSimpleTypeWrapper in SerialOpts) and (Size = 1) then
    begin
      { The class is considered as an alias of the type of it's sole (published) member }
      GenerateAliasSchema(SchemaDef, ATypeInfo, Namespace, PropList[0].PropType^);
    end
    else
    begin
      if ParentInfo <> nil then
      begin
        { Namespace prefix of base type }
        Pre := GetPrefixForTypeInfo(ParentInfo);
        if Pre <> '' then
          BaseName := MakeNodeName(Pre, ParentInfo.Name)
        else
          BaseName := ParentInfo.Name;

        { Does the parent have a parent ?? }
        if GetTypeData(ParentInfo).ParentInfo <> nil then
          AncInfo := GetTypeData(ParentInfo).ParentInfo^
        else
          AncInfo := nil;

        { If yes, validate Grandparent }
        if (AncInfo <> nil) and IsBaseClassTypeInfo(AncInfo) then
          AncInfo := nil;

        { Generate parent schema }
        GenerateXMLSchema(SchemaDef, ParentInfo, AncInfo, Namespace);

        { Add this type's complex type }
        ComplexType := SchemaDef.ComplexTypes.Add(GetXMLSchemaTypeName(ATypeInfo), BaseName)
      end else
        ComplexType := SchemaDef.ComplexTypes.Add(GetXMLSchemaTypeName(ATypeInfo));

      { And the properties }
      for Props := 0 to Size -1 do
      begin
        if PropList[Props] <> nil then
        begin
          ParamType := GetXMLSchemaType(PropList[Props].PropType^);
          PropName := RemClassRegistry.GetExternalPropName(ATypeInfo, PropList[Props].Name);
          if IsStoredPropConst(nil, PropList[Props]) then
            ElementType := ComplexType.ElementDefs.Add(PropName, ParamType)
          else
            AttributeType := ComplexType.AttributeDefs.Add(PropName, ParamType);
          if IsComplexType(PropList[Props].PropType^) then
            GenerateXMLSchema(SchemaDef, PropList[Props].PropType^, nil, Namespace);
        end;
      end;
    end;