* commited patch(-5) by Andrey Sobol from mantis #38153 .

git-svn-id: trunk@47915 -

utils/fpdoc/dglobals.pp

@@ -23,7 +23,7 @@ unit dGlobals;
 
 interface
 
-uses Classes, DOM, PasTree, PParser, uriparser;
+uses Classes, DOM, PasTree, PParser, uriparser, SysUtils;
 
 Const
   CacheSize = 20;
@@ -343,9 +343,9 @@ type
     constructor Create;
     destructor Destroy; override;
     procedure SetPackageName(const APackageName: String);
-    // process the import objects from external .xct file
+    // The process importing of objects from external .xct file
     procedure ReadContentFile(const AFilename, ALinkPrefix: String);
-    // creation of an own .xct output file
+    // Creation of an own .xct output file
     procedure WriteContentFile(const AFilename: String);
 
     function CreateElement(AClass: TPTreeElement; const AName: String;
@@ -385,6 +385,7 @@ type
 
 
 procedure TranslateDocStrings(const Lang: String);
+function DumpExceptionCallStack(E: Exception):String;
 
 Function IsLinkNode(Node : TDomNode) : Boolean;
 Function IsExampleNode(Example : TDomNode) : Boolean;
@@ -395,7 +396,7 @@ Function IsLinkAbsolute(ALink: String): boolean;
 
 implementation
 
-uses SysUtils, Gettext, XMLRead;
+uses Gettext, XMLRead;
 
 const
   AbsoluteLinkPrefixes : array[0..2] of string = ('/', 'http://', 'ms-its:');
@@ -1133,7 +1134,7 @@ begin
             begin
             for k:=0 to ClassLikeDecl.Interfaces.count-1 do
               begin
-                write(contentfile,',',CheckImplicitLink(TPasClassType(ClassLikeDecl.Interfaces[k]).PathName));
+                write(contentfile,',',CheckImplicitLink(TPasType(ClassLikeDecl.Interfaces[k]).PathName));
                 if TPasElement(ClassLikeDecl.Interfaces[k]) is TPasAliasType then
                   begin
                     alias:= TPasAliasType(ClassLikeDecl.Interfaces[k]);
@@ -1757,6 +1758,23 @@ begin
     end;
 end;
 
+function DumpExceptionCallStack(E: Exception):String;
+var
+  I: Integer;
+  Frames: PPointer;
+begin
+  Result := 'Program exception! ' + LineEnding +
+    'Stacktrace:' + LineEnding + LineEnding;
+  if E <> nil then begin
+    Result := Result + 'Exception class: ' + E.ClassName + LineEnding +
+    'Message: ' + E.Message + LineEnding;
+  end;
+  Result := Result + BackTraceStrFunc(ExceptAddr);
+  Frames := ExceptFrames;
+  for I := 0 to ExceptFrameCount - 1 do
+    Result := Result + LineEnding + BackTraceStrFunc(Frames[I]);
+end;
+
 initialization
   LEOL:=Length(LineEnding);
 end.

utils/fpdoc/dw_chm.pp

@@ -3,7 +3,7 @@ unit dw_chm;
 interface
 
 uses Classes, DOM, DOM_HTML,
-    dGlobals, PasTree, dwriter, dw_html, ChmWriter, chmtypes;
+    dGlobals, PasTree, dwriter, dw_html, chmwriter, chmtypes, chmsitemap;
 
 type
 
@@ -34,8 +34,13 @@ type
     FOtherFiles: String;
     procedure ProcessOptions;
     function ResolveLinkIDAbs(const Name: String; Level : Integer = 0): DOMString;
-    function RetrieveOtherFiles(const DataName: String; out PathInChm: String; out FileName: String; var Stream: TStream): Boolean;
+    function RetrieveOtherFiles(const DataName: String; out PathInChm: String;
+              out FileName: String; var Stream: TStream): Boolean;
     procedure LastFileAdded(Sender: TObject);
+    function FindAlphaItem(AItems: TChmSiteMapItems; AName: String): TChmSiteMapItem;
+    function GetAlphaItem(AItems: TChmSiteMapItems; AName: String): TChmSiteMapItem;
+    procedure MultiAlphaItem(AItems: TChmSiteMapItems; AName: String;
+            APasEl: TPasElement; Prefix:String);
     procedure GenerateTOC;
     procedure GenerateIndex;
   public
@@ -50,7 +55,7 @@ type
 
 implementation
 
-uses SysUtils, HTMWrite, chmsitemap;
+uses SysUtils, HTMWrite;
 
 { TFpDocChmWriter }
 
@@ -157,7 +162,8 @@ begin
   Result := CompareText(LowerCase(Item1.Text), LowerCase(Item2.Text));
 end;
 
-function GetAlphaItem(AItems: TChmSiteMapItems; AName: String): TChmSiteMapItem;
+function TCHMHTMLWriter.FindAlphaItem(AItems: TChmSiteMapItems; AName: String
+  ): TChmSiteMapItem;
 var
   x: Integer;
 begin
@@ -167,10 +173,39 @@ begin
     if AItems.Item[x].Text = AName then
       Exit(AItems.Item[x]);
   end;
+end;
+
+function TCHMHTMLWriter.GetAlphaItem(AItems: TChmSiteMapItems; AName: String
+  ): TChmSiteMapItem;
+begin
+  Result := FindAlphaItem(AItems, AName);
+  if Result <> nil then Exit;
   Result := AItems.NewItem;
   Result.Text := AName;
 end;
-     
+
+procedure TCHMHTMLWriter.MultiAlphaItem(AItems: TChmSiteMapItems; AName: String;
+  APasEl: TPasElement; Prefix: String);
+var
+  AChmItem, AChmChld: TChmSiteMapItem;
+begin
+  AChmItem:= FindAlphaItem(AItems, AName);
+  if AChmItem = nil then
+  begin
+    // add new
+    AChmItem := AItems.NewItem;
+    AChmItem.Text :=  AName;
+    AChmItem.addLocal(FixHTMLpath(Allocator.GetFilename(APasEl, 0)));
+  end
+    else
+  begin
+    // add as child
+    AChmChld := AChmItem.Children.NewItem;
+    AChmChld.Text := Prefix + '.' + AName;
+    AChmChld.addLocal(FixHTMLpath(Allocator.GetFilename(APasEl, 0)));
+  end;
+end;
+
 procedure TCHMHTMLWriter.GenerateTOC;
 var
   TOC: TChmSiteMap;
@@ -279,20 +314,26 @@ begin
 
   fchm.AppendTOC(Stream);
   Stream.Free;
+  DoLog('Generating TOC done');
 end;
 
 type
   TClassMemberType = (cmtProcedure, cmtFunction, cmtConstructor, cmtDestructor,
-      cmtInterface, cmtProperty, cmtVariable, cmtUnknown);
+      cmtInterface, cmtProperty, cmtVariable, cmtOperator, cmtConstant, cmtUnknown);
   
 function ElementType(Element: TPasElement): TClassMemberType;
 var
   ETypeName: String;
 begin
   Result := cmtUnknown;
