paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-11 01:38:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: trunk@47915 -
This commit is contained in:
marco 2020-12-30 20:37:24 +00:00
parent 7032cba91e
commit 4353d36516
4 changed files with 129 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
utils/fpdoc/dglobals.pp
View File

@ -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.

93
utils/fpdoc/dw_chm.pp
View File

@ -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;

60
utils/fpdoc/dw_html.pp
View File

@ -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);

13
utils/fpdoc/fpdoc.pp
View File

@ -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