* Applied patch from Andrew H. to make XML format more verbose

git-svn-id: trunk@32751 -

utils/fpdoc/dglobals.pp

@@ -132,6 +132,8 @@ resourcestring
   SCHMUsageMakeSearch = 'Automatically generate a Search Index from filenames that match *.htm*';
   SCHMUsageChmTitle= 'Title of the chm. Defaults to the value from --package';
 
+  SXMLUsageSource  = 'Include source file and line info in generated XML';
+
   // Linear usage
   SLinearUsageDupLinkedDocsP1 = 'Duplicate linked element documentation in';
   SLinearUsageDupLinkedDocsP2 = 'descendant classes.';

utils/fpdoc/dw_xml.pp

@@ -23,15 +23,20 @@ unit dw_XML;
 
 interface
 
-uses DOM, PasTree, dGlobals, dwriter, xmlWrite, SysUtils;
+uses DOM, PasTree, dGlobals, dwriter, xmlWrite, SysUtils, Classes;
 
 Type
 
   { TXMLWriter }
 
   TXMLWriter = Class(TFPDocWriter)
+  private
+    FShowSourceInfo: Boolean;
+  public
     function ModuleToXMLStruct(AModule: TPasModule): TXMLDocument;
     Procedure WriteDoc; override;
+    class procedure Usage(List: TStrings); override;
+    function  InterPretOption(const Cmd,Arg : String): boolean; override;
   end;
 
 
@@ -39,18 +44,179 @@ Type
 
 implementation
 
+const
+  DefaultVisibility = [visDefault, visPublic, visPublished, visProtected];
+
 function TXMLWriter.ModuleToXMLStruct(AModule: TPasModule): TXMLDocument;
 
 var
   ModuleElement: TDOMElement;
+  Doc: TXMLDocument absolute Result;
+
+  function VisibilityToString(vis: TPasMemberVisibility): String;
+  begin
+    case vis of
+      visDefault         : Result := '';
+      visPrivate         : Result := 'private';
+      visProtected       : Result := 'protected';
+      visPublic          : Result := 'public';
+      visPublished       : Result := 'published';
+      visAutomated       : Result := 'automated';
+      visStrictPrivate   : Result := 'strictprivate';
+      visStrictProtected : Result := 'strictprotected';
+    end;
+  end;
+
+  function Sanitize(AString: String): String;
+  var
+    i: Integer;
+  begin
+    Result := AString;
+    for i := 1 to length(Result) do
+      if Result[i] in [' '] then
+        Result[i] := '_';
+  end;
+
+  procedure AddSourceInfo(ADecl: TPasElement; AElement: TDOMElement);
+  var
+    SourceNode: TDOMElement;
+  begin
+    if not FShowSourceInfo then
+      Exit;
+    SourceNode := Doc.CreateElement('source');
+    SourceNode['line'] := IntToStr(ADecl.SourceLinenumber);
+    SourceNode['file'] := ADecl.SourceFilename;
+    AElement.AppendChild(SourceNode);
+  end;
+
+  procedure AddProcedureModifiers(ADecl: TPasProcedure; Node: TDOMElement);
+  begin
+    {pmVirtual , pmDynamic, pmAbstract, pmOverride,
+    pmExport, pmOverload, pmMessage, pmReintroduce,
+    pmStatic,pmInline,pmAssembler,pmVarargs, pmPublic,
+    pmCompilerProc,pmExternal,pmForward}
+
+    if (pmVirtual in ADecl.Modifiers) or (pmDynamic in ADecl.Modifiers) then
+      Node['virtual'] := 'true';
+    if pmAbstract in ADecl.Modifiers then
+      Node['abstract'] := 'true';
+    if pmStatic in ADecl.Modifiers then
+      Node['static'] := 'true';
+    if pmReintroduce in ADecl.Modifiers then
+      Node['reintroduce'] := 'true';
+    if pmOverload in ADecl.Modifiers then
+      Node['overload'] := 'true';
+    if pmForward in ADecl.Modifiers then
+      Node['forward'] := 'true';
+    if pmOverride in ADecl.Modifiers then
+      Node['override'] := 'true';
+  end;
+
+  procedure AddTypeNode(ToNode: TDOMElement; AType: String);
+  begin
+    ToNode.AttribStrings['type'] := AType;
+  end;
 
