webservexp.pas

delphi7 webservice soap 补丁

  finally
    if Size > 0 then
      FreeMem(PropList);
  end;
end;


procedure TWebServExp.GenerateEnumSchema(SchemaDef: IXMLSchemaDef; const ATypeInfo: PTypeinfo; const Namespace: WideString);
var
  SimpleType: IXMLSimpleTypeDef;
  TypeData: PTypeData;
  Index: Integer;
  Value: string;
  EnumInfo: PTypeInfo;
begin
  EnumInfo := ATypeInfo;

  { Here we need to shortcircuit ByteBool, WordBool and LongBool - the
    RTTI/Compiler treats them as enumerations with 256, 32K and 2G members
    respectively - We don't want to publish these members:) }
  if (EnumInfo = TypeInfo(System.ByteBool)) or
     (EnumInfo = TypeInfo(System.WordBool)) or
     (EnumInfo = TypeInfo(System.LongBool)) then
    EnumInfo := TypeInfo(System.Boolean);
  TypeData := GetTypeData(EnumInfo);
  if TypeData <> nil then
  begin
    SimpleType := SchemaDef.SimpleTypes.Add(GetXMLSchemaTypeName(ATypeInfo), 'string'); { do not localize }
    for Index := 0 to TypeData.MaxValue do
    begin
      Value := GetEnumName(ATypeInfo, Index);
      SimpleType.Enumerations.Add(RemClassRegistry.GetExternalPropName(EnumInfo, Value));
    end;
  end;
end;

procedure TWebServExp.GenerateAliasSchema(SchemaDef: IXMLSchemaDef; const ATypeInfo: PTypeinfo; const Namespace: WideString;
                                          const ABaseTypeInfo: PTypeInfo = nil);
var
  SimpleType: IXMLSimpleTypeDef;
  TypeData: PTypeData;
  BaseInfo: PTypeInfo;
  TypeName: WideString;
begin
  TypeData := GetTypeData(ATypeInfo);
  if TypeData <> nil then
  begin
    { Name ?? }
    TypeName := ATypeInfo.Name;
    { Base Type Info }
    if ABaseTypeInfo = nil then
      BaseInfo := GetAliasBaseTypeInfo(ATypeInfo.Kind)
    else
      BaseInfo := ABaseTypeInfo;
    { Add type }
    SimpleType := SchemaDef.SimpleTypes.Add(GetXMLSchemaTypeName(ATypeInfo), TypeName);
    SimpleType.BaseTypeName := GetXMLSchemaType(BaseInfo);
  end;
end;

procedure TWebServExp.GenerateArraySchema(SchemaDef: IXMLSchemaDef; const ATypeInfo: PTypeinfo; const Namespace: WideString);
var
  ComplexType: IXMLComplexTypeDef;
  ElementType: IXMLElementDef;
  ElementTypeInfo: PTypeinfo;
  I, Dimensions: integer;
  ParamType, ArrayElementName: string;
  ArrayType: string;
  TypeName, Prefix, SoapEncPrefix: WideString;
  AttrDef: IXMLAttributeDef;
  DimString, ArrayName, TempName: string;
  XMLElementDefs: IXMLElementDefs;
begin
  if FArrayAsComplexContent then
  begin
    ElementTypeInfo := GetDynArrayNextInfo2(ATypeInfo, ArrayName);
    Dimensions := 1;
    while (ElementTypeInfo <> nil) and  (ElementTypeInfo.Kind = tkDynArray ) and (ElementTypeInfo.Name[1] = '.') do
    begin
      Inc(Dimensions);
      ElementTypeInfo := GetDynArrayNextInfo2(ElementTypeInfo, TempName);
    end;
    if (ElementTypeInfo = nil) or (ElementTypeInfo.Name[1] = '.') then
      GetDynArrayElTypeInfo(ATypeInfo, ElementTypeInfo, Dimensions);
    {
    if (ElementTypeInfo.Kind = tkDynArray) and (ArrayName <> '') and (ArrayName[1] <> '.') then
      GenerateArraySchema(RootNode, ElementTypeInfo, Namespace);
    if (ElementTypeInfo.Kind = tkClass) or (ElementTypeInfo.Kind = tkEnumeration) then
      GenerateXMLSchema(RootNode, ElementTypeInfo, nil, Namespace);
    }
    ParamType := GetXMLSchemaType(ElementTypeInfo);
    ArrayType := SArrayOf + ParamType;
    { Get Soap Encoding prefix }
    SoapEncPrefix := GetPrefixForURI(SchemaDef,  SSoap11EncodingS5);
    TypeName := GetXMLSchemaTypeName(ATypeInfo);
    ComplexType := SchemaDef.ComplexTypes.Add(TypeName, SoapEncPrefix + ':' + SSoapEncodingArray, dmComplexRestriction);
    AttrDef:= ComplexType.AttributeDefs.Add(SoapEncPrefix + ':'+ SArrayType);
    { Get WSDL URI prefix }
    Prefix := GetNodeNameForURI(SchemaDef, Wsdlns);
    { Create dimension string }
    DimString := '[';
    if (Dimensions > 1) then
      for I := 1 to Dimensions-1 do
        DimString := DimString + ',';
    DimString := DimString + ']';

{$IFDEF OPENDOM}
    AttrDef.DeclareNameSpace('n1', Wsdlns);
    AttrDef.SetAttributeNS(SArrayType, Wsdlns, ParamType + DimString);
{$ELSE}
    AttrDef.Attributes['n1'+':'+SArrayType] := ParamType + DimString;
    AttrDef.Attributes[Prefix+':'+'n1'] := Wsdlns;
{$ENDIF}
  end
  else
  begin
    GetDynArrayElTypeInfo(ATypeInfo, ElementTypeInfo, Dimensions);
    ParamType := GetXMLSchemaType(ElementTypeInfo);
    ArrayType := SArrayOf + ParamType;
    XMLElementDefs := SchemaDef.ElementDefs;
    Prefix := GetPrefixForURI(SchemaDef, Soapns);
    TypeName := GetXMLSchemaTypeName(ATypeInfo);
    ElementType := XMLElementDefs.Add(TypeName, True, MakeNodeName(Prefix, SArray));
  {  ElementType := RootNode.SchemaDef.ElementDefs.Add(ATypeInfo.Name, True, SSoapArray); }
  {  ElementType := SchemaDef.ElementDefs.Add(ATypeInfo.Name, True, SSoapArray); }
    ComplexType := ElementType.DataType as IXMLComplexTypeDef;
    ComplexType.Attributes[SName] := ArrayType;

    if Dimensions > 1  then
      GenerateNestedArraySchema(SchemaDef, ComplexType, ElementTypeInfo, Dimensions, Namespace)
    else
    begin
      ArrayElementName := 'Dimension' + IntToStr(Dimensions);
      ParamType := GetXMLSchemaType(ElementTypeInfo);
      ElementType := ComplexType.ElementDefs.Add(ArrayElementName, ParamType);
      ElementType.Attributes[SMaxOccurs] := SUnbounded;

      if IsComplexType(ElementTypeInfo) then
        GenerateXMLSchema(SchemaDef, ElementTypeInfo, nil, Namespace);
    end;
  end;
end;


procedure TWebServExp.GenerateNestedArraySchema(SchemaDef: IXMLSchemaDef; ComplexType: IXMLComplexTypeDef; const ATypeInfo: PTypeinfo; var Dimension: Integer; Namespace: WideString);
var
  ParamType: string;
  ArrayElementName: String;
  ElementType: IXMLElementDef;
  NestedType: IXMLComplexTypeDef;
begin
  while Dimension <> 0 do
  begin
    if Dimension > 1  then
    begin
      ArrayElementName := 'Dimension' + IntToStr(Dimension);
      ElementType := ComplexType.ElementDefs.Add(ArrayElementName, True);
      ElementType.Attributes[SMaxOccurs] := SUnbounded;
      NestedType := ElementType.DataType as IXMLComplexTypeDef;
      Dimension := Dimension -1;
      GenerateNestedArraySchema(SchemaDef, NestedType, ATypeInfo, Dimension, Namespace);
    end
    else
    begin
      ArrayElementName := 'Dimension' + IntToStr(Dimension);
      ParamType := GetXMLSchemaType(ATypeInfo);
      ElementType := ComplexType.ElementDefs.Add(ArrayElementName, ParamType);
      ElementType.Attributes[SMaxOccurs] := SUnbounded;
      Dimension := Dimension -1;

      if IsComplexType(ATypeInfo) then
        GenerateXMLSchema(SchemaDef, ATypeInfo, nil, Namespace);
    end;
  end; //while
end;


procedure TWebServExp.GenerateXMLSchema(SchemaDef: IXMLSchemaDef; const ATypeInfo, ParentInfo: PTypeinfo; Namespace: WideString);
var
  TempURI, TempName: WideString;
  AncInfo: PTypeInfo;
begin
  if  IsComplexType(ATypeInfo) then
  begin
    { NOTE: IsSchemaGenerated will toggle the generated flag if it returns false }
    if (not IsSchemaGenerated(ATypeInfo, Namespace)) then
    begin
      case ATypeInfo.Kind  of
        tkDynArray:     GenerateArraySchema(SchemaDef, ATypeInfo, NameSpace);
        tkEnumeration:  GenerateEnumSchema(SchemaDef, ATypeInfo, NameSpace);
        tkClass:
          begin
            { Determine the base class info. }
            if (ParentInfo = nil) and ((GetTypeData(ATypeInfo).ParentInfo)^ <> nil) then
            begin
              AncInfo := (GetTypeData(ATypeInfo).ParentInfo)^;
              { Stop as soon as we get to a base class }
              if (AncInfo <> nil) and IsBaseClassTypeInfo(AncInfo) then
                AncInfo := nil;
              { Or something not registered }
              if (AncInfo <> nil) and not RemTypeRegistry.TypeInfoToXSD(AncInfo, TempURI , TempName) then
                AncInfo := nil;
            end else
              AncInfo := ParentInfo;

            { Generate the class schemae }
            GenerateClassSchema(SchemaDef, ATypeInfo, AncInfo, Namespace);

            { Generate XML Schema for registered derived classes }
            GenerateDerivedClassSchema(SchemaDef, ATypeInfo, Namespace);
          end;
        else
        begin
          { Generate alias }
          if GetAliasBaseTypeInfo(ATypeInfo.Kind) <> nil then
            GenerateAliasSchema(SchemaDef, ATypeInfo, NameSpace);
        end
      end;
    end;
  end;
end;


procedure TWebServExp.GetAllSchemaTypes(const IntfMD: TIntfMetaData);
var
  I, Methods, Params, NoOfMethods, NoOfParams: Integer;
  IntfMethArray: TIntfMethEntryArray;
  ParamArray: TIntfParamEntryArray;
  HeaderItems: THeaderItemArray;
  ExceptItems: TExceptionItemArray;
begin
  IntfMethArray := nil;
  ParamArray    := nil;
  IntfMethArray := IntfMD.MDA;
  NoOfMethods   := Length(IntfMethArray);

  for Methods := 0 to NoOfMethods -1 do
  begin
    ParamArray := IntfMD.MDA[Methods].Params;
    NoOfParams := Length(ParamArray);

    { Note: Skip this/Self }
    for Params := 0 to NoOfParams -2 do
    begin
      if IsComplexType(ParamArray[Params].Info) then
        GetSchemaTypes(ParamArray[Params].Info, nil);
    end;

    { For Function return type }
    if IntfMD.MDA[Methods].ResultInfo <> nil  then
    begin
      { If the return type is an object }
      if IsComplexType(IntfMD.MDA[Methods].ResultInfo) then
        GetSchemaTypes(IntfMD.MDA[Methods].ResultInfo, nil);
    end;
  end;

  { Add all headers of interface to types }
  HeaderItems := InvRegistry.GetHeaderInfoForInterface(IntfMD.Info);
  for I := 0 to Length(HeaderItems) -1 do
    GetSchemaTypes(HeaderItems[I].ClassType.ClassInfo, nil);

  { And all faults of interface to types }
  ExceptItems := InvRegistry.GetExceptionInfoForInterface(IntfMD.Info);
  for I := 0 to Length(ExceptItems) -1 do
    GetSchemaTypes(ExceptItems[I].ClassType.ClassInfo, nil);
end;


procedure TWebServExp.GetDerivedClassSchema(const ParentTypeInfo: PTypeinfo);
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) then
        GetSchemaTypes(RegEntry.Info, ParentTypeInfo);
    end;
  end;
