123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728 |
- {
- FPDoc - Free Pascal Documentation Tool
- Copyright (C) 2000 - 2002 by
- Areca Systems GmbH / Sebastian Guenther, [email protected]
- * Global declarations
- * Link list management
- * Document node tree
- * Main engine
- See the file COPYING, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- }
- {$MODE objfpc}
- {$H+}
- unit dGlobals;
- interface
- uses Classes, DOM, PasTree, PParser, StrUtils,uriparser;
- Const
- CacheSize = 20;
- ContentBufSize = 4096 * 8;
- Var
- LEOL : Integer;
- modir : string;
- resourcestring
- // Output strings
- SDocPackageTitle = 'Reference for package ''%s''';
- SDocPrograms = 'Programs';
- SDocUnits = 'Units';
- SDocUnitTitle = 'Reference for unit ''%s''';
- SDocInheritanceHierarchy = 'Inheritance Hierarchy';
- SDocInterfaceSection = 'Interface section';
- SDocImplementationSection = 'Implementation section';
- SDocUsedUnits = 'Used units';
- SDocUsedUnitsByUnitXY = 'Used units by unit ''%s''';
- SDocConstsTypesVars = 'Constants, types and variables';
- SDocResStrings = 'Resource strings';
- SDocTypes = 'Types';
- SDocConstants = 'Constants';
- SDocClasses = 'Classes';
- SDocProceduresAndFunctions = 'Procedures and functions';
- SDocVariables = 'Variables';
- SDocIdentifierIndex = 'Index';
- SDocPackageClassHierarchy = 'Class hierarchy';
- SDocModuleIndex = 'Index of all identifiers in unit ''%s''';
- SDocPackageIndex = 'Index of all identifiers in package ''%s''';
- SDocUnitOverview = 'Overview of unit ''%s''';
- SDocOverview = 'Overview';
- SDocSearch = 'Search';
- SDocDeclaration = 'Declaration';
- SDocDescription = 'Description';
- SDocErrors = 'Errors';
- SDocVersion = 'Version info';
- SDocSeeAlso = 'See also';
- SDocExample = 'Example';
- SDocArguments = 'Arguments';
- SDocFunctionResult = 'Function result';
- SDocRemark = 'Remark: ';
- SDocMethodOverview = 'Method overview';
- SDocPropertyOverview = 'Property overview';
- SDocInterfacesOverview = 'Interfaces overview';
- SDocPage = 'Page';
- SDocMethod = 'Method';
- SDocProperty = 'Property';
- SDocAccess = 'Access';
- SDocInheritance = 'Inheritance';
- SDocProperties = 'Properties';
- SDocMethods = 'Methods';
- SDocEvents = 'Events';
- SDocByName = 'by Name';
- SDocValue = 'Value';
- SDocExplanation = 'Explanation';
- SDocProcedure = 'Procedure';
- SDocValuesForEnum = 'Enumeration values for type %s';
- SDocSourcePosition = 'Source position: %s line %d';
- SDocSynopsis = 'Synopsis';
- SDocVisibility = 'Visibility';
- SDocOpaque = 'Opaque type';
- SDocDateGenerated = 'Documentation generated on: %s';
- // The next line requires leading/trailing space due to XML comment layout:
- SDocGeneratedByComment = ' Generated using FPDoc - (c) 2000-2012 FPC contributors and Sebastian Guenther, [email protected] ';
- SDocNotes = 'Notes';
-
- // Topics
- SDocRelatedTopics = 'Related topics';
- SDocUp = 'Up';
- SDocNext = 'Next';
- SDocPrevious = 'Previous';
- // Various backend constants
- SDocChapter = 'Chapter';
- SDocSection = 'Section';
- SDocSubSection = 'Subsection';
- SDocTable = 'Table';
- SDocListing = 'Listing';
- // Man page usage
- SManUsageManSection = 'Use ASection as the man page section';
- SManUsageNoUnitPrefix = 'Do not prefix man pages with unit name.';
- SManUsageWriterDescr = 'UNIX man page output.';
- SManUsagePackageDescription = 'Use descr as the description of man pages';
-
- // HTML usage
- SHTMLUsageFooter = 'Append xhtml from file as footer to html page';
- SHTMLUsageFooterDate = 'Append footer with date. fmt is Optional format for FormatDateTime';
- SHTMLUsageCharset = 'Set the HTML character set';
- SHTMLHtmlSearch = 'Add search page with given name to the menu bar';
- SHTMLIndexColcount = 'Use N columns in the identifier index pages';
- SHTMLImageUrl = 'Prefix image URLs with url';
- SHTMLDisableMenuBrackets = 'Disable ''['' and '']'' characters around menu items at the top of the page. Useful for custom css';
-
- // CHM usage
- SCHMUsageTOC = 'Use [File] as the table of contents. Usually a .hhc file.';
- SCHMUsageIndex = 'Use [File] as the index. Usually a .hhk file.';
- SCHMUsageDefPage = 'Set the "Home" page relative to where it lives in the chm. i.e. "/index.html"';
- SCHMUsageOtrFiles= 'A txt file containing a list of files to be added relative to the working directory.';
- SCHMUsageCSSFile = 'Filename of a .css file to be included in the chm.';
- SCHMUsageAutoTOC = 'Automatically generate a Table of Contents. Ignores --toc-file';
- SCHMUsageAutoIDX = 'Automatically generate an Index. Ignores --index-file';
- SCHMUsageMakeSearch = 'Automatically generate a Search Index from filenames that match *.htm*';
- SCHMUsageChmTitle= 'Title of the chm. Defaults to the value from --package';
- // Linear usage
- SLinearUsageDupLinkedDocsP1 = 'Duplicate linked element documentation in';
- SLinearUsageDupLinkedDocsP2 = 'descendant classes.';
- STitle = 'FPDoc - Free Pascal Documentation Tool';
- SVersion = 'Version %s [%s]';
- SCopyright1 = '(c) 2000 - 2003 Areca Systems GmbH / Sebastian Guenther, [email protected]';
- SCopyright2 = '(c) 2005 - 2012 various FPC contributors';
- SCmdLineHelp = 'Usage: %s [options]';
- SUsageOption010 = '--content Create content file for package cross-references';
- SUsageOption020 = '--cputarget=value Set the target CPU for the scanner.';
- SUsageOption030 = '--descr=file use file as description file, e.g.: ';
- SUsageOption035 = ' --descr=c:\WIP\myzipperdoc.xml';
- SUsageOption040 = ' This option is allowed more than once';
- SUsageOption050 = '--descr-dir=Dir Add All XML files in Dir to list of description files';
- SUsageOption060 = '--format=fmt Select output format.';
- SUsageOption070 = '--help Show this help.';
- SUsageOption080 = '--hide-protected Do not show protected methods in overview';
- SUsageOption090 = '--import=file Import content file for package cross-references';
- SUsageOption100 = '--input=cmd use cmd as input for the parser, e.g.:';
- SUsageOption110 = ' --input=C:\fpc\packages\paszlib\src\zipper.pp';
- SUsageOption120 = ' At least one input option is required.';
- SUsageOption130 = '--input-dir=Dir Add All *.pp and *.pas files in Dir to list of input files';
- SUsageOption140 = '--lang=lng Select output language.';
- SUsageOption150 = '--ostarget=value Set the target OS for the scanner.';
- SUsageOption160 = '--output=name use name as the output name.';
- SUsageOption170 = ' Each backend interpretes this as needed.';
- SUsageOption180 = '--package=name Set the package name for which to create output,';
- SUsageOption190 = ' e.g. --package=fcl';
- SUsageOption200 = '--project=file Use file as project file';
- SUsageOption210 = '--show-private Show private methods.';
- SUsageOption220 = '--warn-no-node Warn if no documentation node was found.';
- SUsageOption230 = '--mo-dir=dir Set directory where language files reside to dir';
- SUsageOption240 = '--parse-impl (Experimental) try to parse implementation too';
- SUsageOption250 = '--dont-trim Do not trim XML contents. Useful for preserving';
- SUsageOption260 = ' formatting inside e.g <pre> tags';
- SUsageOption270 = '--write-project=file';
- SUsageOption280 = ' Do not write documentation, create project file instead';
- SUsageOption290 = '--verbose Write more information on the screen';
- SUsageOption300 = '--dry-run Only parse sources and XML, do not create output';
- SUsageOption310 = '--write-project=file';
- SUsageOption320 = ' Write all command-line options to a project file';
- SUsageFormats = 'The following output formats are supported by this fpdoc:';
- SUsageBackendHelp = 'Specify an output format, combined with --help to get more help for this backend.';
- SUsageFormatSpecific = 'Output format "%s" supports the following options:';
- SCmdLineInvalidOption = 'Ignoring unknown option "%s"';
- SCmdLineInvalidFormat = 'Invalid format "%s" specified';
- SCmdLineOutputOptionMissing = 'Need an output filename, please specify one with --output=<filename>';
- SWritingPages = 'Writing %d pages...';
- SNeedPackageName = 'No package name specified. Please specify one using the --package option.';
- SAvailablePackages = 'Available packages: ';
- SDone = 'Done.';
- SErrCouldNotCreateOutputDir = 'Could not create output directory "%s"';
- SErrCouldNotCreateFile = 'Could not create file "%s": %s';
- SSeeURL = '(See %s)'; // For linear text writers.
- SParsingUsedUnit = 'Parsing used unit "%s" with commandLine "%s"';
- Const
- SVisibility: array[TPasMemberVisibility] of string =
- ('Default', 'Private', 'Protected', 'Public',
- 'Published', 'Automated','Strict Private','Strict Protected');
- type
- // Assumes a list of TObject instances and frees them on destruction
- TObjectList = class(TFPList)
- public
- destructor Destroy; override;
- end;
- TPasExternalClassType = Class(TPasClassType);
- TPasExternalModule = Class(TPasModule);
- { Link entry tree
- TFPDocEngine stores the root of the entry tree in its property
- "RootLinkNode". The root has one child node for each package, for which
- documentation links are available. The children of a package node
- are module nodes; and the children of a module node are the top-level
- declarations of this module; the next level in the tree stores e.g. record
- members, and so on...
- }
- TLinkNode = class
- private
- FFirstChild, FNextSibling: TLinkNode;
- FName: String;
- FLink: String;
- public
- constructor Create(const AName, ALink: String);
- destructor Destroy; override;
- function FindChild(const APathName: String): TLinkNode;
- function CreateChildren(const APathName, ALinkTo: String): TLinkNode;
- // Properties for tree structure
- property FirstChild: TLinkNode read FFirstChild;
- property NextSibling: TLinkNode read FNextSibling;
- // Link properties
- property Name: String read FName;
- property Link: String read FLink;
- end;
- { Documentation entry tree
- TFPDocEngine stores the root of the entry tree in its property
- "RootDocNode". The root has one child node for each package, for which
- documentation is being provided by the user. The children of a package node
- are module nodes; and the children of a module node are the top-level
- declarations of this module; the next level in the tree stores e.g. record
- members, and so on...
- }
- { TDocNode }
- TDocNode = class
- private
- FFirstChild, FNextSibling: TDocNode;
- FName: String;
- FNode: TDOMElement;
- FIsSkipped: Boolean;
- FShortDescr: TDOMElement;
- FDescr: TDOMElement;
- FErrorsDoc: TDOMElement;
- FSeeAlso: TDOMElement;
- FFirstExample: TDOMElement;
- FNotes : TDomElement;
- FLink: String;
- FTopicNode : Boolean;
- FRefCount : Integer;
- FVersion: TDomElement;
- public
- constructor Create(const AName: String; ANode: TDOMElement);
- destructor Destroy; override;
- Function IncRefcount : Integer;
- function FindChild(const APathName: String): TDocNode;
- function CreateChildren(const APathName: String): TDocNode;
- // Properties for tree structure
- property FirstChild: TDocNode read FFirstChild;
- property NextSibling: TDocNode read FNextSibling;
- // Basic properties
- property Name: String read FName;
- property Node: TDOMElement read FNode;
- // Data fetched from the XML document
- property IsSkipped: Boolean read FIsSkipped;
- property ShortDescr: TDOMElement read FShortDescr;
- property Descr: TDOMElement read FDescr;
- property ErrorsDoc: TDOMElement read FErrorsDoc;
- Property Version : TDomElement Read FVersion;
- property SeeAlso: TDOMElement read FSeeAlso;
- property FirstExample: TDOMElement read FFirstExample;
- property Notes : TDOMElement read FNotes;
- property Link: String read FLink;
- Property TopicNode : Boolean Read FTopicNode;
- Property RefCount : Integer Read FRefCount;
- end;
-
- // The main FPDoc engine
- TFPDocLogLevel = (dleWarnNoNode);
- TFPDocLogLevels = set of TFPDocLogLevel;
- TOnParseUnitEvent = Procedure (Sender : TObject; Const AUnitName : String; Out AInputFile,OSTarget,CPUTarget : String) of Object;
- { TFPDocEngine }
- TFPDocEngine = class(TPasTreeContainer)
- private
- FDocLogLevels: TFPDocLogLevels;
- FOnParseUnit: TOnParseUnitEvent;
- function ResolveLinkInPackages(AModule: TPasModule; const ALinkDest: String; Strict: Boolean=False): String;
- function ResolveLinkInUsedUnits(AModule: TPasModule; const ALinkDest: String; Strict: Boolean=False): String;
- protected
- FAlwaysVisible : TStringList;
- DescrDocs: TObjectList; // List of XML documents
- DescrDocNames: TStringList; // Names of the XML documents
- FRootLinkNode: TLinkNode;
- FRootDocNode: TDocNode;
- FPackages: TFPList; // List of TFPPackage objects
- CurModule: TPasModule;
- CurPackageDocNode: TDocNode;
- function ParseUsedUnit(AName, AInputLine,AOSTarget,ACPUTarget: String): TPasModule; virtual;
- Function LogEvent(E : TFPDocLogLevel) : Boolean;
- Procedure DoLog(Const Msg : String);overload;
- Procedure DoLog(Const Fmt : String; Args : Array of const);overload;
- public
- Output: String;
- HasContentFile: Boolean;
- HidePrivate: Boolean; // Hide private class members in output?
- HideProtected: Boolean; // Hide protected class members in output?
- WarnNoNode : Boolean; // Warn if no description node found for element.
- constructor Create;
- destructor Destroy; override;
- procedure SetPackageName(const APackageName: String);
- procedure ReadContentFile(const AFilename, ALinkPrefix: String);
- procedure WriteContentFile(const AFilename: String);
- function CreateElement(AClass: TPTreeElement; const AName: String;
- AParent: TPasElement; AVisibility: TPasMemberVisibility;
- const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
- override;
- function FindElement(const AName: String): TPasElement; override;
- function FindModule(const AName: String): TPasModule; override;
- Function HintsToStr(Hints : TPasMemberHints) : String;
- // Link tree support
- procedure AddLink(const APathName, ALinkTo: String);
- function FindAbsoluteLink(const AName: String): String;
- function ResolveLink(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
- function FindLinkedNode(ANode: TDocNode): TDocNode;
- Function ShowElement(El : TPasElement) : Boolean; inline;
- // Call this before documenting.
- Procedure StartDocumenting; virtual;
- // Documentation file support
- procedure AddDocFile(const AFilename: String;DontTrim:boolean=false);
- // Documentation retrieval
- function FindDocNode(AElement: TPasElement): TDocNode;
- function FindDocNode(ARefModule: TPasModule; const AName: String): TDocNode;
- function FindShortDescr(AElement: TPasElement): TDOMElement;
- function FindShortDescr(ARefModule: TPasModule; const AName: String): TDOMElement;
- function GetExampleFilename(const ExElement: TDOMElement): String;
- property RootLinkNode: TLinkNode read FRootLinkNode;
- property RootDocNode: TDocNode read FRootDocNode;
- Property DocLogLevels : TFPDocLogLevels Read FDocLogLevels Write FDocLogLevels;
- Property OnParseUnit : TOnParseUnitEvent Read FOnParseUnit Write FOnParseUnit;
- end;
- procedure TranslateDocStrings(const Lang: String);
- Function IsLinkNode(Node : TDomNode) : Boolean;
- Function IsExampleNode(Example : TDomNode) : Boolean;
- // returns true is link is an absolute URI
- Function IsLinkAbsolute(ALink: String): boolean;
- implementation
- uses SysUtils, Gettext, XMLRead;
- const
- AbsoluteLinkPrefixes : array[0..2] of string = ('/', 'http://', 'ms-its:');
- { TObjectList }
- destructor TObjectList.Destroy;
- var
- i: Integer;
- begin
- for i := 0 to Count - 1 do
- TObject(Items[i]).Free;
- inherited Destroy;
- end;
- { TLinkNode }
- constructor TLinkNode.Create(const AName, ALink: String);
- begin
- inherited Create;
- FName := AName;
- FLink := ALink;
- end;
- destructor TLinkNode.Destroy;
- begin
- if Assigned(FirstChild) then
- FirstChild.Free;
- if Assigned(NextSibling) then
- NextSibling.Free;
- inherited Destroy;
- end;
- function TLinkNode.FindChild(const APathName: String): TLinkNode;
- var
- DotPos: Integer;
- ChildName: String;
- Child: TLinkNode;
- begin
- if Length(APathName) = 0 then
- Result := Self
- else
- begin
- DotPos := Pos('.', APathName);
- if DotPos = 0 then
- ChildName := APathName
- else
- ChildName := Copy(APathName, 1, DotPos - 1);
- Child := FirstChild;
- while Assigned(Child) do
- begin
- if CompareText(Child.Name, ChildName) = 0 then
- begin
- if DotPos = 0 then
- Result := Child
- else
- Result := Child.FindChild(
- Copy(APathName, DotPos + 1, Length(APathName)));
- exit;
- end;
- Child := Child.NextSibling;
- end;
- Result := nil;
- end;
- end;
- function TLinkNode.CreateChildren(const APathName, ALinkTo: String): TLinkNode;
- var
- DotPos: Integer;
- ChildName: String;
- Child, LastChild: TLinkNode;
- begin
- if Length(APathName) = 0 then
- Result := Self
- else
- begin
- DotPos := Pos('.', APathName);
- if DotPos = 0 then
- ChildName := APathName
- else
- ChildName := Copy(APathName, 1, DotPos - 1);
- Child := FirstChild;
- LastChild := nil;
- while Assigned(Child) do
- begin
- if CompareText(Child.Name, ChildName) = 0 then
- begin
- if DotPos = 0 then
- Result := Child
- else
- Result := Child.CreateChildren(
- Copy(APathName, DotPos + 1, Length(APathName)), ALinkTo);
- exit;
- end;
- LastChild := Child;
- Child := Child.NextSibling;
- end;
- { No child found, let's create one if we are at the end of the path }
- if DotPos > 0 then
- Raise Exception.CreateFmt('Link path does not exist: %s',[APathName]);
- Result := TLinkNode.Create(ChildName, ALinkTo);
- if Assigned(LastChild) then
- LastChild.FNextSibling := Result
- else
- FFirstChild := Result;
- end;
- end;
- { TDocNode }
- constructor TDocNode.Create(const AName: String; ANode: TDOMElement);
- begin
- inherited Create;
- FName := AName;
- FNode := ANode;
- end;
- destructor TDocNode.Destroy;
- begin
- if Assigned(FirstChild) then
- FirstChild.Free;
- if Assigned(NextSibling) then
- NextSibling.Free;
- inherited Destroy;
- end;
- Function TDocNode.IncRefcount : Integer;
- begin
- Inc(FRefCount);
- Result:=FRefCount;
- end;
- function TDocNode.FindChild(const APathName: String): TDocNode;
- var
- DotPos: Integer;
- ChildName: String;
- Child: TDocNode;
- begin
- if Length(APathName) = 0 then
- Result := Self
- else
- begin
- DotPos := Pos('.', APathName);
- if DotPos = 0 then
- ChildName := APathName
- else
- ChildName := Copy(APathName, 1, DotPos - 1);
- Child := FirstChild;
- while Assigned(Child) do
- begin
- if CompareText(Child.Name, ChildName) = 0 then
- begin
- if DotPos = 0 then
- Result := Child
- else
- Result := Child.FindChild(
- Copy(APathName, DotPos + 1, Length(APathName)));
- exit;
- end;
- Child := Child.NextSibling;
- end;
- Result := nil;
- end;
- end;
- function TDocNode.CreateChildren(const APathName: String): TDocNode;
- var
- DotPos: Integer;
- ChildName: String;
- Child: TDocNode;
- begin
- if Length(APathName) = 0 then
- Result := Self
- else
- begin
- DotPos := Pos('.', APathName);
- if DotPos = 0 then
- ChildName := APathName
- else
- ChildName := Copy(APathName, 1, DotPos - 1);
- Child := FirstChild;
- while Assigned(Child) do
- begin
- if CompareText(Child.Name, ChildName) = 0 then
- begin
- if DotPos = 0 then
- Result := Child
- else
- Result := Child.CreateChildren(
- Copy(APathName, DotPos + 1, Length(APathName)));
- exit;
- end;
- Child := Child.NextSibling;
- end;
- // No child found, let's create one
- Result := TDocNode.Create(ChildName, nil);
- if Assigned(FirstChild) then
- begin
- Result.FNextSibling := FirstChild;
- FFirstChild := Result;
- end else
- FFirstChild := Result;
- if DotPos > 0 then
- Result := Result.CreateChildren(
- Copy(APathName, DotPos + 1, Length(APathName)));
- end;
- end;
- { TFPDocEngine }
- function TFPDocEngine.LogEvent(E: TFPDocLogLevel): Boolean;
- begin
- Result:=E in FDocLogLevels;
- end;
- procedure TFPDocEngine.DoLog(const Msg: String);
- begin
- If Assigned(OnLog) then
- OnLog(Self,Msg);
- end;
- procedure TFPDocEngine.DoLog(const Fmt: String; Args: array of const);
- begin
- DoLog(Format(Fmt,Args));
- end;
- constructor TFPDocEngine.Create;
- begin
- inherited Create;
- DescrDocs := TObjectList.Create;
- FAlwaysVisible := TStringList.Create;
- FAlwaysVisible.CaseSensitive:=True;
- DescrDocNames := TStringList.Create;
- FRootLinkNode := TLinkNode.Create('', '');
- FRootDocNode := TDocNode.Create('', nil);
- HidePrivate := True;
- InterfaceOnly:=True;
- FPackages := TFPList.Create;
- end;
- destructor TFPDocEngine.Destroy;
- var
- i: Integer;
- begin
- for i := 0 to FPackages.Count - 1 do
- TPasPackage(FPackages[i]).Release;
- FreeAndNil(FRootDocNode);
- FreeAndNil(FRootLinkNode);
- FreeAndNil(DescrDocNames);
- FreeAndNil(DescrDocs);
- FreeAndNil(FAlwaysVisible);
- inherited Destroy;
- end;
- procedure TFPDocEngine.SetPackageName(const APackageName: String);
- begin
- ASSERT(not Assigned(Package));
- FPackage := TPasPackage(inherited CreateElement(TPasPackage,
- '#' + APackageName, nil, '', 0));
- FPackages.Add(FPackage);
- CurPackageDocNode := RootDocNode.FindChild('#' + APackageName);
- If Assigned(CurPackageDocNode) then
- CurPackageDocNode.IncRefCount;
- end;
- procedure TFPDocEngine.ReadContentFile(const AFilename, ALinkPrefix: String);
- var
- f: Text;
- inheritanceinfo : TStringlist;
- procedure ReadLinkTree;
- var
- s: String;
- PrevSpaces, ThisSpaces, i, StackIndex: Integer;
- CurParent, PrevSibling, NewNode: TLinkNode;
- ParentStack, SiblingStack: array[0..7] of TLinkNode;
- begin
- PrevSpaces := 0;
- CurParent := RootLinkNode;
- PrevSibling := CurParent.FirstChild;
- if assigned(PrevSibling) then
- while assigned(PrevSibling.NextSibling) do
- PrevSibling := PrevSibling.NextSibling;
- StackIndex := 0;
- while True do
- begin
- ReadLn(f, s);
- if Length(s) = 0 then
- break;
- ThisSpaces := 0;
- while s[ThisSpaces + 1] = ' ' do
- Inc(ThisSpaces);
- if ThisSpaces <> PrevSpaces then
- begin
- if ThisSpaces > PrevSpaces then
- begin
- { Dive down one level }
- ParentStack[StackIndex] := CurParent;
- SiblingStack[StackIndex] := PrevSibling;
- Inc(StackIndex);
- CurParent := PrevSibling;
- PrevSibling := nil;
- end else
- while PrevSpaces > ThisSpaces do
- begin
- Dec(StackIndex);
- CurParent := ParentStack[StackIndex];
- PrevSibling := SiblingStack[StackIndex];
- Dec(PrevSpaces);
- end;
- PrevSpaces := ThisSpaces;
- end;
- i := ThisSpaces + 1;
- while s[i] <> ' ' do
- Inc(i);
- NewNode := TLinkNode.Create(Copy(s, ThisSpaces + 1, i - ThisSpaces - 1),
- ALinkPrefix + Copy(s, i + 1, Length(s)));
- if pos(' ',newnode.link)>0 then
- writeln(stderr,'Bad format imported node: name="',newnode.name,'" link="',newnode.link,'"');
- if Assigned(PrevSibling) then
- PrevSibling.FNextSibling := NewNode
- else
- CurParent.FFirstChild := NewNode;
- PrevSibling := NewNode;
- end;
- end;
- function ResolvePackageModule(AName:String;var pkg:TPasPackage;var module:TPasModule;createnew:boolean):String;
- var
- DotPos, DotPos2, i,j: Integer;
- s: String;
- HPackage: TPasPackage;
- begin
- pkg:=nil; module:=nil; result:='';
- // Find or create package
- DotPos := Pos('.', AName);
- s := Copy(AName, 1, DotPos - 1);
- HPackage := nil;
- for i := 0 to FPackages.Count - 1 do
- if CompareText(TPasPackage(FPackages[i]).Name, s) = 0 then
- begin
- HPackage := TPasPackage(FPackages[i]);
- break;
- end;
- if not Assigned(HPackage) then
- begin
- if not CreateNew then
- exit;
- HPackage := TPasPackage(inherited CreateElement(TPasPackage, s, nil,
- '', 0));
- FPackages.Add(HPackage);
- end;
- // Find or create module
- DotPos2 := DotPos;
- repeat
- Inc(DotPos2);
- until AName[DotPos2] = '.';
- s := Copy(AName, DotPos + 1, DotPos2 - DotPos - 1);
- Module := nil;
- for i := 0 to HPackage.Modules.Count - 1 do
- if CompareText(TPasModule(HPackage.Modules[i]).Name, s) = 0 then
- begin
- Module := TPasModule(HPackage.Modules[i]);
- break;
- end;
- if not Assigned(Module) then
- begin
- if not CreateNew then
- exit;
- Module := TPasExternalModule.Create(s, HPackage);
- Module.InterfaceSection := TInterfaceSection.Create('', Module);
- HPackage.Modules.Add(Module);
- end;
- pkg:=hpackage;
- result:=Copy(AName, DotPos2 + 1, length(AName)-dotpos2);
- end;
- function SearchInList(clslist:TFPList;s:string):TPasElement;
- var i : integer;
- ClassEl: TPasElement;
- begin
- result:=nil;
- for i:=0 to clslist.count-1 do
- begin
- ClassEl := TPasElement(clslist[i]);
- if CompareText(ClassEl.Name,s) =0 then
- exit(Classel);
- end;
- end;
- function ResolveClassType(AName:String):TPasClassType;
- var
- pkg : TPasPackage;
- module : TPasModule;
- s : string;
- begin
- Result:=nil;
- s:=ResolvePackageModule(AName,pkg,module,False);
- if not assigned(module) then
- exit;
- result:=TPasClassType(SearchInList(Module.InterfaceSection.Classes,s));
- end;
- function ResolveAliasType(AName:String):TPasAliasType;
- var
- pkg : TPasPackage;
- module : TPasModule;
- s : string;
- begin
- Result:=nil;
- s:=ResolvePackageModule(AName,pkg,module,False);
- if not assigned(module) then
- exit;
- result:=TPasAliasType(SearchInList(Module.InterfaceSection.Types,s));
- if not (result is TPasAliasType) then
- result:=nil;
- end;
- procedure ReadClasses;
- function CreateClass(const AName: String;InheritanceStr:String): TPasClassType;
- var
- DotPos, DotPos2, i,j: Integer;
- s: String;
- HPackage: TPasPackage;
- Module: TPasModule;
- begin
- s:= ResolvePackageModule(AName,HPackage,Module,True);
- // Create node for class
- Result := TPasExternalClassType.Create(s, Module.InterfaceSection);
- Result.ObjKind := okClass;
- Module.InterfaceSection.Declarations.Add(Result);
- Module.InterfaceSection.Classes.Add(Result);
- // defer processing inheritancestr till all classes are loaded.
- if inheritancestr<>'' then
- InheritanceInfo.AddObject(Inheritancestr,result);
- end;
- procedure splitalias(var instr:string;out outstr:string);
- var i,j:integer;
- begin
- if length(instr)=0 then exit;
- instr:=trim(instr);
- i:=pos('(',instr);
- if i>0 then
- begin
- j:=length(instr)-i;
- if instr[length(instr)]=')' then
- dec(j);
- outstr:=copy(instr,i+1,j);
- delete(instr,i,j+2);
- end
- end;
- Function ResolveAndLinkClass(clname:String;IsClass:boolean;cls:TPasClassType):TPasClassType;
- begin
- result:=TPasClassType(ResolveClassType(clname));
- if assigned(result) and not (cls=result) then // save from tobject=implicit tobject
- begin
- result.addref;
- if IsClass then
- begin
- cls.ancestortype:=result;
- // writeln(cls.name, ' has as ancestor ',result.pathname);
- end
- else
- begin
- cls.interfaces.add(result);
- // writeln(cls.name, ' implements ',result.pathname);
- end;
- end
- else
- if cls<>result then
- DoLog('Warning : ancestor class %s of class %s could not be resolved',[clname,cls.name]);
- end;
- function CreateAliasType (alname,clname : string;parentclass:TPasClassType; out cl2 :TPasClassType):TPasAliasType;
- // create alias clname = alname
- var
- pkg : TPasPackage;
- module : TPasModule;
- s : string;
- begin
- Result:=nil;
- s:=ResolvePackageModule(Alname,pkg,module,True);
- if not assigned(module) then
- exit;
- cl2:=TPasClassType(ResolveClassType(alname));
- if assigned( cl2) and not (parentclass=cl2) then
- begin
- result:=ResolveAliasType(clname);
- if assigned(result) then
- begin
- // writeln('found alias ',clname,' (',s,') ',result.classname);
- end
- else
- begin
- // writeln('new alias ',clname,' (',s,') ');
- cl2.addref;
- Result := TPasAliasType(CreateElement(TPasAliasType,s,module.interfacesection,vispublic,'',0));
- module.interfacesection.Declarations.Add(Result);
- TPasAliasType(Result).DestType := cl2;
- end
- end
- end;
- procedure ProcessInheritanceStrings(inhInfo:TStringList);
- var i,j : integer;
- cls : TPasClassType;
- cls2: TPasClassType;
- clname,
- alname : string;
- inhclass : TStringList;
- begin
- inhclass:=TStringList.Create;
- inhclass.delimiter:=',';
- if InhInfo.Count>0 then
- for i:=0 to InhInfo.Count-1 do
- begin
- cls:=TPasClassType(InhInfo.Objects[i]);
- inhclass.clear;
- inhclass.delimitedtext:=InhInfo[i];
- for j:= 0 to inhclass.count-1 do
- begin
- //writeln('processing',inhclass[j]);
- clname:=inhclass[j];
- splitalias(clname,alname);
- if alname<>'' then // the class//interface we refered to is an alias
- begin
- // writeln('Found alias pair ',clname,' = ',alname);
- if not assigned(CreateAliasType(alname,clname,cls,cls2)) then
- DoLog('Warning: creating alias %s for %s failed!',[alname,clname]);
- end
- else
- cls2:=ResolveAndLinkClass(clname,j=0,cls);
- end;
- end;
- inhclass.free;
- end;
- var
- s, Name: String;
- CurClass: TPasClassType;
- i: Integer;
- Member: TPasElement;
- begin
- inheritanceinfo :=TStringlist.Create;
- Try
- CurClass := nil;
- while True do
- begin
- ReadLn(f, s);
- if Length(s) = 0 then
- break;
- if s[1] = '#' then
- begin
- // New class
- i := Pos(' ', s);
- CurClass := CreateClass(Copy(s, 1, i - 1), copy(s,i+1,length(s)));
- end else
- begin
- i := Pos(' ', s);
- if i = 0 then
- Name := Copy(s, 3, Length(s))
- else
- Name := Copy(s, 3, i - 3);
- case s[2] of
- 'M':
- Member := TPasProcedure.Create(Name, CurClass);
- 'P':
- begin
- Member := TPasProperty.Create(Name, CurClass);
- if i > 0 then
- while i <= Length(s) do
- begin
- case s[i] of
- 'r':
- TPasProperty(Member).ReadAccessorName := '<dummy>';
- 'w':
- TPasProperty(Member).WriteAccessorName := '<dummy>';
- 's':
- TPasProperty(Member).StoredAccessorName := '<dummy>';
- end;
- Inc(i);
- end;
- end;
- 'V':
- Member := TPasVariable.Create(Name, CurClass);
- else
- raise Exception.Create('Invalid member type: ' + s[2]);
- end;
- CurClass.Members.Add(Member);
- end;
- end;
- ProcessInheritanceStrings(Inheritanceinfo);
- finally
- inheritanceinfo.Free;
- end;
- end;
- var
- s: String;
- buf : Array[1..ContentBufSize-1] of byte;
- begin
- if not FileExists(AFileName) then
- raise EInOutError.Create('File not found: ' + AFileName);
- Assign(f, AFilename);
- Reset(f);
- SetTextBuf(F,Buf,SizeOf(Buf));
- while not EOF(f) do
- begin
- ReadLn(f, s);
- if (Length(s) = 0) or (s[1] = '#') then
- continue;
- if s = ':link tree' then
- ReadLinkTree
- else if s = ':classes' then
- ReadClasses
- else
- repeat
- ReadLn(f, s);
- until EOF(f) or (Length(s) = 0);
- end;
- Close(f);
- end;
- procedure TFPDocEngine.WriteContentFile(const AFilename: String);
- var
- ContentFile: Text;
- procedure ProcessLinkNode(ALinkNode: TLinkNode; const AIdent: String);
- var
- ChildNode: TLinkNode;
- begin
- WriteLn(ContentFile, AIdent, ALinkNode.Name, ' ', ALinkNode.Link);
- ChildNode := ALinkNode.FirstChild;
- while Assigned(ChildNode) do
- begin
- ProcessLinkNode(ChildNode, AIdent + ' ');
- ChildNode := ChildNode.NextSibling;
- end;
- end;
- function CheckImplicitInterfaceLink(const s : String):String;
- begin
- if uppercase(s)='IUNKNOWN' then
- Result:='#rtl.System.IUnknown'
- else
- Result:=s;
- end;
- var
- LinkNode: TLinkNode;
- i, j, k: Integer;
- Module: TPasModule;
- Alias : TPasAliasType;
- ClassDecl: TPasClassType;
- Member: TPasElement;
- s: String;
- Buf : Array[0..ContentBufSize-1] of byte;
- begin
- Assign(ContentFile, AFilename);
- Rewrite(ContentFile);
- SetTextBuf(ContentFile,Buf,SizeOf(Buf));
- try
- WriteLn(ContentFile, '# FPDoc Content File');
- WriteLn(ContentFile, ':link tree');
- LinkNode := RootLinkNode.FirstChild;
- while Assigned(LinkNode) do
- begin
- if LinkNode.Name = Package.Name then
- begin
- ProcessLinkNode(LinkNode, '');
- end;
- LinkNode := LinkNode.NextSibling;
- end;
- if Assigned(Package) then
- begin
- WriteLn(ContentFile);
- WriteLn(ContentFile, ':classes');
- for i := 0 to Package.Modules.Count - 1 do
- begin
- Module := TPasModule(Package.Modules[i]);
- if not assigned(Module.InterfaceSection) then
- continue;
- for j := 0 to Module.InterfaceSection.Classes.Count - 1 do
- begin
- ClassDecl := TPasClassType(Module.InterfaceSection.Classes[j]);
- Write(ContentFile, CheckImplicitInterfaceLink(ClassDecl.PathName), ' ');
- if Assigned(ClassDecl.AncestorType) then
- begin
- // simple aliases to class types are coded as "alias(classtype)"
- Write(ContentFile, CheckImplicitInterfaceLink(ClassDecl.AncestorType.PathName));
- if ClassDecl.AncestorType is TPasAliasType then
- begin
- alias:= TPasAliasType(ClassDecl.AncestorType);
- if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
- write(ContentFile,'(',alias.desttype.PathName,')');
- end;
- end
- else if ClassDecl.ObjKind = okClass then
- Write(ContentFile, '#rtl.System.TObject')
- else if ClassDecl.ObjKind = okInterface then
- Write(ContentFile, '#rtl.System.IUnknown');
- if ClassDecl.Interfaces.Count>0 then
- begin
- for k:=0 to ClassDecl.Interfaces.count-1 do
- begin
- write(contentfile,',',CheckImplicitInterfaceLink(TPasClassType(ClassDecl.Interfaces[k]).PathName));
- if TPasElement(ClassDecl.Interfaces[k]) is TPasAliasType then
- begin
- alias:= TPasAliasType(ClassDecl.Interfaces[k]);
- if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
- write(ContentFile,'(',CheckImplicitInterfaceLink(alias.desttype.PathName),')');
- end;
- end;
- end;
- writeln(contentfile);
- for k := 0 to ClassDecl.Members.Count - 1 do
- begin
- Member := TPasElement(ClassDecl.Members[k]);
- Write(ContentFile, Chr(Ord(Member.Visibility) + Ord('0')));
- SetLength(s, 0);
- if Member.ClassType = TPasVariable then
- Write(ContentFile, 'V')
- else if Member.ClassType = TPasProperty then
- begin
- Write(ContentFile, 'P');
- if Length(TPasProperty(Member).ReadAccessorName) > 0 then
- s := s + 'r';
- if Length(TPasProperty(Member).WriteAccessorName) > 0 then
- s := s + 'w';
- if Length(TPasProperty(Member).StoredAccessorName) > 0 then
- s := s + 's';
- end else
- Write(ContentFile, 'M'); // Member must be a method
- Write(ContentFile, Member.Name);
- if Length(s) > 0 then
- WriteLn(ContentFile, ' ', s)
- else
- WriteLn(ContentFile);
- end;
- end;
- end;
- end;
- finally
- Close(ContentFile);
- end;
- end;
- function TFPDocEngine.CreateElement(AClass: TPTreeElement; const AName: String;
- AParent: TPasElement; AVisibility: TPasMemberVisibility;
- const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
- begin
- Result := AClass.Create(AName, AParent);
- Result.Visibility := AVisibility;
- if AClass.InheritsFrom(TPasModule) then
- CurModule := TPasModule(Result);
- Result.SourceFilename := ASourceFilename;
- Result.SourceLinenumber := ASourceLinenumber;
- end;
- function TFPDocEngine.FindElement(const AName: String): TPasElement;
- function FindInModule(AModule: TPasModule; const LocalName: String): TPasElement;
-
- var
- l: TFPList;
- i: Integer;
-
- begin
- If assigned(AModule.InterfaceSection) and
- Assigned(AModule.InterfaceSection.Declarations) then
- begin
- l:=AModule.InterfaceSection.Declarations;
- for i := 0 to l.Count - 1 do
- begin
- Result := TPasElement(l[i]);
- if CompareText(Result.Name, LocalName) = 0 then
- exit;
- end;
- end;
- Result := nil;
- end;
- var
- i: Integer;
- Module: TPasElement;
- begin
- Result := FindInModule(CurModule, AName);
- if not Assigned(Result) and assigned (CurModule.InterfaceSection) then
- for i := CurModule.InterfaceSection.UsesList.Count - 1 downto 0 do
- begin
- Module := TPasElement(CurModule.InterfaceSection.UsesList[i]);
- if Module.ClassType.InheritsFrom(TPasModule) then
- begin
- Result := FindInModule(TPasModule(Module), AName);
- if Assigned(Result) then
- exit;
- end;
- end;
- end;
- function TFPDocEngine.FindModule(const AName: String): TPasModule;
- function FindInPackage(APackage: TPasPackage): TPasModule;
- var
- i: Integer;
- begin
- for i := 0 to APackage.Modules.Count - 1 do
- begin
- Result := TPasModule(APackage.Modules[i]);
- if CompareText(Result.Name, AName) = 0 then
- exit;
- end;
- Result := nil;
- end;
- var
- i: Integer;
- AInPutLine,OSTarget,CPUTarget : String;
- begin
- Result := FindInPackage(Package);
- if not Assigned(Result) then
- for i := FPackages.Count - 1 downto 0 do
- begin
- if TPasPackage(FPackages[i]) = Package then
- continue;
- Result := FindInPackage(TPasPackage(FPackages[i]));
- if Assigned(Result) then
- exit;
- end;
- if Not Assigned(Result) and Assigned(FOnParseUnit) then
- begin
- FOnParseUnit(Self,AName,AInputLine,OSTarget,CPUTarget);
- If (AInPutLine<>'') then
- Result:=ParseUsedUnit(AName,AInputLine,OSTarget,CPUTarget);
- end;
- end;
- function TFPDocEngine.HintsToStr(Hints: TPasMemberHints): String;
- Var
- H : TPasMemberHint;
- begin
- Result:='';
- For h:=Low(TPasMemberHint) to High(TPasMemberHint) do
- if h in Hints then
- begin
- if (Result<>'') then
- Result:=Result+', ';
- Result:=Result+cPasMemberHint[h]
- end;
- end;
- function TFPDocEngine.ParseUsedUnit(AName, AInputLine, AOSTarget,
- ACPUTarget: String): TPasModule;
- Var
- M : TPasModule;
- begin
- DoLog(SParsingUsedUnit,[AName,AInputLine]);
- M:=CurModule;
- CurModule:=Nil;
- try
- ParseSource(Self,AInputLine,AOSTarget,ACPUTarget,True);
- Result:=CurModule;
- finally
- CurModule:=M;
- end;
- end;
- procedure TFPDocEngine.AddLink(const APathName, ALinkTo: String);
- begin
- RootLinkNode.CreateChildren(APathName, ALinkTo);
- end;
- function TFPDocEngine.FindAbsoluteLink(const AName: String): String;
- var
- LinkNode: TLinkNode;
- begin
- LinkNode := RootLinkNode.FindChild(AName);
- if Assigned(LinkNode) then
- Result := LinkNode.Link
- else
- SetLength(Result, 0);
- end;
- function TFPDocEngine.ResolveLinkInPackages(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
- Var
- ThisPackage: TLinkNode;
- begin
- { Try all packages }
- Result:='';
- ThisPackage:=RootLinkNode.FirstChild;
- while Assigned(ThisPackage) and (Result='') do
- begin
- Result:=ResolveLink(AModule, ThisPackage.Name + '.' + ALinkDest, Strict);
- ThisPackage := ThisPackage.NextSibling;
- end;
- end;
- function TFPDocEngine.ResolveLinkInUsedUnits(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
- var
- i: Integer;
- UL: TFPList;
- begin
- Result:='';
- UL:=AModule.InterfaceSection.UsesList;
- I:=UL.Count-1;
- While (Result='') and (I>=0) do
- begin
- Result:=ResolveLinkInPackages(AModule,TPasType(UL[i]).Name+'.'+ALinkDest, strict);
- Dec(I);
- end;
- end;
- function TFPDocEngine.ResolveLink(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
- var
- i: Integer;
- begin
- {
- if Assigned(AModule) then
- system.WriteLn('ResolveLink(', AModule.Name, ' - ', ALinkDest, ')... ')
- else
- system.WriteLn('ResolveLink(Nil - ', ALinkDest, ')... ');
- }
- if (ALinkDest='') then
- Exit('');
- if (ALinkDest[1] = '#') then
- Result := FindAbsoluteLink(ALinkDest)
- else if (AModule=Nil) then
- Result:= FindAbsoluteLink(RootLinkNode.FirstChild.Name+'.'+ALinkDest)
- else
- begin
- if Pos(AModule.Name,ALinkDest) = 1 then
- Result := ResolveLink(AModule, AModule.packagename + '.' + ALinkDest, Strict)
- else
- Result := ResolveLink(AModule, AModule.PathName + '.' + ALinkDest, Strict);
- if (Result='') then
- begin
- Result:=ResolveLinkInPackages(AModule,ALinkDest,Strict);
- if (Result='') then
- Result:=ResolveLinkInUsedUnits(Amodule,AlinkDest,Strict);
- end;
- end;
- // Match on parent : class/enumerated/record/module
- if (Result='') and not strict then
- for i := Length(ALinkDest) downto 1 do
- if ALinkDest[i] = '.' then
- begin
- Result := ResolveLink(AModule, Copy(ALinkDest, 1, i - 1), Strict);
- exit;
- end;
- end;
- procedure ReadXMLFileALT(OUT ADoc:TXMLDocument;const AFileName:ansistring);
- var
- Parser: TDOMParser;
- Src: TXMLInputSource;
- FileStream: TStream;
- begin
- ADoc := nil;
- FileStream := TFileStream.Create(AFilename, fmOpenRead+fmShareDenyWrite);
- try
- Parser := TDOMParser.Create; // create a parser object
- try
- Src := TXMLInputSource.Create(FileStream); // and the input source
- src.SystemId:=FileNameToUri(AFileName);
- try
- Parser.Options.PreserveWhitespace := True;
- Parser.Parse(Src, ADoc);
- finally
- Src.Free; // cleanup
- end;
- finally
- Parser.Free;
- end;
- finally
- FileStream.Free;
- end;
- end;
- procedure TFPDocEngine.AddDocFile(const AFilename: String;DontTrim:boolean=false);
- Var
- PN : String;
- function ReadNode(OwnerDocNode: TDocNode; Element: TDOMElement): TDocNode;
- var
- Subnode: TDOMNode;
- begin
- if OwnerDocNode = RootDocNode then
- Result := OwnerDocNode.CreateChildren('#' + Element['name'])
- else
- Result := OwnerDocNode.CreateChildren(Element['name']);
- Result.FNode := Element;
- Result.FLink := Element['link'];
- if (Element['alwaysvisible'] = '1') and (Element.NodeName='element') then
- FAlwaysVisible.Add(LowerCase(PN+'.'+TDocNode(OwnerDocNode).Name+'.'+Element['name']));
- Result.FIsSkipped := Element['skip'] = '1';
- Subnode := Element.FirstChild;
- while Assigned(Subnode) do
- begin
- if Subnode.NodeType = ELEMENT_NODE then
- begin
- if Subnode.NodeName = 'short' then
- Result.FShortDescr := TDOMElement(Subnode)
- else if Subnode.NodeName = 'descr' then
- Result.FDescr := TDOMElement(Subnode)
- else if Subnode.NodeName = 'version' then
- begin
- Result.FVersion := TDOMElement(Subnode)
- end
- else if Subnode.NodeName = 'errors' then
- Result.FErrorsDoc := TDOMElement(Subnode)
- else if Subnode.NodeName = 'seealso' then
- Result.FSeeAlso := TDOMElement(Subnode)
- else if (Subnode.NodeName = 'example') and
- not Assigned(Result.FirstExample) then
- Result.FFirstExample := TDOMElement(Subnode)
- else if (Subnode.NodeName = 'notes') then
- Result.FNotes := TDOMElement(Subnode);
- end;
- Subnode := Subnode.NextSibling;
- end;
- end;
- Procedure ReadTopics(TopicNode : TDocNode);
- Var
- SubNode : TDOMNode;
- begin
- SubNode:=TopicNode.FNode.FirstChilD;
- While Assigned(SubNode) do
- begin
- If (SubNode.NodeType=ELEMENT_NODE) and (SubNode.NodeName='topic') then
- With ReadNode(TopicNode,TDomElement(SubNode)) do
- // We could allow recursion here, but we won't, because it doesn't work on paper.
- FTopicNode:=True;
- SubNode:=Subnode.NextSibling;
- end;
- end;
- var
- i: Integer;
- Node, Subnode, Subsubnode: TDOMNode;
- Element: TDOMElement;
- Doc: TXMLDocument;
- PackageDocNode, TopicNode,ModuleDocNode: TDocNode;
- begin
- if DontTrim then
- ReadXMLFileALT(Doc, AFilename)
- else
- ReadXMLFile(Doc, AFilename);
- DescrDocs.Add(Doc);
- DescrDocNames.Add(AFilename);
- Node := Doc.DocumentElement.FirstChild;
- while Assigned(Node) do
- begin
- if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'package') then
- begin
- PackageDocNode := ReadNode(RootDocNode, TDOMElement(Node));
- PackageDocNode.IncRefCount;
- PN:=PackageDocNode.Name;
- // Scan all 'module' elements within this package element
- Subnode := Node.FirstChild;
- while Assigned(Subnode) do
- begin
- if (Subnode.NodeType = ELEMENT_NODE) then
- begin
- If (Subnode.NodeName = 'module') then
- begin
- ModuleDocNode := ReadNode(PackageDocNode, TDOMElement(Subnode));
- // Scan all 'element' elements within this module element
- Subsubnode := Subnode.FirstChild;
- while Assigned(Subsubnode) do
- begin
- if (Subsubnode.NodeType = ELEMENT_NODE) then
- begin
- if (Subsubnode.NodeName = 'element') then
- ReadNode(ModuleDocNode, TDOMElement(Subsubnode))
- else if (SubSubNode.NodeName='topic') then
- begin
- TopicNode:=ReadNode(ModuleDocNode,TDomElement(SubSubNode));
- TopicNode.FTopicNode:=True;
- ReadTopics(TopicNode);
- end;
- end;
- Subsubnode := Subsubnode.NextSibling;
- end;
- end
- else if (SubNode.NodeName='topic') then
- begin
- TopicNode:=ReadNode(PackageDocNode,TDomElement(SubNode));
- TopicNode.FTopicNode:=True;
- ReadTopics(TopicNode);
- end;
- end;
- Subnode := Subnode.NextSibling;
- end;
- end;
- Node := Node.NextSibling;
- end;
- end;
- function TFPDocEngine.FindDocNode(AElement: TPasElement): TDocNode;
- begin
- Result:=Nil;
- If Assigned(AElement) then
- begin
- if AElement.InheritsFrom(TPasUnresolvedTypeRef) then
- Result := FindDocNode(AElement.GetModule, AElement.Name)
- else
- Result := RootDocNode.FindChild(AElement.PathName);
- if (Result=Nil) and
- WarnNoNode and
- (Length(AElement.PathName)>0) and
- (AElement.PathName[1]='#') then
- DoLog(Format('No documentation node found for identifier : %s',[AElement.PathName]));
- end;
- end;
- function TFPDocEngine.FindDocNode(ARefModule: TPasModule;
- const AName: String): TDocNode;
- var
- CurPackage: TDocNode;
- UnitList: TFPList;
- i: Integer;
- begin
- if Length(AName) = 0 then
- Result := nil
- else
- begin
- if AName[1] = '#' then
- Result := RootDocNode.FindChild(AName)
- else
- Result := RootDocNode.FindChild(Package.Name + '.' + AName);
- if (not Assigned(Result)) and Assigned(ARefModule) then
- Result := RootDocNode.FindChild(ARefModule.PathName + '.' + AName);
- if (not Assigned(Result)) and (AName[1] <> '#') then
- begin
- CurPackage := RootDocNode.FirstChild;
- while Assigned(CurPackage) do
- begin
- Result := RootDocNode.FindChild(CurPackage.Name + '.' + AName);
- if Assigned(Result) then
- break;
- CurPackage := CurPackage.NextSibling;
- end;
- if not Assigned(Result) and assigned(CurModule.InterfaceSection) then
- begin
- { Okay, then we have to try all imported units of the current module }
- UnitList := CurModule.InterfaceSection.UsesList;
- for i := UnitList.Count - 1 downto 0 do
- begin
- { Try all packages }
- CurPackage := RootDocNode.FirstChild;
- while Assigned(CurPackage) do
- begin
- Result := RootDocNode.FindChild(CurPackage.Name + '.' +
- TPasType(UnitList[i]).Name + '.' + AName);
- if Assigned(Result) then
- break;
- CurPackage := CurPackage.NextSibling;
- end;
- end;
- end;
- end;
- end;
- end;
- function TFPDocEngine.FindShortDescr(AElement: TPasElement): TDOMElement;
- var
- DocNode,N: TDocNode;
- begin
- DocNode := FindDocNode(AElement);
- if Assigned(DocNode) then
- begin
- N:=FindLinkedNode(DocNode);
- If (N<>Nil) then
- DocNode:=N;
- Result := DocNode.ShortDescr;
- end
- else
- Result := nil;
- end;
- function TFPDocEngine.FindLinkedNode(ANode : TDocNode) : TDocNode;
- Var
- S: String;
- begin
- If (ANode.Link='') then
- Result:=Nil
- else
- Result:=FindDocNode(CurModule,ANode.Link);
- end;
- function TFPDocEngine.ShowElement(El: TPasElement): Boolean;
- begin
- Case El.Visibility of
- visStrictPrivate,
- visPrivate :
- Result:=Not HidePrivate;
- visStrictProtected,
- visProtected :
- begin
- Result:=Not HideProtected;
- if not Result then
- Result:=FAlwaysVisible.IndexOf(LowerCase(El.PathName))<>-1;
- end
- Else
- Result:=True
- end;
- end;
- procedure TFPDocEngine.StartDocumenting;
- begin
- FAlwaysVisible.Sorted:=True;
- end;
- function TFPDocEngine.FindShortDescr(ARefModule: TPasModule;
- const AName: String): TDOMElement;
- var
- N,DocNode: TDocNode;
- begin
- DocNode := FindDocNode(ARefModule, AName);
- if Assigned(DocNode) then
- begin
- N:=FindLinkedNode(DocNode);
- If (N<>Nil) then
- DocNode:=N;
- Result := DocNode.ShortDescr;
- end
- else
- Result := nil;
- end;
- function TFPDocEngine.GetExampleFilename(const ExElement: TDOMElement): String;
- var
- i: Integer;
- fn : String;
-
- begin
- Result:='';
- for i := 0 to DescrDocs.Count - 1 do
- begin
- Fn:=ExElement['file'];
- if (FN<>'') and (TDOMDocument(DescrDocs[i]) = ExElement.OwnerDocument) then
- begin
- Result := ExtractFilePath(DescrDocNames[i]) + FN;
- if (ExtractFileExt(Result)='') then
- Result:=Result+'.pp';
- end;
- end;
- end;
- { Global helpers }
- procedure TranslateDocStrings(const Lang: String);
- Const
- {$ifdef unix}
- DefDir = '/usr/local/share/locale';
- {$else}
- DefDir = 'intl';
- {$endif}
- var
- mo: TMOFile;
- dir : string;
- begin
- dir:=modir;
- If Dir='' then
- Dir:=DefDir;
- Dir:=IncludeTrailingPathDelimiter(Dir);
- {$IFDEF Unix}
- mo := TMOFile.Create(Format(Dir+'%s/LC_MESSAGES/dglobals.mo', [Lang]));
- {$ELSE}
- mo := TMOFile.Create(Format(Dir+'dglobals.%s.mo', [Lang]));
- {$ENDIF}
- try
- TranslateResourceStrings(mo);
- finally
- mo.Free;
- end;
- end;
- Function IsLinkNode(Node : TDomNode) : Boolean;
- begin
- Result:=Assigned(Node) and (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'link');
- end;
- Function IsExampleNode(Example : TDomNode) : Boolean;
- begin
- Result:=Assigned(Example) and (Example.NodeType = ELEMENT_NODE) and (Example.NodeName = 'example')
- end;
- function IsLinkAbsolute(ALink: String): boolean;
- var
- i: integer;
- begin
- Result := false;
- for i := low(AbsoluteLinkPrefixes) to high(AbsoluteLinkPrefixes) do
- if CompareText(AbsoluteLinkPrefixes[i], copy(ALink,1,length(AbsoluteLinkPrefixes[i])))=0 then begin
- Result := true;
- break;
- end;
- end;
- initialization
- LEOL:=Length(LineEnding);
- end.
|