-  procedure ProcessProcedure(Proc: TPasProcedure; Element: TDOMElement);
+  function AddTypeNode(ToNode: TDOMElement; AType: TPasType): Boolean;
+  //var
+  //  TypeNode: TDOMElement;
+  begin
+    Result := False;
+    if not Assigned(AType) then
+      Exit;
+    //TypeNode := Doc.CreateElement('type');
+    //TypeNode.TextContent:=AType.Name;
+    //ToNode.AppendChild(TypeNode);
+    AddTypeNode(ToNode, AType.Name);
+    Result := True;
+  end;
+
+  procedure ProcessArgs(Args: TFPList; ProcNode: TDomElement);
+  var
+    i: Integer;
+    ArgNode: TDOMElement;
+    Arg: TPasArgument;
+  begin
+    for i := 0 to Args.Count-1 do
+    begin
+      Arg := TPasArgument(Args.Items[i]);
+      ArgNode := Doc.CreateElement('argument');
+      ArgNode.AttribStrings['name'] := Arg.Name;
+      AddTypeNode(ArgNode, Arg.ArgType);
+      ProcNode.AppendChild(ArgNode);
+    end;
+  end;
+
+  procedure DoVisibility(PasEl: TPasElement; Element: TDOMElement);
+  begin
+    if PasEl.Visibility <> visDefault then
+      Element['visibility'] := VisibilityToString(PasEl.Visibility);
+  end;
+
+  function ProcessProcedure(Proc: TPasProcedure; Element: TDOMElement): TDOMElement;
   var
     ProcEl: TDOMElement;
+    ReturnEl: TDOMElement;
   begin
-    ProcEl := Result.CreateElement(Proc.TypeName);
+    Result := nil;
+    ProcEl := Doc.CreateElement(Sanitize(Proc.TypeName));
     Element.AppendChild(ProcEl);
     ProcEl['name'] := Proc.Name;
+
+    DoVisibility(Proc, ProcEl);
+
+    AddProcedureModifiers(Proc, ProcEl);
+    AddSourceInfo(Proc,ProcEl);
+
+    if Proc.InheritsFrom(TPasFunction) then
+    begin
+      ReturnEl := Doc.CreateElement('return');
+      ProcEl.AppendChild(ReturnEl);
+      AddTypeNode(ReturnEl, TPasFunction(Proc).FuncType.ResultEl.ResultType);
+    end;
+
+    ProcessArgs(Proc.ProcType.Args, ProcEl);
+
+    Result := ProcEl;
+  end;
+
+  procedure ProcessArrayType(AType: TPasArrayType; Element: TDOMElement);
+  var
+    TypeEl: TDOMElement;
+  begin
+    TypeEl := Doc.CreateElement('array');
+    TypeEl['name'] := AType.Name;
+    if not AddTypeNode(TypeEl, AType.ElType) then
+      TypeEl['const'] := 'true';
+    TypeEl['range'] := AType.IndexRange;
+    DoVisibility(AType, Element);
+    AddSourceInfo(AType,Element);
+    Element.AppendChild(TypeEl);
+  end;
+
+  procedure ProcessPointerType(AType: TPasPointerType; Element: TDOMElement);
+  var
+    TypeEl: TDOMElement;
+  begin
+    TypeEl := Doc.CreateElement('pointer');
+    TypeEl['name'] := AType.Name;
+    AddTypeNode(TypeEl, AType.DestType);
+    DoVisibility(AType, Element);
+    AddSourceInfo(AType,Element);
+
+    Element.AppendChild(TypeEl);
+  end;
+
+  procedure ProcessAliasType(AType: TPasAliasType; Element: TDOMElement);
+  var
+    TypeEl: TDOMElement;
+  begin
+    TypeEl := Doc.CreateElement('alias');
+    TypeEl['name'] := AType.Name;
+    AddTypeNode(TypeEl, AType.DestType);
+    DoVisibility(AType, Element);
+    AddSourceInfo(AType,Element);
+    Element.AppendChild(TypeEl);
   end;
 
   procedure ProcessVariable(AVar: TPasVariable; Element: TDOMElement);
@@ -60,8 +226,291 @@ var
     VarEl := Result.CreateElement('var');
     Element.AppendChild(VarEl);
     VarEl['name'] := AVar.Name;