+  if not Assigned(Element) then Exit;
   ETypeName := Element.ElementTypeName;
-  //overloaded we don't care
-  if ETypeName[1] = 'o' then ETypeName := Copy(ETypeName, 11, Length(ETypeName));
+  if Length(ETypeName) = 0 then Exit;
+  // opearator
+  if ETypeName[2] = 'p' then Exit(cmtOperator);
+  if ETypeName[3] = 'n' then Exit(cmtConstant);
+  // overloaded we don't care
+  if ETypeName[1] = 'o' then ETypeName := Copy(ETypeName, 12, Length(ETypeName));
   
   if ETypeName[1] = 'f' then Exit(cmtFunction);
   if ETypeName[1] = 'c' then Exit(cmtConstructor);
@@ -301,7 +342,8 @@ begin
   // the p's
   if ETypeName[4] = 'c' then Exit(cmtProcedure);
   if ETypeName[4] = 'p' then Exit(cmtProperty);
-  
+  // Unknown
+  // WriteLn(' Warning El name: '+ Element.Name+' path: '+Element.PathName+' TypeName: '+Element.ElementTypeName);
 end;
 
 procedure TCHMHTMLWriter.GenerateIndex;
@@ -315,7 +357,7 @@ var
   ParentElement: TPasElement;
   MemberItem: TChmSiteMapItem;
   Stream: TMemoryStream;
