* Improved class tree building

git-svn-id: trunk@47537 -

utils/fpdoc/dw_html.pp

@@ -2412,17 +2412,21 @@ procedure THTMLWriter.CreateClassHierarchyPage(AList : TStringList; AddUnit : Bo
     PushOutputNode(h);
   end;
 
-  Procedure AppendClass(E : TDomElement);
+  Procedure AppendClass(E : TPasElementNode);
 
   Var
     N : TDomNode;
-    P,PM : TPasElement;
+    P,PM,M : TPasElement;
     EN : String;
     LL : TstringList;
     I,J : Integer;
 
   begin
-    EN:=Package.Name+'.'+UTF8Encode(E['unit'])+'.'+UTF8Encode(E.NodeName);
+    M:=E.Element.GetModule;
+    if (M<>Nil) then
+      EN:=Package.Name+'.'+UTF8Encode(M.Name)+'.'+UTF8Encode(E.Element.Name)
+    else
+      EN:=UTF8Encode(E.Element.Name);
     J:=AList.IndexOf(EN);
     If J<>-1 then
       P:=AList.Objects[J] as TPasElement
@@ -2442,30 +2446,17 @@ procedure THTMLWriter.CreateClassHierarchyPage(AList : TStringList; AddUnit : Bo
           end
         end
       else
-        AppendText(CurOutputNode,E.Nodename);
+        AppendText(CurOutputNode,E.Element.Name);
-      LL:=TStringList.Create;
+      if E.ChildCount>0 then
-      try
+        begin
-        N:=E.FirstChild;
+        PushClassList;
-        While (N<>Nil) do
+        try
-          begin
+          For I:=0 to E.ChildCount-1 do
-          if (N.NodeType=ELEMENT_NODE) then
+            AppendClass(E.Children[i] as TPasElementNode);
-            LL.AddObject(UTF8Encode(N.NodeName),N);
+        finally
-          N:=N.NextSibling;
+          PopOutputNode;
-          end;
+        end;
-        if (LL.Count>0) then
+        end;
-          begin
-          LL.Sorted:=true;
-          PushClassList;
-          try
-            For I:=0 to LL.Count-1 do
-              AppendClass(LL.Objects[i] as TDomElement);
-          finally
-            PopOutputNode;
-          end;
-          end;
-      finally
-        LL.Free;
-      end;
     Finally
       PopOutputNode;
     end;
@@ -2473,7 +2464,8 @@ procedure THTMLWriter.CreateClassHierarchyPage(AList : TStringList; AddUnit : Bo
 
 Var
   B : TClassTreeBuilder;
-  E : TDomElement;
+  E : TPasElementNode;
+
 begin
   PushOutputNode(BodyElement);
   try
@@ -2483,7 +2475,7 @@ begin
       // Classes
       // WriteXMLFile(B.ClassTree,'tree.xml');
       // Dummy TObject
-      E:=B.ClassTree.DocumentElement;
+      E:=B.RootNode;
       PushClassList;
       try
         AppendClass(E);

utils/fpdoc/fpdocclasstree.pp

@@ -5,188 +5,184 @@ unit fpdocclasstree;
 interface
 
 uses
-  Classes, SysUtils, DOM, pastree;
+  Classes, SysUtils, DOM, pastree, contnrs;
 
 Type
+
+  { TPasElementNode }
+
+  TPasElementNode = Class
+  Private
+    FElement : TPasElement;
+    FChildren : TFPObjectList;
+    function GetChild(aIndex : Integer): TPasElementNode;
+    function GetChildCount: Integer;
+  Public
+    Constructor Create (aElement : TPaselement);
+    Destructor Destroy; override;
+    Procedure AddChild(C : TPasElementNode);
+    Procedure SortChildren;
+    Property Element : TPasElement Read FElement;
+    Property Children [aIndex : Integer] : TPasElementNode Read GetChild;
+    Property ChildCount : Integer Read GetChildCount;
+  end;
+
+  { TClassTreeBuilder }
+
   TClassTreeBuilder = Class
   Private
-    FClassTree : TXMLDocument;
+    // Full name -> TDomElement;
-    FTreeStart : TDomElement;
+    FElementList : TFPObjectHashTable;
     FObjectKind : TPasObjKind;
     FPackage: TPasPackage;
     FParentObject : TPasClassType;
+    FRootNode : TPasElementNode;
+    FRootObjectName : string;
   Protected
-    function LookForElement(PE: TDomElement; AElement: TPasElement; NoPath : Boolean): TDomNode;
+    function AddToList(aElement: TPasClassType): TPasElementNode;
-    function NodeMatch(N: TDomNode; AElement: TPasElement; NoPath : Boolean): Boolean;
-    Function AddToClassTree(AElement : TPasElement; Var ACount : Integer) : TDomElement;
   Public
     Constructor Create(APackage : TPasPackage; AObjectKind : TPasObjKind = okClass);
     Destructor Destroy; override;
     Function BuildTree(AObjects : TStringList) : Integer;
-    Property ClassTree : TXMLDocument Read FClassTree;
+    Property RootNode : TPasElementNode Read FRootNode;
   end;
 
 implementation
 
+{ TPasElementNode }
+
+function SortOnElementName(Item1, Item2: Pointer): Integer;
+begin
+  Result:=CompareText(TPasElementNode(Item1).Element.Name,TPasElementNode(Item2).Element.Name);
+end;
+
+function TPasElementNode.GetChild(aIndex : Integer): TPasElementNode;
+begin
+  if Assigned(FChildren) then
+    Result:=TPasElementNode(FChildren[aIndex])
+  else
+    Raise EListError.Create('Index out of range');
+end;
+
+function TPasElementNode.GetChildCount: Integer;
+begin
+  if Assigned(FChildren) then
+    Result:=FChildren.Count
+  else
+    Result:=0
+end;
+
+constructor TPasElementNode.Create(aElement: TPaselement);
+begin
+  FElement:=aElement;
+end;
+
+destructor TPasElementNode.Destroy;
+begin
+  FreeAndNil(FChildren);
+  inherited Destroy;
+end;
+
+procedure TPasElementNode.AddChild(C: TPasElementNode);
+begin
+  if FChildren=Nil then
+    FChildren:=TFPObjectList.Create(True);
+  FChildren.Add(C);
+end;
+
+procedure TPasElementNode.SortChildren;
+begin
+  if Assigned(FChildren) then
+    FChildren.Sort(@SortOnElementName);
+end;
+
 constructor TClassTreeBuilder.Create(APackage : TPasPackage;
   AObjectKind: TPasObjKind);
 
 begin
-  FCLassTree:=TXMLDocument.Create;
   FPackage:=APAckage;
   FObjectKind:=AObjectKind;
   Case FObjectkind of
-    okObject    : FParentObject:=TPasClassType.Create('System.TObject',FPackage);
+    okInterface : FRootObjectName:='#rtl.System.IInterface';
-    okClass     : FParentObject:=TPasClassType.Create('System.TObject',FPackage);
+    okObject,
-    okInterface : FParentObject:=TPasClassType.Create('System.IInterface',FPackage);
+    okClass    : FRootObjectName:='#rtl.System.TObject';
+  else
+    FRootObjectName:='#rtl.System.TObject';
   end;
+  FParentObject:=TPasClassType.Create(FRootObjectName,FPackage);
   FParentObject.ObjKind:=FObjectKind;
-  FTreeStart:=FClassTree.CreateElement('TObject');
+  FRootNode:=TPasElementNode.Create(FParentObject);
-  FTreeStart['unit']:='System';
+  FElementList:=TFPObjectHashTable.Create(False);
-  ClassTree.AppendChild(FTreeStart);
+  FElementList.Add(FRootObjectName,FRootNode);
 end;
 
 destructor TClassTreeBuilder.Destroy;
 begin
   FreeAndNil(FParentObject);
-  FreeAndNil(FClassTree);
+  FreeAndNil(FRootNode);
+  FreeAndNil(FElementList);
   Inherited;
 end;
 
+Function TClassTreeBuilder.AddToList(aElement : TPasClassType) : TPasElementNode;
+
+Var
+  aParentNode : TPasElementNode;
+  aName : String;
+
+begin
+  if aElement=Nil then
+    aName:=FRootObjectName
+  else
+    begin
+    aName:=aElement.PathName;
+    end;
+  Result:=TPasElementNode(FElementList.Items[aName]);
+  if (Result=Nil) then
+    begin
+    if aElement.AncestorType is TPasClassType then
+      aParentNode:=AddToList(aElement.AncestorType as TPasClassType)
+    else
+      aParentNode:=FRootNode;
+    Result:=TPasElementNode.Create(aElement);
+    aParentNode.AddChild(Result);
+    FElementList.Add(aName,Result);
+    end;
+end;
+
+
 Function TClassTreeBuilder.BuildTree(AObjects : TStringList) : Integer;
 
+(*
+Procedure DumpNode(Prefix : String; N : TPasElementNode);
+
+  Var
+    I : Integer;
+
+  begin
+    Writeln(Prefix,N.FElement.Name);
+    if Assigned(N.FChildren) then
+       For I:=0 to N.FChildren.Count-1 do
+         DumpNode(Prefix+'  ',TPasElementNode(N.FChildren[i]));
+  end;
+*)
+
 Var
   I : Integer;
   PC : TPasClassType;
 
 begin
   Result:=0;
-  AObjects.Sorted:=True;
   For I:=0 to AObjects.Count-1 do
     // Advanced records
     if AObjects.Objects[i] is TPasClassType then
       begin
       PC:=AObjects.Objects[i] as TPasClassType;
-      If (PC.ObjKind=FObjectKind) and Not PC.IsForward then
+      AddToList(PC);
-        AddToClassTree(PC,Result);
       end;
 end;
 
-Function TClassTreeBuilder.NodeMatch(N : TDomNode; AElement : TPasElement; NoPath : Boolean) : Boolean;
 
-Var
-  PN,S,EN : String;
-
-begin
-  EN:=AELement.Name;
-  Result:=(N.NodeType=ELEMENT_NODE);
-  if Result then
-    begin
-    S:=UTF8Encode(N.NodeName);
-    if NoPath then
-      Begin
-      Result:=CompareText(S,EN)=0;
-      end
-    else
-      begin
-      IF Assigned(Aelement.GetModule) then
-        PN:=Aelement.GetModule.PackageName
-      else
-        PN:=FPackage.Name;
-      S:=PN+'.'+UTF8Encode(TDomElement(N)['unit'])+'.'+S;
-      Result:=(CompareText(S,AElement.PathName)=0);
-      end;
-   end;
-end;
-
-Function TClassTreeBuilder.LookForElement(PE : TDomElement; AElement : TPasElement; NoPath : boolean) : TDomNode;
-
-Var
-  N : TDomNode;
-
-begin
-//  Writeln('Enter TClassTreeBuilderLookForElement');
-  Result:=PE;
-  While (Result<>Nil) and Not NodeMatch(Result,AElement,NoPath) do
-    Result:=Result.NextSibling;
-  If (Result=Nil) then
-    if  Assigned(PE) then
-      begin
-      N:=PE.FirstChild;
-      While (Result=Nil) and (N<>Nil) do
-        begin
-        if (N.NodeType=ELEMENT_NODE) then
-          begin
-          Result:=LookForElement(N as TDomElement,AElement,NoPath);
-          end;
-        N:=N.NextSibling;
-        end;
-      end;
-//  Writeln('Exit TClassTreeBuilderLookForElement');
-end;
-
-Function TClassTreeBuilder.AddToClassTree(AElement : TPasElement; Var ACount : Integer) : TDomElement;
-// there are several codepaths that use uninitialized variables. (N,PE)
-// I initialized them to nil to at least make failures deterministic.
-Var
-  PC : TPasClassType;
-  PE : TDomElement;
-  M : TPasModule;
-  N : TDomNode;
-
-begin
-
-//  Writeln('Enter TClassTreeBuilder.AddToClassTree');
-  //if Assigned(AElement) then
-    //Writeln('Addtoclasstree : ',aElement.Name);
-  Result:=Nil; M:=Nil; N:=Nil;PE:=NIL;PC:=Nil;
-  If (AElement=Nil) then
-    begin
-    Result:=FTreeStart;
-    Exit;
-    end
-  else If (AElement is TPasUnresolvedTypeRef) then
-    begin
-    N:=LookForElement(FTreeStart,AElement,True);
-    If (N=Nil) then
-      PE:=FTreeStart;
-    end
-  else If (AElement is TPasClassType) then
-    begin
-    if (AElement=FParentObject) then
-      Result:=FTreeStart
-    else
-      begin
-      PC:=AElement as TPasClassType;
-      PE:=AddToClassTree(PC.AncestorType,ACount);
-      if PE=Nil then
-        PE:=FTreeStart;
-      N:=LookForElement(PE,PC,False);
-      end
-    end;
-  If (N<>Nil) then
-    begin
-    Result:=N as TDomElement
-    end
-  else if AElement.Name<>'' then
-    begin // N=NIL, PE might be nil.
-    Inc(ACount);
-    Result:=FClassTree.CreateElement(UTF8Decode(AElement.Name));
-    If Not (AElement is TPasUnresolvedTypeRef) then
-      begin
-      M:=AElement.GetModule;
-      if Assigned(M) then
-        Result['unit']:=UTF8Decode(M.Name);
-      end;
-    if PE=Nil then
-      begin
-      PE:=FTreeStart
-      end;
-    // if not assigned, probably needs to be assigned to something else.
-    if assigned(PE) then
-      PE.AppendChild(Result);
-    end;
-end;
 
 end.