+    if not AVar.VarType.InheritsFrom(TPasArrayType) then
+      AddTypeNode(VarEl, AVar.VarType)
+    else
+    begin
+      VarEl['array'] := 'true';
+      ProcessArrayType(TPasArrayType(AVar.VarType), VarEl);
+    end;
+    DoVisibility(Avar, VarEl);
+    AddSourceInfo(AVar,VarEl);
+  end;
+
+  procedure ProcessProperty(AProp: TPasProperty; Element: TDOMElement);
+  var
+    PropEl: TDOMElement;
+  begin
+    PropEl := Doc.CreateElement('property');
+    Element.AppendChild(PropEl);
+
+    PropEl.AttribStrings['name'] := AProp.Name;
+    AddTypeNode(PropEL, AProp.ResolvedType);
+
+    if AProp.IndexValue <> '' then
+      PropEl['index'] := AProp.IndexValue;
+
+    if AProp.DefaultValue <> '' then
+      PropEl['default'] := AProp.DefaultValue;
+
+
+    if AProp.WriteAccessorName <> '' then
+      PropEl.AttribStrings['writable'] := 'true';
+
+    ProcessArgs(AProp.Args, PropEl);
+    DoVisibility(AProp, Element);
+    AddSourceInfo(AProp,PropEl);
+
+    // this isn't quite right
+    //if AProp.ReadAccessorName = '' then
+    //  PropEl.AttribStrings['inherited'] := 'true';
+  end;
+
+  procedure ProcessOverloadedProcedure(AOverload: TPasOverloadedProc; Element: TDOMElement);
+  var
+    OverEl: TDOMElement;
+    i: Integer;
+  begin
+    for i := 0 to AOverload.Overloads.Count-1 do
+    begin
+      OverEl := ProcessProcedure(TPasProcedure(AOverload.Overloads.Items[i]), Element);
+      OverEl['overload'] := 'true';
+    end;
+  end;
+
+  procedure ProcessConst(AConst: TPasConst; Element: TDOMElement);
+  var
+    ConstEl: TDOMElement;
+  begin
+    ConstEl := Doc.CreateElement('const');
+    ConstEl['name'] := AConst.name;
+    ConstEl['value'] := AConst.Value;
+    Element.AppendChild(ConstEl);
+    AddSourceInfo(AConst,ConstEl);
+  end;
+
+  procedure ProcessEnumType(AType: TPasEnumType; Element: TDOMElement);
+  var
+    TypeEl: TDOMElement;
+    ValEl: TDOMELement;
+    i: Integer;
+  begin
+    TypeEl := Doc.CreateElement('enum');
+    TypeEl['name'] := AType.name;
+    AddSourceInfo(AType,TypeEl);
+    //ConstEl['value'] := AConst.Value;
+    for i := 0 to AType.Values.Count-1 do
+    begin
+      ValEl := Doc.CreateElement('enumvalue');
+      ValEl['name'] := TPasEnumValue(AType.Values.Items[i]).Name;
+      AddSourceInfo(TPasEnumValue(AType.Values.Items[i]),ValEl);
+      TypeEl.AppendChild(ValEl);
+
+    end;
+    Element.AppendChild(TypeEl);
+  end;
+
+  procedure ProcessSetType(AType: TPasSetType; Element: TDOMElement);
+  var
+    SetEl: TDOMElement;
+  begin
+    SetEl := Doc.CreateElement('set');
+    SetEl['name'] := AType.name;
+    AddTypeNode(SetEl, AType.EnumType);
+    AddSourceInfo(AType,SetEl);
+    Element.AppendChild(SetEl);
+  end;
+
+  procedure ProcessProcedureType(AType: TPasProcedureType; Element: TDOMElement);
+  var
+    TypeEl: TDOMElement;
+  begin
+    TypeEl := Doc.CreateElement(AType.TypeName);
+    TypeEl['name'] := AType.name;
+    TypeEl['istype'] := 'true';
+    if AType.IsOfObject then
+      TypeEl['object'] := 'true';
+    ProcessArgs(AType.Args, TypeEl);
+    AddSourceInfo(AType,TypeEl);
+    Element.AppendChild(TypeEl);
+  end;
+
+  procedure ProcessRecordType(AType: TPasRecordType; Element: TDOMElement);
+  var
+    TypeEl: TDOMElement;
+    Decl: TPasElement;
+    i: Integer;
+  begin
+    TypeEl := Doc.CreateElement('record');
+    TypeEl['name'] := AType.name;
+
+    Element.AppendChild(TypeEl);
+    AddSourceInfo(AType,TypeEl);
+
+    if Assigned(AType.Members) then
+      for i := 0 to AType.Members.Count - 1 do
+      begin
+        Decl := TPasElement(AType.Members[i]);
+        if Decl.InheritsFrom(TPasProcedure)then
+          ProcessProcedure(TPasProcedure(Decl), TypeEl)
+        else if Decl.ClassType = TPasVariable then
+          ProcessVariable(TPasVariable(Decl), TypeEl)
+        else if Decl.ClassType = TPasProperty then
+          ProcessProperty(TPasProperty(Decl), TypeEl)
+        else writeln('Unhandled record member: ', Decl.ClassName, ' ', Decl.Name);
+      end;
+  end;
+
+  procedure ProcessGenericTypes(AGenericTypes: TFPList; ANode: TDOMElement);
+  var
+    i: Integer;
+    Node: TDOMElement;
+  begin
+    for i := 0 to AGenericTypes.Count-1 do
+    begin
+      Node := Doc.CreateElement('t');
+      Node['name'] := TPasGenericTemplateType(AGenericTypes.Items[i]).Name;
+      ANode.AppendChild(Node);
+      AddSourceInfo(TPasGenericTemplateType(AGenericTypes.Items[i]),Node);
+    end;
+  end;
+
+  procedure ProcessRangeType(AType: TPasRangeType; Element: TDOMElement);
+  var
+    TypeEl: TDOMElement;
+  begin
+    TypeEl := Doc.CreateElement('range');
+    TypeEl['name'] := AType.Name;
+    TypeEl['start'] := AType.RangeStart;
+    TypeEl['end'] := AType.RangeEnd;
+    AddSourceInfo(AType,TypeEl);
+
+    Element.AppendChild(TypeEl);
+
+  end;
+
+  procedure ProcessClassType(AClass: TPasClassType; Element: TDOMElement); forward;
+
+  function ProcessType(AType: TPasElement; Element: TDOMElement): Boolean;
+  begin
+    Result := True;
+    if AType.ClassType = TPasVariable then
+      ProcessVariable(TPasVariable(AType), Element)
+    else if AType.ClassType = TPasProperty then
+      ProcessProperty(TPasProperty(AType), Element)
+    else if AType.InheritsFrom(TPasOverloadedProc) then
+      ProcessOverloadedProcedure(TPasOverloadedProc(AType), Element)
+    else if AType.InheritsFrom(TPasConst) then
+      ProcessConst(TPasConst(AType), Element)
+    else if AType.InheritsFrom(TPasEnumType) then
+      ProcessEnumType(TPasEnumType(AType), Element)
+    else if AType.InheritsFrom(TPasClassType) then
+      ProcessClassType(TPasClassType(AType), Element)
+    else if AType.InheritsFrom(TPasAliasType) then
+      ProcessAliasType(TPasAliasType(AType), Element)
+    else if AType.InheritsFrom(TPasSetType) then
+      ProcessSetType(TPasSetType(AType), Element)
+    else if AType.InheritsFrom(TPasProcedureType) then
+      ProcessProcedureType(TPasProcedureType(AType), Element)
+    else if AType.InheritsFrom(TPasRecordType) then
+      ProcessRecordType(TPasRecordType(AType), Element)
+    else if AType.InheritsFrom(TPasArrayType) then
+      ProcessArrayType(TPasArrayType(AType), Element)
+    else if AType.InheritsFrom(TPasPointerType) then
+      ProcessPointerType(TPasPointerType(AType), Element)
+    else if AType.InheritsFrom(TPasRangeType) then
+      ProcessRangeType(TPasRangeType(AType), Element)
+    else
+      Result := False;
+  end;
+
+  procedure ProcessClassType(AClass: TPasClassType; Element: TDOMElement);
+  var
+    ClassEl: TDOMElement = nil;
+    i: Integer;
+    Decl: TPasElement;
+    SubNode: TDomElement;
+    InterfaceEl: TDomElement;
+    Vis: TPasMemberVisibilities = DefaultVisibility;
+  begin
+    if not Engine.HidePrivate then Include(Vis, visPrivate);
+    if Engine.HideProtected then Exclude(Vis, visProtected);
+    case AClass.ObjKind of
+      okClass: ClassEl := Result.CreateElement('class');
+      okObject: ClassEl := Result.CreateElement('object');
+      okInterface: ClassEl := Result.CreateElement('interface');
+      okSpecialize: ClassEl := Result.CreateElement('classspecialized');
+      //okGeneric: Result.CreateElement('generic');
+      //okClassHelper: Result.CreateElement('classhelper');
+      //okRecordHelper: Result.CreateElement('recordhelper');
+      //okTypeHelper: Result.CreateElement('typehelper');
+
+    else
+      //raise Exception.Create('ProcessClass: unknown class kind');
+      WriteLn('Unhandled Class kind: ', AClass.ObjKind);
+    end;
+
+    if Assigned(ClassEl) then
+    begin
+      Element.AppendChild(ClassEl);
+      ClassEl['name'] := AClass.Name;
+      if Assigned(AClass.AncestorType) then
+        ClassEl['parentclass'] := AClass.AncestorType.Name;
+
+      if AClass.ObjKind = okSpecialize then
+      begin
+        ProcessGenericTypes(AClass.GenericTemplateTypes, ClassEl);
+      end;
+      AddSourceInfo(AClass,ClassEl);
+
+      if Assigned(AClass.Interfaces) then
+        for i := 0 to AClass.Interfaces.Count-1 do
+        begin
+          InterfaceEl := Doc.CreateElement('interface');
+          ClassEl.AppendChild(InterfaceEl);
+          InterfaceEl['name'] := TPasElement(AClass.Interfaces.Items[i]).Name;
+        end;
+
+      if Assigned(AClass.Members) then
+      for i := 0 to AClass.Members.Count - 1 do
+      begin
+        Decl := TPasElement(AClass.Members[i]);
+        if not (Decl.Visibility in Vis) then
+          continue;
+        if Decl.InheritsFrom(TPasProcedure)then
+        begin
+          SubNode := ProcessProcedure(TPasProcedure(Decl), ClassEl);
+          if Assigned(SubNode) then
+          begin
+            if SubNode.InheritsFrom(TPasClassConstructor) then
+              SubNode.SetAttribute('type', 'constructor')
+            else if SubNode.InheritsFrom(TPasClassDestructor) then
+              SubNode.SetAttribute('type', 'destructor');
+          end;
+        end
+        else if not ProcessType(Decl, ClassEl) then
+          writeln('Unhandled class member: ', Decl.ClassName, ' ', Decl.Name);
+      end;
+    end;
+  end;
+
+  function FindInList(AName: String; AList: TFPList): Boolean;
+  var
+    El: TPasElement;
+    I: Integer;
+  begin
+    Result := False;
+    I := 0;
+    while not Result and (I < AList.Count) do
+    begin
+      El := TPasElement(AList[I]);
+      if El.Name = AName then
+        Result := True;
+      Inc(I);
+    end;
   end;
 