-  RedirectUrl,Urls: String;
+  RedirectUrl,Urls,SName: String;
 
 begin
   DoLog('Generating Index...');
@@ -356,7 +398,7 @@ begin
 
           if(trim(RedirectUrl)<>'') and (RedirectUrl<>urls) then
             begin
-              writeln('Hint: Index Resolved:',urls,' to ',RedirectUrl);
+              //writeln('Hint: Index Resolved:',urls,' to ',RedirectUrl);
               urls:=RedirectUrl;
             end;
 
@@ -369,6 +411,8 @@ begin
             cmtProperty    : TmpItem.Text := TmpElement.Name + ' property';
             cmtVariable    : TmpItem.Text := TmpElement.Name + ' variable';
             cmtInterface   : TmpItem.Text := TmpElement.Name + ' interface';
+            cmtOperator    : TmpItem.Text := TmpElement.Name + ' operator';
+            cmtConstant    : TmpItem.Text := TmpElement.Name + ' const';
             cmtUnknown     : TmpItem.Text := TmpElement.Name;
           end;
           TmpItem.addLocal(Urls);
@@ -389,18 +433,24 @@ begin
       // routines
       for j := 0 to AModule.InterfaceSection.Functions.Count-1 do
       begin
-        ParentElement := TPasProcedureType(AModule.InterfaceSection.Functions[j]);
-        TmpItem := Index.Items.NewItem;
-        TmpItem.Text := ParentElement.Name + ' ' + ParentElement.ElementTypeName;
-        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
+        // routine name
+        ParentElement := TPasElement(AModule.InterfaceSection.Functions[j]);
+        case ElementType(ParentElement) of
+          cmtProcedure   : SName:= ' procedure';
+          cmtFunction    : SName:= ' function';
+          cmtOperator    : SName:= ' operator';
+          //cmtConstant    : SName:= ' const';
+          else             SName:= ' unknown'
+        end;
+        SName:= ParentElement.Name + ' ' + SName;
+        MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name);
       end;
       // consts
       for j := 0 to AModule.InterfaceSection.Consts.Count-1 do
       begin
         ParentElement := TPasElement(AModule.InterfaceSection.Consts[j]);
-        TmpItem := Index.Items.NewItem;
-        TmpItem.Text := ParentElement.Name;
-        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
+        SName:= ParentElement.Name + ' const';
+        MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name);
       end;
       // types
       for j := 0 to AModule.InterfaceSection.Types.Count-1 do
@@ -431,9 +481,8 @@ begin
       for j := 0 to AModule.InterfaceSection.Variables.Count-1 do
       begin
         ParentElement := TPasElement(AModule.InterfaceSection.Variables[j]);