end;

function TWebServExp.FindOrAddSchema(const ATypeInfo: PTypeinfo; const TnsURI: string): Boolean;
var
  Index: Integer;
begin
  Result := False;

  { Do not register Empty TnsURI or tkSet or any predefined type from XMLSchema }
  if ((TnsURI = '') or (ATypeInfo.Kind = tkSet) or (TnsURI = SXMLSchemaURI_1999) or  (TnsURI = SXMLSchemaURI_2000_10) or
    (TnsURI = SXMLSchemaURI_2001))  then
  begin
    Result := True;
    Exit;
  end;

  for Index := 0 to Length(SchemaArray) -1 do
  begin
    if SchemaArray[Index].TypeInfo = ATypeInfo then
    begin
      Result := True;
      Exit;
    end;
  end;

  { Add new type }
  Index := Length(SchemaArray);
  SetLength(SchemaArray, Index+1);
  SchemaArray[Index].TypeName := GetXMLSchemaTypeName(ATypeInfo);
  SchemaArray[Index].NameSpace := TnsURI;
  SchemaArray[Index].TypeInfo := ATypeInfo;
  SchemaArray[Index].XSGenerated := False;
end;

{ NOTE: IsSchemaGenerated has a nasty side-effect - if the generated flag is false, it will
        toggle it - Argghh!! }
function TWebServExp.IsSchemaGenerated(const ATypeInfo: PTypeinfo; const TnsURI: WideString): Boolean;
var
  Index: Integer;
begin
  Result := True;
  for Index := 0 to Length(SchemaArray) -1 do
  begin
    if ((SchemaArray[Index].TypeInfo = ATypeInfo) and
      (SchemaArray[Index].NameSpace = TnsURI) ) then
    begin
      if  SchemaArray[Index].XSGenerated = False then
      begin
        Result := False;
        SchemaArray[Index].XSGenerated := True;
      end
      else
        Result := True;
      Exit;
    end;
  end;
end;


function  TWebServExp.GetPrefixForTypeInfo(const ATypeInfo: PTypeinfo): WideString;
var
  Index: Integer;
begin
  Result := '';
  for Index := 0 to Length(SchemaArray) -1 do
  begin
    if (SchemaArray[Index].TypeInfo = ATypeInfo) then
    begin
      Result := SchemaArray[Index].NSPrefix;
      exit;
    end;
  end;
end;

{ This routines collects all sc