+
   procedure ProcessSection(ASection: TPasSection; const Name: DOMString);
   var
     Element, UsesElement, UnitElement: TDOMElement;
@@ -82,6 +531,25 @@ var
       end;
     end;
 
+    for i := 0 to ASection.Classes.Count -1 do
+    begin
+      Decl := TPasElement(ASection.Classes[i]);
+      ProcessClassType(TPasClassType(Decl), Element);
+    end;
+
+    for i := 0 to ASection.Consts.Count - 1 do
+    begin
+      Decl := TPasElement(ASection.Consts[i]);
+      ProcessConst(TPasConst(Decl), Element)
+    end;
+
+    for i := 0 to ASection.Types.Count - 1 do
+    begin
+      Decl := TPasElement(ASection.Types[i]);
+      if not ProcessType(Decl, Element) then
+        WriteLn('Unhandled type: ',Decl.ClassName, ' ', Decl.Name);
+    end;
+
     for i := 0 to ASection.Declarations.Count - 1 do
     begin
       Decl := TPasElement(ASection.Declarations[i]);
@@ -90,6 +558,23 @@ var
       else if Decl.ClassType = TPasVariable then
         ProcessVariable(TPasVariable(Decl), Element);
     end;
+
+    for i := 0 to ASection.Functions.Count - 1 do
+    begin
+      // many of these (all?) seem to be in ASection.Declarations
+      Decl := TPasElement(ASection.Functions[i]);
+      if FindInList(Decl.Name, ASection.Declarations) then
+        WriteLn('Duplicate proc definition in declarations. Skipping: ', Decl.Name)
+      else
+        WriteLn('Unhandled function: ',Decl.ClassName, ' ', Decl.Name);
+
+    end;
+
+    for i := 0 to ASection.Properties.Count - 1 do
+    begin
+      Decl := TPasElement(ASection.Properties[i]);
+      ProcessProperty(TPasProperty(Decl), Element);
+    end;
   end;
 
 
@@ -121,6 +606,20 @@ begin
   end;
 end;
 
+class procedure TXMLWriter.Usage(List: TStrings);
+begin
+  List.AddStrings(['--source-info', SXMLUsageSource]);
+end;
+
+function TXMLWriter.InterPretOption(const Cmd, Arg: String): boolean;
+begin
+  Result := True;
+  if Cmd = '--source-info' then
+    FShowSourceInfo:=True
+  else
+    Result:=inherited InterPretOption(Cmd, Arg);
+end;
+
 initialization
   // Do not localize.
   RegisterWriter(TXMLWriter,'xml','fpdoc XML output.');