-        TmpItem := Index.Items.NewItem;
-        TmpItem.Text := ParentElement.Name + ' var';
-        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
+        SName:= ParentElement.Name + ' variable';
+        MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name);
       end;
       // declarations
       {
@@ -471,6 +520,7 @@ begin
     FChm.AppendIndex(Stream);
     Stream.Free;
   end;
+  DoLog('Generating Index Done');
 end;
 
 procedure TCHMHTMLWriter.WriteHTMLPages;
@@ -548,6 +598,7 @@ begin
 
   FChm.Execute;
   FChm.Free;
+  DoLog('Collecting done');
   // we don't need to free FTempUncompressed
   // FTempUncompressed.Free;
   FOutChm.Free;

utils/fpdoc/dw_html.pp

@@ -53,6 +53,8 @@ type
     function GetCSSFilename(ARelativeTo: TPasElement): DOMString; virtual;
   end;
 
+  { TLongNameFileAllocator }
+
   TLongNameFileAllocator = class(TFileAllocator)
   private
     FExtension: String;
@@ -255,7 +257,6 @@ type
     // Start producing html complete package documentation
     procedure WriteHTMLPages; virtual;
     procedure WriteXHTMLPages;
-    function  ModuleForElement(AnElement:TPasElement):TPasModule;
 
     Function InterPretOption(Const Cmd,Arg : String) : boolean; override;
     Procedure WriteDoc; override;
@@ -276,7 +277,6 @@ type
     Property ImageFileList : TStrings Read FImageFileList;
   end;
 
-
 Function FixHTMLpath(S : String) : STring;
 
 implementation
@@ -310,7 +310,6 @@ begin
 end;
 
 
-
 constructor TLongNameFileAllocator.Create(const AExtension: String);
 begin
   inherited Create;
@@ -331,12 +330,12 @@ begin
     Result := 'index';
     excl := True;
   end
-  else if AElement.ClassType = TPasModule then
+    else if AElement.ClassType = TPasModule then
   begin
     Result := LowerCase(AElement.Name) + PathDelim + 'index';
     excl := True;
   end
-  else
+    else
   begin
     if AElement is TPasOperator then
     begin
@@ -371,9 +370,11 @@ begin
       excl := (ASubindex > 0);
     end;
     // searching for TPasModule - it is on the 2nd level
-    if Assigned(AElement.Parent) then
-      while Assigned(AElement.Parent.Parent) do
-        AElement := AElement.Parent;
+    if AElement.GetModule <> nil then
+      AElement := AElement.GetModule 
+    else
+      Raise EFPDocWriterError.Create(
+      'TLongNameFileAllocator error: Unresolved module name for element: ' +AElement.PathName);
     // cut off Package Name
     Result := Copy(Result, Length(AElement.Parent.Name) + 2, MaxInt);
     // to skip dots in unit name
@@ -834,15 +835,6 @@ begin
   end;
 end;
 
-function  THTMLWriter.ModuleForElement(AnElement:TPasElement):TPasModule;
-
-begin
-  result:=TPasModule(AnElement);
-  while assigned(result) and not (result is TPasModule) do 
-        result:=TPasModule(result.parent);
-  if not (result is TPasModule) then
-   result:=nil;
-end;
 
 procedure THTMLWriter.CreateCSSFile;
 
@@ -1691,7 +1683,7 @@ begin
     end else
     begin
       Result := nil;
-      AppendText(Parent, Element.Name);
+      AppendText(Parent, Element.Name); // unresolved items
     end;
   end else
   begin
@@ -2294,7 +2286,7 @@ begin
         else
           AppendText(NewEl,El['id']);
        l:=El['id'];
-       DescrEl := Engine.FindShortDescr(ModuleForElement(AElement),UTF8Encode(L));
+       DescrEl := Engine.FindShortDescr(AElement.GetModule,UTF8Encode(L));
        if Assigned(DescrEl) then
          begin
          AppendNbSp(CreatePara(CreateTD(TREl)), 2);
@@ -2494,7 +2486,7 @@ type
       if (PE<>Nil) then
         begin
         AppendHyperLink(CurOutputNode,PE);
-        PM:=ModuleForElement(PE);
+        PM:=PE.GetModule();
         if (PM<>Nil) then
           begin
           AppendText(CurOutputNode,' (');
@@ -3157,7 +3149,7 @@ var
   i: Integer;
   s: String;
   t : TPasType;
-  ah,ol,wt,ct,wc,cc  : boolean;
+  ah,ol,wt,ct,wc,cc : boolean;
   isRecord : Boolean;
 
 begin
@@ -3172,30 +3164,24 @@ begin
       begin
       Member := TPasElement(Members[i]);
       MVisibility:=Member.Visibility;
+      cc:=(Member is TPasConst);
+      ct:=(Member is TPasType);
       ol:=(Member is TPasOverloadedProc);
       ah:=ol or ((Member is TPasProcedure) and (TPasProcedure(Member).ProcType.Args.Count > 0));
       if ol then
         Member:=TPasElement((Member as TPasOverloadedProc).Overloads[0]);
       if Not Engine.ShowElement(Member) then
         continue;
-      if (CurVisibility <> MVisibility) then
+      if (CurVisibility <> MVisibility) or (cc <> wc) or (ct <> wt) then
         begin
         CurVisibility := MVisibility;
+        wc:=cc;
+        wt:=ct;
         s:=VisibilityNames[MVisibility];
         AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), UTF8Decode(s));
+        if (ct) then AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'type');
+        if (cc) then AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'const');
         end;
-      ct:=(Member is TPasType);
-      if ct and (not wt) then
-        begin
-        AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'Type');
-        end;
-      wt:=ct;
-      cc:=(Member is TPasConst);
-      if cc and (not wc) then
-        begin
-        AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'Const');
-        end;
-      wc:=cc;
       TREl := CreateTR(TableEl);
       CodeEl := CreateCode(CreatePara(CreateTD_vtop(TREl)));
       AppendNbSp(CodeEl, 2);
@@ -3218,7 +3204,7 @@ begin
         If Assigned(TPasConst(Member).VarType) then
           begin
           AppendSym(CodeEl, ' = ');
-          AppendTypeDecl(TPasType(Member),TableEl,CodeEl);
+          AppendTypeDecl(TPasType(TPasConst(Member).VarType),TableEl,CodeEl);
           end;
         AppendSym(CodeEl, ' = ');
         AppendText(CodeEl,UTF8Decode(TPasConst(Member).Expr.GetDeclaration(True)));
@@ -3270,7 +3256,7 @@ begin
         else
           AppendText(CodeEl, UTF8Decode(Member.Name));
         AppendSym(CodeEl, ': ');
-        AppendHyperlink(CodeEl, TPasVariable(Member).VarType);
+        AppendType(CodeEl, TableEl, TPasVariable(Member).VarType,False);
         AppendSym(CodeEl, ';');
         end
       else
@@ -3490,6 +3476,7 @@ var
             AppendText(ParaEl, 'pt');
           visPublished:
             AppendText(ParaEl, 'pl');
+          else
         end;
         AppendNbSp(ParaEl, 1);
 
@@ -3558,6 +3545,7 @@ var
             AppendText(ParaEl, 'pt');
           visPublished:
             AppendText(ParaEl, 'pl');
+          else
         end;
         AppendNbSp(ParaEl, 1);
 

utils/fpdoc/fpdoc.pp

@@ -55,8 +55,9 @@ Type
     procedure OutputLog(Sender: TObject; const Msg: String);
     procedure ParseCommandLine;
     procedure ParseOption(const S: String);
-    Procedure Usage(AnExitCode : Byte);
-    Procedure DoRun; override;
+    procedure Usage(AnExitCode : Byte);
+    procedure ExceptProc(Sender: TObject; E: Exception);
+    procedure DoRun; override;
   Public
     Constructor Create(AOwner : TComponent); override;
     Destructor Destroy; override;
@@ -64,7 +65,7 @@ Type
   end;
 
 
-Procedure TFPDocApplication.Usage(AnExitCode : Byte);
+procedure TFPDocApplication.Usage(AnExitCode: Byte);
 
 Var
   I,P : Integer;
@@ -148,6 +149,11 @@ begin
   Halt(AnExitCode);
 end;
 
+procedure TFPDocApplication.ExceptProc(Sender: TObject; E: Exception);
+begin
+  OutputLog(Sender, DumpExceptionCallStack(E));
+end;
+
 destructor TFPDocApplication.Destroy;
 
 begin
@@ -427,6 +433,7 @@ begin
   StopOnException:=true;
   FCreator:=TFPDocCreator.Create(Self);
   FCreator.OnLog:=@OutputLog;
+  OnException:= @ExceptProc;
 end;
 
 begin