2
0

dglobals.pp 47 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633
  1. {
  2. FPDoc - Free Pascal Documentation Tool
  3. Copyright (C) 2000 - 2002 by
  4. Areca Systems GmbH / Sebastian Guenther, [email protected]
  5. * Global declarations
  6. * Link list management
  7. * Document node tree
  8. * Main engine
  9. See the file COPYING, included in this distribution,
  10. for details about the copyright.
  11. This program is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14. }
  15. {$MODE objfpc}
  16. {$H+}
  17. unit dGlobals;
  18. interface
  19. uses Classes, DOM, PasTree, PParser, uriparser, SysUtils;
  20. Const
  21. CacheSize = 20;
  22. ContentBufSize = 4096 * 8;
  23. Var
  24. LEOL : Integer;
  25. modir : string;
  26. Const
  27. SVisibility: array[TPasMemberVisibility] of string =
  28. ('Default', 'Private', 'Protected', 'Public',
  29. 'Published', 'Automated','Strict Private','Strict Protected',
  30. 'Required', 'Optional' // ObjCClass
  31. );
  32. type
  33. TBufType = Array[1..ContentBufSize-1] of byte;
  34. // Assumes a list of TObject instances and frees them on destruction
  35. TObjectList = class(TFPList)
  36. public
  37. destructor Destroy; override;
  38. end;
  39. TPasExternalClassType = Class(TPasClassType);
  40. TPasExternalModule = Class(TPasModule);
  41. { Link entry tree
  42. TFPDocEngine stores the root of the entry tree in its property
  43. "RootLinkNode". The root has one child node for each package, for which
  44. documentation links are available. The children of a package node
  45. are module nodes; and the children of a module node are the top-level
  46. declarations of this module; the next level in the tree stores e.g. record
  47. members, and so on...
  48. }
  49. TLinkNode = class
  50. private
  51. FFirstChild, FNextSibling: TLinkNode;
  52. FName: String;
  53. FLink: String;
  54. public
  55. constructor Create(const AName, ALink: String);
  56. destructor Destroy; override;
  57. function FindChild(const APathName: String): TLinkNode;
  58. function CreateChildren(const APathName, ALinkTo: String): TLinkNode;
  59. // Properties for tree structure
  60. property FirstChild: TLinkNode read FFirstChild;
  61. property NextSibling: TLinkNode read FNextSibling;
  62. // Link properties
  63. property Name: String read FName;
  64. property Link: String read FLink;
  65. end;
  66. { Documentation entry tree
  67. TFPDocEngine stores the root of the entry tree in its property
  68. "RootDocNode". The root has one child node for each package, for which
  69. documentation is being provided by the user. The children of a package node
  70. are module nodes; and the children of a module node are the top-level
  71. declarations of this module; the next level in the tree stores e.g. record
  72. members, and so on...
  73. }
  74. { TDocNode }
  75. TDocNode = class
  76. private
  77. FFirstChild, FNextSibling: TDocNode;
  78. FName: String;
  79. FNode: TDOMElement;
  80. FIsSkipped: Boolean;
  81. FShortDescr: TDOMElement;
  82. FDescr: TDOMElement;
  83. FErrorsDoc: TDOMElement;
  84. FSeeAlso: TDOMElement;
  85. FFirstExample: TDOMElement;
  86. FNotes : TDomElement;
  87. FLink: String;
  88. FTopicNode : Boolean;
  89. FRefCount : Integer;
  90. FVersion: TDomElement;
  91. public
  92. constructor Create(const AName: String; ANode: TDOMElement);
  93. destructor Destroy; override;
  94. Function IncRefcount : Integer;
  95. function FindChild(const APathName: String): TDocNode;
  96. function CreateChildren(const APathName: String): TDocNode;
  97. // Properties for tree structure
  98. property FirstChild: TDocNode read FFirstChild;
  99. property NextSibling: TDocNode read FNextSibling;
  100. // Basic properties
  101. property Name: String read FName;
  102. property Node: TDOMElement read FNode;
  103. // Data fetched from the XML document
  104. property IsSkipped: Boolean read FIsSkipped;
  105. property ShortDescr: TDOMElement read FShortDescr;
  106. property Descr: TDOMElement read FDescr;
  107. property ErrorsDoc: TDOMElement read FErrorsDoc;
  108. Property Version : TDomElement Read FVersion;
  109. property SeeAlso: TDOMElement read FSeeAlso;
  110. property FirstExample: TDOMElement read FFirstExample;
  111. property Notes : TDOMElement read FNotes;
  112. property Link: String read FLink;
  113. Property TopicNode : Boolean Read FTopicNode;
  114. Property RefCount : Integer Read FRefCount;
  115. end;
  116. // The main FPDoc engine
  117. TFPDocLogLevel = (dleWarnNoNode, dleWarnUsedFile, dleDocumentationEmpty, dleXCT);
  118. TFPDocLogLevels = set of TFPDocLogLevel;
  119. TOnParseUnitEvent = Procedure (Sender : TObject; Const AUnitName : String; Out AInputFile,OSTarget,CPUTarget : String) of Object;
  120. { TFPDocEngine }
  121. TFPDocEngine = class(TPasTreeContainer)
  122. private
  123. FDocLogLevels: TFPDocLogLevels;
  124. FOnParseUnit: TOnParseUnitEvent;
  125. function ResolveLinkInPackages(AModule: TPasModule; const ALinkDest: String; Strict: Boolean=False): String;
  126. function ResolveLinkInUsedUnits(AModule: TPasModule; const ALinkDest: String; Strict: Boolean=False): String;
  127. protected
  128. FAlwaysVisible : TStringList;
  129. DescrDocs: TObjectList; // List of XML documents
  130. DescrDocNames: TStringList; // Names of the XML documents
  131. FRootLinkNode: TLinkNode; // Global tree of TlinkNode from the imported .xct files
  132. FRootDocNode: TDocNode; // Global tree of TDocNode from the .xml documentation files
  133. FPackages: TFPList; // Global list of TPasPackage objects and full tree of sources
  134. CurModule: TPasModule;
  135. CurPackageDocNode: TDocNode;
  136. function ParseUsedUnit(AName, AInputLine,AOSTarget,ACPUTarget: String): TPasModule; virtual;
  137. Function LogEvent(E : TFPDocLogLevel) : Boolean;
  138. Procedure DoLog(Const Msg : String);overload;
  139. Procedure DoLog(Const Fmt : String; Args : Array of const);overload;
  140. public
  141. Output: String;
  142. HasContentFile: Boolean;
  143. HidePrivate: Boolean; // Hide private class members in output?
  144. HideProtected: Boolean; // Hide protected class members in output?
  145. FalbackSeeAlsoLinks: Boolean; // Simplify SeeAlso Links
  146. constructor Create;
  147. destructor Destroy; override;
  148. procedure SetPackageName(const APackageName: String);
  149. // The process importing of objects from external .xct file
  150. procedure ReadContentFile(const AFilename, ALinkPrefix: String);
  151. // Creation of an own .xct output file
  152. procedure WriteContentFile(const AFilename: String);
  153. function CreateElement(AClass: TPTreeElement; const AName: String;
  154. AParent: TPasElement; AVisibility: TPasMemberVisibility;
  155. const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
  156. override;
  157. function FindElement(const AName: String ; AModule: TPasModule): TPasElement; overload;
  158. function FindElement(const AName: String): TPasElement; override;
  159. function FindModule(const AName: String): TPasModule; override;
  160. Function HintsToStr(Hints : TPasMemberHints) : String;
  161. // Link tree support
  162. procedure AddLink(const APathName, ALinkTo: String);
  163. function FindAbsoluteLink(const AName: String): String;
  164. // resolve link inside actual AModule and AModule.Parent = APackage
  165. function ResolveLink(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
  166. function FindLinkedNode(ANode: TDocNode): TDocNode;
  167. Function ShowElement(El : TPasElement) : Boolean; inline;
  168. // Call this before documenting.
  169. Procedure StartDocumenting; virtual;
  170. // Documentation file support
  171. procedure AddDocFile(const AFilename: String;DontTrim:boolean=false);
  172. // Documentation retrieval
  173. function FindDocNode(AElement: TPasElement): TDocNode;
  174. function FindDocNode(ARefModule: TPasModule; const AName: String): TDocNode;
  175. function FindShortDescr(AElement: TPasElement): TDOMElement;
  176. function FindShortDescr(ARefModule: TPasModule; const AName: String): TDOMElement;
  177. function GetExampleFilename(const ExElement: TDOMElement): String;
  178. property RootLinkNode: TLinkNode read FRootLinkNode;
  179. property RootDocNode: TDocNode read FRootDocNode;
  180. Property DocLogLevels : TFPDocLogLevels Read FDocLogLevels Write FDocLogLevels;
  181. Property OnParseUnit : TOnParseUnitEvent Read FOnParseUnit Write FOnParseUnit;
  182. end;
  183. procedure TranslateDocStrings(const Lang: String);
  184. {$IFDEF EXCEPTION_STACK}
  185. function DumpExceptionCallStack(E: Exception):String;
  186. {$ENDIF}
  187. Function IsLinkNode(Node : TDomNode) : Boolean;
  188. Function IsExampleNode(Example : TDomNode) : Boolean;
  189. // returns true is link is an absolute URI
  190. Function IsLinkAbsolute(ALink: String): boolean;
  191. implementation
  192. uses Gettext, XMLRead, fpdocstrs;
  193. const
  194. AbsoluteLinkPrefixes : array[0..2] of string = ('/', 'http://', 'ms-its:');
  195. { TObjectList }
  196. destructor TObjectList.Destroy;
  197. var
  198. i: Integer;
  199. begin
  200. for i := 0 to Count - 1 do
  201. TObject(Items[i]).Free;
  202. inherited Destroy;
  203. end;
  204. { TLinkNode }
  205. constructor TLinkNode.Create(const AName, ALink: String);
  206. begin
  207. inherited Create;
  208. FName := AName;
  209. FLink := ALink;
  210. end;
  211. destructor TLinkNode.Destroy;
  212. begin
  213. if Assigned(FirstChild) then
  214. FirstChild.Free;
  215. if Assigned(NextSibling) then
  216. NextSibling.Free;
  217. inherited Destroy;
  218. end;
  219. function TLinkNode.FindChild(const APathName: String): TLinkNode;
  220. var
  221. DotPos: Integer;
  222. ChildName: String;
  223. Child: TLinkNode;
  224. begin
  225. if Length(APathName) = 0 then
  226. Result := Self
  227. else
  228. begin
  229. DotPos := Pos('.', APathName);
  230. if DotPos = 0 then
  231. ChildName := APathName
  232. else
  233. ChildName := Copy(APathName, 1, DotPos - 1);
  234. Child := FirstChild;
  235. while Assigned(Child) do
  236. begin
  237. if CompareText(Child.Name, ChildName) = 0 then
  238. begin
  239. if DotPos = 0 then
  240. Result := Child
  241. else
  242. Result := Child.FindChild(
  243. Copy(APathName, DotPos + 1, Length(APathName)));
  244. exit;
  245. end;
  246. Child := Child.NextSibling;
  247. end;
  248. Result := nil;
  249. end;
  250. end;
  251. function TLinkNode.CreateChildren(const APathName, ALinkTo: String): TLinkNode;
  252. var
  253. DotPos: Integer;
  254. ChildName: String;
  255. Child, LastChild: TLinkNode;
  256. begin
  257. if Length(APathName) = 0 then
  258. Result := Self
  259. else
  260. begin
  261. DotPos := Pos('.', APathName);
  262. if DotPos = 0 then
  263. ChildName := APathName
  264. else
  265. ChildName := Copy(APathName, 1, DotPos - 1);
  266. Child := FirstChild;
  267. LastChild := nil;
  268. while Assigned(Child) do
  269. begin
  270. if CompareText(Child.Name, ChildName) = 0 then
  271. begin
  272. if DotPos = 0 then
  273. Result := Child
  274. else
  275. Result := Child.CreateChildren(
  276. Copy(APathName, DotPos + 1, Length(APathName)), ALinkTo);
  277. exit;
  278. end;
  279. LastChild := Child;
  280. Child := Child.NextSibling;
  281. end;
  282. Result := TLinkNode.Create(ChildName, ALinkTo);
  283. if Assigned(LastChild) then
  284. LastChild.FNextSibling := Result
  285. else
  286. FFirstChild := Result;
  287. end;
  288. end;
  289. { TDocNode }
  290. constructor TDocNode.Create(const AName: String; ANode: TDOMElement);
  291. begin
  292. inherited Create;
  293. FName := AName;
  294. FNode := ANode;
  295. end;
  296. destructor TDocNode.Destroy;
  297. begin
  298. if Assigned(FirstChild) then
  299. FirstChild.Free;
  300. if Assigned(NextSibling) then
  301. NextSibling.Free;
  302. inherited Destroy;
  303. end;
  304. Function TDocNode.IncRefcount : Integer;
  305. begin
  306. Inc(FRefCount);
  307. Result:=FRefCount;
  308. end;
  309. function TDocNode.FindChild(const APathName: String): TDocNode;
  310. var
  311. DotPos: Integer;
  312. ChildName: String;
  313. Child: TDocNode;
  314. begin
  315. if Length(APathName) = 0 then
  316. Result := Self
  317. else
  318. begin
  319. DotPos := Pos('.', APathName);
  320. if DotPos = 0 then
  321. ChildName := APathName
  322. else
  323. ChildName := Copy(APathName, 1, DotPos - 1);
  324. Child := FirstChild;
  325. while Assigned(Child) do
  326. begin
  327. if CompareText(Child.Name, ChildName) = 0 then
  328. begin
  329. if DotPos = 0 then
  330. Result := Child
  331. else
  332. Result := Child.FindChild(
  333. Copy(APathName, DotPos + 1, Length(APathName)));
  334. exit;
  335. end;
  336. Child := Child.NextSibling;
  337. end;
  338. Result := nil;
  339. end;
  340. end;
  341. function TDocNode.CreateChildren(const APathName: String): TDocNode;
  342. var
  343. DotPos: Integer;
  344. ChildName: String;
  345. Child: TDocNode;
  346. begin
  347. if Length(APathName) = 0 then
  348. Result := Self
  349. else
  350. begin
  351. DotPos := Pos('.', APathName);
  352. if DotPos = 0 then
  353. ChildName := APathName
  354. else
  355. ChildName := Copy(APathName, 1, DotPos - 1);
  356. Child := FirstChild;
  357. while Assigned(Child) do
  358. begin
  359. if CompareText(Child.Name, ChildName) = 0 then
  360. begin
  361. if DotPos = 0 then
  362. Result := Child
  363. else
  364. Result := Child.CreateChildren(
  365. Copy(APathName, DotPos + 1, Length(APathName)));
  366. exit;
  367. end;
  368. Child := Child.NextSibling;
  369. end;
  370. // No child found, let's create one
  371. Result := TDocNode.Create(ChildName, nil);
  372. if Assigned(FirstChild) then
  373. begin
  374. Result.FNextSibling := FirstChild;
  375. FFirstChild := Result;
  376. end else
  377. FFirstChild := Result;
  378. if DotPos > 0 then
  379. Result := Result.CreateChildren(
  380. Copy(APathName, DotPos + 1, Length(APathName)));
  381. end;
  382. end;
  383. { TFPDocEngine }
  384. function TFPDocEngine.LogEvent(E: TFPDocLogLevel): Boolean;
  385. begin
  386. Result:=E in FDocLogLevels;
  387. end;
  388. procedure TFPDocEngine.DoLog(const Msg: String);
  389. begin
  390. If Assigned(OnLog) then
  391. OnLog(Self,Msg);
  392. end;
  393. procedure TFPDocEngine.DoLog(const Fmt: String; Args: array of const);
  394. begin
  395. DoLog(Format(Fmt,Args));
  396. end;
  397. constructor TFPDocEngine.Create;
  398. begin
  399. inherited Create;
  400. DescrDocs := TObjectList.Create;
  401. FAlwaysVisible := TStringList.Create;
  402. FAlwaysVisible.CaseSensitive:=True;
  403. DescrDocNames := TStringList.Create;
  404. FRootLinkNode := TLinkNode.Create('', '');
  405. FRootDocNode := TDocNode.Create('', nil);
  406. HidePrivate := True;
  407. InterfaceOnly:=True;
  408. FPackages := TFPList.Create;
  409. end;
  410. destructor TFPDocEngine.Destroy;
  411. var
  412. i: Integer;
  413. begin
  414. if FPackages.Count > 0 then
  415. for i := 0 to FPackages.Count - 1 do
  416. TPasPackage(FPackages[i]).Release{$IFDEF CheckPasTreeRefCount}('TFPDocEngine.Destroy'){$ENDIF}
  417. else
  418. FreeAndNil(FPackages);
  419. FreeAndNil(FRootDocNode);
  420. FreeAndNil(FRootLinkNode);
  421. FreeAndNil(DescrDocNames);
  422. FreeAndNil(DescrDocs);
  423. FreeAndNil(FAlwaysVisible);
  424. FreeAndNil(FPackages);
  425. inherited Destroy;
  426. end;
  427. procedure TFPDocEngine.SetPackageName(const APackageName: String);
  428. begin
  429. ASSERT(not Assigned(Package));
  430. FPackage := TPasPackage(inherited CreateElement(TPasPackage,
  431. '#' + APackageName, nil, '', 0));
  432. FPackages.Add(FPackage);
  433. CurPackageDocNode := RootDocNode.FindChild('#' + APackageName);
  434. If Assigned(CurPackageDocNode) then
  435. CurPackageDocNode.IncRefCount;
  436. end;
  437. procedure TFPDocEngine.ReadContentFile(const AFilename, ALinkPrefix: String);
  438. var
  439. f: Text;
  440. inheritanceinfo : TStringlist; // contents list of TPasClass with inheritance info
  441. // like this #PackageName.ModuleName.ClassName
  442. tmpLinkPrefix : string;
  443. procedure ReadLinkTree;
  444. var
  445. s: String;
  446. PrevSpaces, ThisSpaces, i, StackIndex: Integer;
  447. CurParent, PrevSibling, NewNode: TLinkNode;
  448. ParentStack, SiblingStack: array[0..7] of TLinkNode;
  449. begin
  450. PrevSpaces := 0;
  451. CurParent := RootLinkNode;
  452. PrevSibling := CurParent.FirstChild;
  453. if assigned(PrevSibling) then
  454. while assigned(PrevSibling.NextSibling) do
  455. PrevSibling := PrevSibling.NextSibling;
  456. StackIndex := 0;
  457. while True do
  458. begin
  459. ReadLn(f, s);
  460. if Length(s) = 0 then
  461. break;
  462. ThisSpaces := 0;
  463. while s[ThisSpaces + 1] = ' ' do
  464. Inc(ThisSpaces);
  465. if ThisSpaces <> PrevSpaces then
  466. begin
  467. if ThisSpaces > PrevSpaces then
  468. begin
  469. { Dive down one level }
  470. ParentStack[StackIndex] := CurParent;
  471. SiblingStack[StackIndex] := PrevSibling;
  472. Inc(StackIndex);
  473. CurParent := PrevSibling;
  474. PrevSibling := nil;
  475. end else
  476. while PrevSpaces > ThisSpaces do
  477. begin
  478. Dec(StackIndex);
  479. CurParent := ParentStack[StackIndex];
  480. PrevSibling := SiblingStack[StackIndex];
  481. Dec(PrevSpaces);
  482. end;
  483. PrevSpaces := ThisSpaces;
  484. end;
  485. i := ThisSpaces + 1;
  486. while s[i] <> ' ' do
  487. Inc(i);
  488. if ALinkPrefix <> '' then
  489. tmpLinkPrefix := ExcludeTrailingPathDelimiter(ALinkPrefix)+'/';
  490. NewNode := TLinkNode.Create(Copy(s, ThisSpaces + 1, i - ThisSpaces - 1),
  491. tmpLinkPrefix + Copy(s, i + 1, Length(s)));
  492. if pos(' ',newnode.link)>0 then
  493. writeln(stderr,'Bad format imported node: name="',newnode.name,'" link="',newnode.link,'"');
  494. if Assigned(PrevSibling) then
  495. PrevSibling.FNextSibling := NewNode
  496. else
  497. CurParent.FFirstChild := NewNode;
  498. PrevSibling := NewNode;
  499. end;
  500. end;
  501. function ResolvePackageModule(AName:String;out pkg:TPasPackage;out module:TPasModule;createnew:boolean):String;
  502. var
  503. DotPos, DotPos2, i: Integer;
  504. s: String;
  505. HPackage: TPasPackage;
  506. begin
  507. pkg:=nil; module:=nil; result:='';
  508. // Find or create package
  509. DotPos := Pos('.', AName);
  510. s := Copy(AName, 1, DotPos - 1);
  511. HPackage := nil;
  512. for i := 0 to FPackages.Count - 1 do
  513. if CompareText(TPasPackage(FPackages[i]).Name, s) = 0 then
  514. begin
  515. HPackage := TPasPackage(FPackages[i]);
  516. break;
  517. end;
  518. if not Assigned(HPackage) then
  519. begin
  520. if not CreateNew then
  521. exit;
  522. HPackage := TPasPackage(inherited CreateElement(TPasPackage, s, nil,
  523. '', 0));
  524. FPackages.Add(HPackage);
  525. end;
  526. // Find or create module
  527. DotPos2 := DotPos;
  528. repeat
  529. Inc(DotPos2);
  530. until AName[DotPos2] = '.';
  531. s := Copy(AName, DotPos + 1, DotPos2 - DotPos - 1);
  532. Module := nil;
  533. for i := 0 to HPackage.Modules.Count - 1 do
  534. if CompareText(TPasModule(HPackage.Modules[i]).Name, s) = 0 then
  535. begin
  536. Module := TPasModule(HPackage.Modules[i]);
  537. break;
  538. end;
  539. if not Assigned(Module) then
  540. begin
  541. if not CreateNew then
  542. exit;
  543. Module := TPasExternalModule.Create(s, HPackage);
  544. Module.InterfaceSection := TInterfaceSection.Create('', Module);
  545. Module.PackageName:= HPackage.Name;
  546. // Module.AddRef{$IFDEF CheckPasTreeRefCount}('ReadContentFile.ResolvePackageModule'){$ENDIF};
  547. HPackage.Modules.Add(Module);
  548. end;
  549. pkg:=hpackage;
  550. result:=Copy(AName, DotPos2 + 1, length(AName)-dotpos2);
  551. end;
  552. function SearchInList(clslist:TFPList;s:string):TPasElement;
  553. var i : integer;
  554. ClassEl: TPasElement;
  555. begin
  556. result:=nil;
  557. for i:=0 to clslist.count-1 do
  558. begin
  559. ClassEl := TPasElement(clslist[i]);
  560. if CompareText(ClassEl.Name,s) =0 then
  561. exit(Classel);
  562. end;
  563. end;
  564. function ResolveClassType(AName:String):TPasClassType;
  565. var
  566. pkg : TPasPackage;
  567. module : TPasModule;
  568. s : string;
  569. begin
  570. Result:=nil;
  571. s:=ResolvePackageModule(AName,pkg,module,False);
  572. if not assigned(module) then
  573. exit;
  574. result:=TPasClassType(SearchInList(Module.InterfaceSection.Classes,s));
  575. end;
  576. function ResolveAliasType(AName:String):TPasAliasType;
  577. var
  578. pkg : TPasPackage;
  579. module : TPasModule;
  580. s : string;
  581. begin
  582. Result:=nil;
  583. s:=ResolvePackageModule(AName,pkg,module,False);
  584. if not assigned(module) then
  585. exit;
  586. result:=TPasAliasType(SearchInList(Module.InterfaceSection.Types,s));
  587. if not (result is TPasAliasType) then
  588. result:=nil;
  589. end;
  590. procedure ReadClasses;
  591. function CreateClass(const AName: String;InheritanceStr:String): TPasClassType;
  592. var
  593. s: String;
  594. HPackage: TPasPackage;
  595. Module: TPasModule;
  596. begin
  597. s:= ResolvePackageModule(AName,HPackage,Module,True);
  598. // Create node for class
  599. Result := TPasExternalClassType.Create(s, Module.InterfaceSection);
  600. Result.ObjKind := okClass;
  601. // Result.AddRef{$IFDEF CheckPasTreeRefCount}('ReadContentFile.ResolveAndLinkClass'){$ENDIF};
  602. Module.InterfaceSection.Declarations.Add(Result);
  603. Module.InterfaceSection.Classes.Add(Result);
  604. // defer processing inheritancestr till all classes are loaded.
  605. if inheritancestr<>'' then
  606. InheritanceInfo.AddObject(Inheritancestr,result);
  607. end;
  608. procedure splitalias(var instr:string;out outstr:string);
  609. var i,j:integer;
  610. begin
  611. if length(instr)=0 then exit;
  612. instr:=trim(instr);
  613. i:=pos('(',instr);
  614. if i>0 then
  615. begin
  616. j:=length(instr)-i;
  617. if instr[length(instr)]=')' then
  618. dec(j);
  619. outstr:=copy(instr,i+1,j);
  620. delete(instr,i,j+2);
  621. end
  622. end;
  623. Function ResolveAndLinkClass(clname:String;IsClass:boolean;cls:TPasClassType):TPasClassType;
  624. begin
  625. result:=TPasClassType(ResolveClassType(clname));
  626. if assigned(result) and not (cls=result) then // save from tobject=implicit tobject
  627. begin
  628. result.addref{$IFDEF CheckPasTreeRefCount}('ReadContentFile.ResolveAndLinkClass'){$ENDIF};
  629. if IsClass then
  630. begin
  631. cls.ancestortype:=result;
  632. // writeln(cls.name, ' has as ancestor ',result.pathname);
  633. end
  634. else
  635. begin
  636. cls.interfaces.add(result);
  637. // writeln(cls.name, ' implements ',result.pathname);
  638. end;
  639. end
  640. else
  641. if (dleXCT in FDocLogLevels) and (cls<>result) then
  642. DoLog('Warning : ancestor class %s of class %s could not be resolved',[clname,cls.name]);
  643. end;
  644. function CreateAliasType (alname,clname : string;parentclass:TPasClassType; out cl2 :TPasClassType):TPasAliasType;
  645. // create alias clname = alname
  646. var
  647. pkg : TPasPackage;
  648. module : TPasModule;
  649. s : string;
  650. begin
  651. Result:=nil;
  652. s:=ResolvePackageModule(Alname,pkg,module,True);
  653. if not assigned(module) then
  654. exit;
  655. cl2:=TPasClassType(ResolveClassType(alname));
  656. if assigned( cl2) and not (parentclass=cl2) then
  657. begin
  658. result:=ResolveAliasType(clname);
  659. if assigned(result) then
  660. begin
  661. // writeln('found alias ',clname,' (',s,') ',result.classname);
  662. end
  663. else
  664. begin
  665. // writeln('new alias ',clname,' (',s,') ');
  666. cl2.addref{$IFDEF CheckPasTreeRefCount}('ReadContentFile.CreateAliasType'){$ENDIF};
  667. Result := TPasAliasType(CreateElement(TPasAliasType,s,module.interfacesection,vispublic,'',0));
  668. module.interfacesection.Declarations.Add(Result);
  669. TPasAliasType(Result).DestType := cl2;
  670. end
  671. end
  672. end;
  673. procedure ProcessInheritanceStrings(inhInfo:TStringList);
  674. var i,j : integer;
  675. cls : TPasClassType;
  676. cls2: TPasClassType;
  677. clname,
  678. alname : string;
  679. inhclass : TStringList;
  680. begin
  681. inhclass:=TStringList.Create;
  682. inhclass.delimiter:=',';
  683. if InhInfo.Count>0 then
  684. for i:=0 to InhInfo.Count-1 do
  685. begin
  686. cls:=TPasClassType(InhInfo.Objects[i]);
  687. inhclass.clear;
  688. inhclass.delimitedtext:=InhInfo[i];
  689. for j:= 0 to inhclass.count-1 do
  690. begin
  691. // writeln('processing',inhclass[j]);
  692. clname:=inhclass[j];
  693. splitalias(clname,alname);
  694. if alname<>'' then // the class//interface we refered to is an alias
  695. begin
  696. // writeln('Found alias pair ',clname,' = ',alname);
  697. if (dleXCT in FDocLogLevels) and not assigned(CreateAliasType(alname,clname,cls,cls2)) then
  698. DoLog('Warning: creating alias %s for %s failed!',[alname,clname]);
  699. end
  700. else
  701. cls2:=ResolveAndLinkClass(clname,j=0,cls);
  702. end;
  703. end;
  704. inhclass.free;
  705. end;
  706. var
  707. s, Name: String;
  708. CurClass: TPasClassType;
  709. i: Integer;
  710. Member: TPasElement;
  711. begin
  712. inheritanceinfo :=TStringlist.Create;
  713. Try
  714. CurClass := nil;
  715. while True do
  716. begin
  717. ReadLn(f, s);
  718. if Length(s) = 0 then
  719. break;
  720. if s[1] = '#' then
  721. begin
  722. // New class
  723. i := Pos(' ', s);
  724. CurClass := CreateClass(Copy(s, 1, i - 1), copy(s,i+1,length(s)));
  725. end else
  726. begin
  727. i := Pos(' ', s);
  728. if i = 0 then
  729. Name := Copy(s, 3, Length(s))
  730. else
  731. Name := Copy(s, 3, i - 3);
  732. case s[2] of
  733. 'M':
  734. Member := TPasProcedure.Create(Name, CurClass);
  735. 'P':
  736. begin
  737. Member := TPasProperty.Create(Name, CurClass);
  738. if i > 0 then
  739. while i <= Length(s) do
  740. begin
  741. case s[i] of
  742. 'r':
  743. TPasProperty(Member).ReadAccessorName := '<dummy>';
  744. 'w':
  745. TPasProperty(Member).WriteAccessorName := '<dummy>';
  746. 's':
  747. TPasProperty(Member).StoredAccessorName := '<dummy>';
  748. end;
  749. Inc(i);
  750. end;
  751. end;
  752. 'V':
  753. Member := TPasVariable.Create(Name, CurClass);
  754. else
  755. raise Exception.Create('Invalid member type: ' + s[2]);
  756. end;
  757. CurClass.Members.Add(Member);
  758. end;
  759. end;
  760. ProcessInheritanceStrings(Inheritanceinfo);
  761. finally
  762. inheritanceinfo.Free;
  763. end;
  764. end;
  765. var
  766. s: String;
  767. buf : TBufType;
  768. begin
  769. buf:=Default(TBufType);
  770. if not FileExists(AFileName) then
  771. raise EInOutError.Create('File not found: ' + AFileName);
  772. Assign(f, AFilename);
  773. Reset(f);
  774. SetTextBuf(F,Buf,SizeOf(Buf));
  775. while not EOF(f) do
  776. begin
  777. ReadLn(f, s);
  778. if (Length(s) = 0) or (s[1] = '#') then
  779. continue;
  780. if s = ':link tree' then
  781. ReadLinkTree
  782. else if s = ':classes' then
  783. ReadClasses
  784. else
  785. repeat
  786. ReadLn(f, s);
  787. until EOF(f) or (Length(s) = 0);
  788. end;
  789. Close(f);
  790. end;
  791. procedure TFPDocEngine.WriteContentFile(const AFilename: String);
  792. var
  793. ContentFile: Text;
  794. procedure ProcessLinkNode(ALinkNode: TLinkNode; const AIdent: String);
  795. var
  796. ChildNode: TLinkNode;
  797. begin
  798. WriteLn(ContentFile, AIdent, ALinkNode.Name, ' ', ALinkNode.Link);
  799. ChildNode := ALinkNode.FirstChild;
  800. while Assigned(ChildNode) do
  801. begin
  802. ProcessLinkNode(ChildNode, AIdent + ' ');
  803. ChildNode := ChildNode.NextSibling;
  804. end;
  805. end;
  806. function CheckImplicitLink(const s : String):String;
  807. begin
  808. if uppercase(s)='IUNKNOWN' then
  809. Result:='#rtl.System.IUnknown'
  810. else if uppercase(s)='TOBJECT' then
  811. Result:='#rtl.System.TObject'
  812. else
  813. Result:=s;
  814. end;
  815. var
  816. LinkNode: TLinkNode;
  817. i, j, k: Integer;
  818. Module: TPasModule;
  819. Alias : TPasAliasType;
  820. MemberDecl: TPasMembersType;
  821. ClassLikeDecl : TPasClassType;
  822. Member: TPasElement;
  823. s: String;
  824. Buf : TBufType;
  825. begin
  826. Buf:=Default(TBufType);
  827. Assign(ContentFile, AFilename);
  828. Rewrite(ContentFile);
  829. SetTextBuf(ContentFile,Buf,SizeOf(Buf));
  830. try
  831. WriteLn(ContentFile, '# FPDoc Content File');
  832. WriteLn(ContentFile, ':link tree');
  833. LinkNode := RootLinkNode.FirstChild;
  834. while Assigned(LinkNode) do
  835. begin
  836. if LinkNode.Name = Package.Name then
  837. begin
  838. ProcessLinkNode(LinkNode, '');
  839. end;
  840. LinkNode := LinkNode.NextSibling;
  841. end;
  842. if Assigned(Package) then
  843. begin
  844. WriteLn(ContentFile);
  845. WriteLn(ContentFile, ':classes');
  846. for i := 0 to Package.Modules.Count - 1 do
  847. begin
  848. Module := TPasModule(Package.Modules[i]);
  849. if not assigned(Module.InterfaceSection) then
  850. continue;
  851. for j := 0 to Module.InterfaceSection.Classes.Count - 1 do
  852. begin
  853. MemberDecl := TPasClassType(Module.InterfaceSection.Classes[j]);
  854. if MemberDecl is TPasClassType then
  855. ClassLikeDecl:=MemberDecl as TPasClassType
  856. else
  857. ClassLikeDecl:=nil;
  858. Write(ContentFile, CheckImplicitLink(MemberDecl.PathName), ' ');
  859. if Assigned(ClassLikeDecl) then
  860. begin
  861. if Assigned(ClassLikeDecl.AncestorType) then
  862. begin
  863. // simple aliases to class types are coded as "alias(classtype)"
  864. Write(ContentFile, CheckImplicitLink(ClassLikeDecl.AncestorType.PathName));
  865. if ClassLikeDecl.AncestorType is TPasAliasType then
  866. begin
  867. alias:= TPasAliasType(ClassLikeDecl.AncestorType);
  868. if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
  869. write(ContentFile,'(',alias.desttype.PathName,')');
  870. end;
  871. end
  872. else if ClassLikeDecl.ObjKind = okClass then
  873. Write(ContentFile, '#rtl.System.TObject')
  874. else if ClassLikeDecl.ObjKind = okInterface then
  875. Write(ContentFile, '#rtl.System.IUnknown');
  876. if ClassLikeDecl.Interfaces.Count>0 then
  877. begin
  878. for k:=0 to ClassLikeDecl.Interfaces.count-1 do
  879. begin
  880. write(contentfile,',',CheckImplicitLink(TPasType(ClassLikeDecl.Interfaces[k]).PathName));
  881. if TPasElement(ClassLikeDecl.Interfaces[k]) is TPasAliasType then
  882. begin
  883. alias:= TPasAliasType(ClassLikeDecl.Interfaces[k]);
  884. if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
  885. write(ContentFile,'(',CheckImplicitLink(alias.desttype.PathName),')');
  886. end;
  887. end;
  888. end;
  889. end;
  890. writeln(contentfile);
  891. for k := 0 to MemberDecl.Members.Count - 1 do
  892. begin
  893. Member := TPasElement(MemberDecl.Members[k]);
  894. Write(ContentFile, Chr(Ord(Member.Visibility) + Ord('0')));
  895. S:='';
  896. if Member.ClassType = TPasVariable then
  897. Write(ContentFile, 'V')
  898. else if Member.ClassType = TPasProperty then
  899. begin
  900. Write(ContentFile, 'P');
  901. if Length(TPasProperty(Member).ReadAccessorName) > 0 then
  902. s := s + 'r';
  903. if Length(TPasProperty(Member).WriteAccessorName) > 0 then
  904. s := s + 'w';
  905. if Length(TPasProperty(Member).StoredAccessorName) > 0 then
  906. s := s + 's';
  907. end else
  908. Write(ContentFile, 'M'); // Member must be a method
  909. Write(ContentFile, Member.Name);
  910. if Length(s) > 0 then
  911. WriteLn(ContentFile, ' ', s)
  912. else
  913. WriteLn(ContentFile);
  914. end;
  915. end;
  916. end;
  917. end;
  918. finally
  919. Close(ContentFile);
  920. end;
  921. end;
  922. function TFPDocEngine.CreateElement(AClass: TPTreeElement; const AName: String;
  923. AParent: TPasElement; AVisibility: TPasMemberVisibility;
  924. const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
  925. begin
  926. Result := AClass.Create(AName, AParent);
  927. Result.Visibility := AVisibility;
  928. if AClass.InheritsFrom(TPasModule) then
  929. CurModule := TPasModule(Result);
  930. Result.SourceFilename := ASourceFilename;
  931. Result.SourceLinenumber := ASourceLinenumber;
  932. end;
  933. function TFPDocEngine.FindElement ( const AName: String; AModule: TPasModule
  934. ) : TPasElement;
  935. var
  936. l: TFPList;
  937. i: Integer;
  938. begin
  939. If Assigned(AModule) and Assigned(AModule.InterfaceSection) and
  940. Assigned(AModule.InterfaceSection.Declarations) then
  941. begin
  942. l:=AModule.InterfaceSection.Declarations;
  943. for i := 0 to l.Count - 1 do
  944. begin
  945. Result := TPasElement(l[i]);
  946. if CompareText(Result.Name, AName) = 0 then
  947. exit;
  948. end;
  949. end;
  950. Result := nil;
  951. end;
  952. function TFPDocEngine.FindElement(const AName: String): TPasElement;
  953. var
  954. i: Integer;
  955. Module: TPasElement;
  956. begin
  957. Result := FindElement( AName, CurModule );
  958. if not Assigned(Result) and assigned (CurModule.InterfaceSection) then
  959. for i := CurModule.InterfaceSection.UsesList.Count - 1 downto 0 do
  960. begin
  961. Module := TPasElement(CurModule.InterfaceSection.UsesList[i]);
  962. if Module.ClassType.InheritsFrom(TPasModule) then
  963. begin
  964. Result := FindElement(AName, TPasModule(Module));
  965. if Assigned(Result) then
  966. exit;
  967. end;
  968. end;
  969. end;
  970. function TFPDocEngine.FindModule(const AName: String): TPasModule;
  971. function FindInPackage(APackage: TPasPackage): TPasModule;
  972. var
  973. i: Integer;
  974. begin
  975. if not Assigned(APackage) then Exit;
  976. for i := 0 to APackage.Modules.Count - 1 do
  977. begin
  978. Result := TPasModule(APackage.Modules[i]);
  979. if CompareText(Result.Name, AName) = 0 then
  980. exit;
  981. end;
  982. Result := nil;
  983. end;
  984. var
  985. i: Integer;
  986. AInPutLine,OSTarget,CPUTarget : String;
  987. begin
  988. Result := FindInPackage(Package);
  989. if not Assigned(Result) and (FPackages.Count > 0) then
  990. for i := FPackages.Count - 1 downto 0 do
  991. begin
  992. if TPasPackage(FPackages[i]) = Package then
  993. continue;
  994. Result := FindInPackage(TPasPackage(FPackages[i]));
  995. if Assigned(Result) then
  996. exit;
  997. end;
  998. if Not Assigned(Result) and Assigned(FOnParseUnit) then
  999. begin
  1000. FOnParseUnit(Self,AName,AInputLine,OSTarget,CPUTarget);
  1001. If (AInPutLine<>'') then
  1002. Result:=ParseUsedUnit(AName,AInputLine,OSTarget,CPUTarget);
  1003. end;
  1004. end;
  1005. function TFPDocEngine.HintsToStr(Hints: TPasMemberHints): String;
  1006. Var
  1007. H : TPasMemberHint;
  1008. begin
  1009. Result:='';
  1010. For h:=Low(TPasMemberHint) to High(TPasMemberHint) do
  1011. if h in Hints then
  1012. begin
  1013. if (Result<>'') then
  1014. Result:=Result+', ';
  1015. Result:=Result+cPasMemberHint[h]
  1016. end;
  1017. end;
  1018. function TFPDocEngine.ParseUsedUnit(AName, AInputLine, AOSTarget,
  1019. ACPUTarget: String): TPasModule;
  1020. Var
  1021. M : TPasModule;
  1022. begin
  1023. if dleWarnUsedFile in FDocLogLevels then
  1024. DoLog(SParsingUsedUnit,[AName,AInputLine]);
  1025. M:=CurModule;
  1026. CurModule:=Nil;
  1027. try
  1028. ParseSource(Self,AInputLine,AOSTarget,ACPUTarget,[poUseStreams]); //[poSkipDefaultDefs];
  1029. Result:=CurModule;
  1030. finally
  1031. CurModule:=M;
  1032. end;
  1033. end;
  1034. procedure TFPDocEngine.AddLink(const APathName, ALinkTo: String);
  1035. begin
  1036. RootLinkNode.CreateChildren(APathName, ALinkTo);
  1037. end;
  1038. function TFPDocEngine.FindAbsoluteLink(const AName: String): String;
  1039. var
  1040. LinkNode: TLinkNode;
  1041. begin
  1042. LinkNode := RootLinkNode.FindChild(AName);
  1043. if Assigned(LinkNode) then
  1044. Result := LinkNode.Link
  1045. else
  1046. SetLength(Result, 0);
  1047. end;
  1048. function TFPDocEngine.ResolveLinkInPackages(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
  1049. Var
  1050. ThisPackage: TLinkNode;
  1051. begin
  1052. { Try all packages }
  1053. Result:='';
  1054. ThisPackage:=RootLinkNode.FirstChild;
  1055. while Assigned(ThisPackage) and (Result='') do
  1056. begin
  1057. Result:=ResolveLink(AModule, ThisPackage.Name + '.' + ALinkDest, Strict);
  1058. ThisPackage := ThisPackage.NextSibling;
  1059. end;
  1060. end;
  1061. function TFPDocEngine.ResolveLinkInUsedUnits(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
  1062. var
  1063. i: Integer;
  1064. UL: TFPList;
  1065. begin
  1066. Result:='';
  1067. UL:=AModule.InterfaceSection.UsesList;
  1068. I:=UL.Count-1;
  1069. While (Result='') and (I>=0) do
  1070. begin
  1071. Result:=ResolveLinkInPackages(AModule,TPasType(UL[i]).Name+'.'+ALinkDest, strict);
  1072. Dec(I);
  1073. end;
  1074. end;
  1075. function TFPDocEngine.ResolveLink(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
  1076. var
  1077. i: Integer;
  1078. begin
  1079. {
  1080. if Assigned(AModule) then
  1081. system.WriteLn('ResolveLink(', AModule.Name, ' - ', ALinkDest, ')... ')
  1082. else
  1083. system.WriteLn('ResolveLink(Nil - ', ALinkDest, ')... ');
  1084. }
  1085. if (ALinkDest='') then
  1086. Exit('');
  1087. if (ALinkDest[1] = '#') then
  1088. // Link has full path
  1089. Result := FindAbsoluteLink(ALinkDest)
  1090. else if (AModule=Nil) then
  1091. // Trying to add package name only
  1092. Result:= FindAbsoluteLink(RootLinkNode.FirstChild.Name+'.'+ALinkDest)
  1093. else
  1094. begin
  1095. if Pos(LowerCase(AModule.Name)+'.',LowerCase(ALinkDest)) = 1 then
  1096. // fix ERROR - Link starts from name of module
  1097. Result := ResolveLink(AModule, AModule.packagename + '.' + ALinkDest, Strict)
  1098. else
  1099. // Link should be a first level inside of module
  1100. Result := ResolveLink(AModule, AModule.PathName + '.' + ALinkDest, Strict);
  1101. if (Result='') then
  1102. begin
  1103. Result:=ResolveLinkInPackages(AModule,ALinkDest,Strict);
  1104. if (Result='') then
  1105. Result:=ResolveLinkInUsedUnits(Amodule,AlinkDest,Strict);
  1106. end;
  1107. end;
  1108. // Match on parent : class/enumerated/record/module
  1109. if (Result='') and not strict then
  1110. begin
  1111. // TODO: I didn't see a calling this code at entire lcl package
  1112. // Writeln('INFO UnStrinct(): ' + ALinkDest);
  1113. for i := Length(ALinkDest) downto 1 do
  1114. if ALinkDest[i] = '.' then
  1115. begin
  1116. Result := ResolveLink(AModule, Copy(ALinkDest, 1, i - 1), Strict);
  1117. //if Result <> '' then Writeln('INFO LinkResolved UnStrinct(): '+Result);
  1118. exit;
  1119. end;
  1120. end;
  1121. end;
  1122. procedure ReadXMLFileALT(OUT ADoc:TXMLDocument;const AFileName:ansistring);
  1123. var
  1124. Parser: TDOMParser;
  1125. Src: TXMLInputSource;
  1126. FileStream: TStream;
  1127. begin
  1128. ADoc := nil;
  1129. FileStream := TFileStream.Create(AFilename, fmOpenRead+fmShareDenyWrite);
  1130. try
  1131. Parser := TDOMParser.Create; // create a parser object
  1132. try
  1133. Src := TXMLInputSource.Create(FileStream); // and the input source
  1134. src.SystemId:=UTF8Decode(FileNameToUri(AFileName));
  1135. try
  1136. Parser.Options.PreserveWhitespace := True;
  1137. Parser.Parse(Src, ADoc);
  1138. finally
  1139. Src.Free; // cleanup
  1140. end;
  1141. finally
  1142. Parser.Free;
  1143. end;
  1144. finally
  1145. FileStream.Free;
  1146. end;
  1147. end;
  1148. procedure TFPDocEngine.AddDocFile(const AFilename: String;DontTrim:boolean=false);
  1149. Var
  1150. PN : String;
  1151. function ReadNode(OwnerDocNode: TDocNode; Element: TDOMElement): TDocNode;
  1152. var
  1153. Subnode: TDOMNode;
  1154. begin
  1155. if OwnerDocNode = RootDocNode then
  1156. Result := OwnerDocNode.CreateChildren('#' + UTF8Encode(Element['name']))
  1157. else
  1158. Result := OwnerDocNode.CreateChildren(UTF8Encode(Element['name']));
  1159. Result.FNode := Element;
  1160. Result.FLink := UTF8Encode(Element['link']);
  1161. if (Element['alwaysvisible'] = '1') and (Element.NodeName='element') then
  1162. FAlwaysVisible.Add(LowerCase(PN+'.'+TDocNode(OwnerDocNode).Name+'.'+UTF8Encode(Element['name'])));
  1163. Result.FIsSkipped := Element['skip'] = '1';
  1164. Subnode := Element.FirstChild;
  1165. while Assigned(Subnode) do
  1166. begin
  1167. if Subnode.NodeType = ELEMENT_NODE then
  1168. begin
  1169. if Subnode.NodeName = 'short' then
  1170. Result.FShortDescr := TDOMElement(Subnode)
  1171. else if Subnode.NodeName = 'descr' then
  1172. Result.FDescr := TDOMElement(Subnode)
  1173. else if Subnode.NodeName = 'version' then
  1174. begin
  1175. Result.FVersion := TDOMElement(Subnode)
  1176. end
  1177. else if Subnode.NodeName = 'errors' then
  1178. Result.FErrorsDoc := TDOMElement(Subnode)
  1179. else if Subnode.NodeName = 'seealso' then
  1180. Result.FSeeAlso := TDOMElement(Subnode)
  1181. else if (Subnode.NodeName = 'example') and
  1182. not Assigned(Result.FirstExample) then
  1183. Result.FFirstExample := TDOMElement(Subnode)
  1184. else if (Subnode.NodeName = 'notes') then
  1185. Result.FNotes := TDOMElement(Subnode);
  1186. end;
  1187. Subnode := Subnode.NextSibling;
  1188. end;
  1189. end;
  1190. Procedure ReadTopics(TopicNode : TDocNode);
  1191. Var
  1192. SubNode : TDOMNode;
  1193. begin
  1194. SubNode:=TopicNode.FNode.FirstChilD;
  1195. While Assigned(SubNode) do
  1196. begin
  1197. If (SubNode.NodeType=ELEMENT_NODE) and (SubNode.NodeName='topic') then
  1198. With ReadNode(TopicNode,TDomElement(SubNode)) do
  1199. // We could allow recursion here, but we won't, because it doesn't work on paper.
  1200. FTopicNode:=True;
  1201. SubNode:=Subnode.NextSibling;
  1202. end;
  1203. end;
  1204. var
  1205. Node, Subnode, Subsubnode: TDOMNode;
  1206. Doc: TXMLDocument;
  1207. PackageDocNode, TopicNode,ModuleDocNode: TDocNode;
  1208. begin
  1209. if DontTrim then
  1210. ReadXMLFileALT(Doc, AFilename)
  1211. else
  1212. ReadXMLFile(Doc, AFilename);
  1213. DescrDocs.Add(Doc);
  1214. DescrDocNames.Add(AFilename);
  1215. Node := Doc.DocumentElement.FirstChild;
  1216. while Assigned(Node) do
  1217. begin
  1218. if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'package') then
  1219. begin
  1220. PackageDocNode := ReadNode(RootDocNode, TDOMElement(Node));
  1221. PackageDocNode.IncRefCount;
  1222. PN:=PackageDocNode.Name;
  1223. // Scan all 'module' elements within this package element
  1224. Subnode := Node.FirstChild;
  1225. while Assigned(Subnode) do
  1226. begin
  1227. if (Subnode.NodeType = ELEMENT_NODE) then
  1228. begin
  1229. If (Subnode.NodeName = 'module') then
  1230. begin
  1231. ModuleDocNode := ReadNode(PackageDocNode, TDOMElement(Subnode));
  1232. // Scan all 'element' elements within this module element
  1233. Subsubnode := Subnode.FirstChild;
  1234. while Assigned(Subsubnode) do
  1235. begin
  1236. if (Subsubnode.NodeType = ELEMENT_NODE) then
  1237. begin
  1238. if (Subsubnode.NodeName = 'element') then
  1239. ReadNode(ModuleDocNode, TDOMElement(Subsubnode))
  1240. else if (SubSubNode.NodeName='topic') then
  1241. begin
  1242. TopicNode:=ReadNode(ModuleDocNode,TDomElement(SubSubNode));
  1243. TopicNode.FTopicNode:=True;
  1244. ReadTopics(TopicNode);
  1245. end;
  1246. end;
  1247. Subsubnode := Subsubnode.NextSibling;
  1248. end;
  1249. end
  1250. else if (SubNode.NodeName='topic') then
  1251. begin
  1252. TopicNode:=ReadNode(PackageDocNode,TDomElement(SubNode));
  1253. TopicNode.FTopicNode:=True;
  1254. ReadTopics(TopicNode);
  1255. end;
  1256. end;
  1257. Subnode := Subnode.NextSibling;
  1258. end;
  1259. end;
  1260. Node := Node.NextSibling;
  1261. end;
  1262. end;
  1263. function TFPDocEngine.FindDocNode(AElement: TPasElement): TDocNode;
  1264. begin
  1265. Result:=Nil;
  1266. If not Assigned(AElement) then
  1267. exit;
  1268. if aElement.CustomData is TDocNode then
  1269. Exit(TDocNode(aElement.CustomData));
  1270. if AElement.InheritsFrom(TPasUnresolvedTypeRef) then
  1271. Result := FindDocNode(AElement.GetModule, AElement.Name)
  1272. else
  1273. begin
  1274. Result := RootDocNode.FindChild(AElement.PathName);
  1275. if (Result=Nil) and (AElement is TPasoperator) then
  1276. Result:=RootDocNode.FindChild(TPasOperator(AElement).OldName(True));
  1277. end;
  1278. if (Result<>Nil) then
  1279. begin
  1280. if aElement.CustomData=Nil then
  1281. aElement.CustomData:=Result;
  1282. end
  1283. else if (dleWarnNoNode in FDocLogLevels) and
  1284. (Length(AElement.PathName)>0) and
  1285. (AElement.PathName[1]='#') then
  1286. DoLog(Format('No documentation node found for identifier : %s',[AElement.PathName]));
  1287. end;
  1288. function TFPDocEngine.FindDocNode(ARefModule: TPasModule;
  1289. const AName: String): TDocNode;
  1290. var
  1291. CurPackage: TDocNode;
  1292. UnitList: TFPList;
  1293. i: Integer;
  1294. begin
  1295. if Length(AName) = 0 then
  1296. Result := nil
  1297. else
  1298. begin
  1299. if AName[1] = '#' then
  1300. Result := RootDocNode.FindChild(AName)
  1301. else
  1302. Result := RootDocNode.FindChild(Package.Name + '.' + AName);
  1303. if (not Assigned(Result)) and Assigned(ARefModule) then
  1304. Result := RootDocNode.FindChild(ARefModule.PathName + '.' + AName);
  1305. if (not Assigned(Result)) and (AName[1] <> '#') then
  1306. begin
  1307. CurPackage := RootDocNode.FirstChild;
  1308. while Assigned(CurPackage) do
  1309. begin
  1310. Result := RootDocNode.FindChild(CurPackage.Name + '.' + AName);
  1311. if Assigned(Result) then
  1312. break;
  1313. CurPackage := CurPackage.NextSibling;
  1314. end;
  1315. if not Assigned(Result) and assigned(CurModule.InterfaceSection) then
  1316. begin
  1317. { Okay, then we have to try all imported units of the current module }
  1318. UnitList := CurModule.InterfaceSection.UsesList;
  1319. for i := UnitList.Count - 1 downto 0 do
  1320. begin
  1321. { Try all packages }
  1322. CurPackage := RootDocNode.FirstChild;
  1323. while Assigned(CurPackage) do
  1324. begin
  1325. Result := RootDocNode.FindChild(CurPackage.Name + '.' +
  1326. TPasType(UnitList[i]).Name + '.' + AName);
  1327. if Assigned(Result) then
  1328. break;
  1329. CurPackage := CurPackage.NextSibling;
  1330. end;
  1331. end;
  1332. end;
  1333. end;
  1334. end;
  1335. end;
  1336. function TFPDocEngine.FindShortDescr(AElement: TPasElement): TDOMElement;
  1337. var
  1338. DocNode,N: TDocNode;
  1339. begin
  1340. DocNode := FindDocNode(AElement);
  1341. if Assigned(DocNode) then
  1342. begin
  1343. N:=FindLinkedNode(DocNode);
  1344. If (N<>Nil) then
  1345. DocNode:=N;
  1346. Result := DocNode.ShortDescr;
  1347. end
  1348. else
  1349. Result := nil;
  1350. end;
  1351. function TFPDocEngine.FindLinkedNode(ANode : TDocNode) : TDocNode;
  1352. begin
  1353. If (ANode.Link='') then
  1354. Result:=Nil
  1355. else
  1356. Result:=FindDocNode(CurModule,ANode.Link);
  1357. end;
  1358. function TFPDocEngine.ShowElement(El: TPasElement): Boolean;
  1359. begin
  1360. Case El.Visibility of
  1361. visStrictPrivate,
  1362. visPrivate :
  1363. Result:=Not HidePrivate;
  1364. visStrictProtected,
  1365. visProtected :
  1366. begin
  1367. Result:=Not HideProtected;
  1368. if not Result then
  1369. Result:=FAlwaysVisible.IndexOf(LowerCase(El.PathName))<>-1;
  1370. end
  1371. Else
  1372. Result:=True
  1373. end;
  1374. end;
  1375. procedure TFPDocEngine.StartDocumenting;
  1376. begin
  1377. FAlwaysVisible.Sorted:=True;
  1378. end;
  1379. function TFPDocEngine.FindShortDescr(ARefModule: TPasModule;
  1380. const AName: String): TDOMElement;
  1381. var
  1382. N,DocNode: TDocNode;
  1383. begin
  1384. DocNode := FindDocNode(ARefModule, AName);
  1385. if Assigned(DocNode) then
  1386. begin
  1387. N:=FindLinkedNode(DocNode);
  1388. If (N<>Nil) then
  1389. DocNode:=N;
  1390. Result := DocNode.ShortDescr;
  1391. end
  1392. else
  1393. Result := nil;
  1394. end;
  1395. function TFPDocEngine.GetExampleFilename(const ExElement: TDOMElement): String;
  1396. var
  1397. i: Integer;
  1398. fn : String;
  1399. begin
  1400. Result:='';
  1401. for i := 0 to DescrDocs.Count - 1 do
  1402. begin
  1403. Fn:=UTF8Encode(ExElement['file']);
  1404. if (FN<>'') and (TDOMDocument(DescrDocs[i]) = ExElement.OwnerDocument) then
  1405. begin
  1406. Result := ExtractFilePath(DescrDocNames[i]) + FN;
  1407. if (ExtractFileExt(Result)='') then
  1408. Result:=Result+'.pp';
  1409. end;
  1410. end;
  1411. end;
  1412. { Global helpers }
  1413. procedure TranslateDocStrings(const Lang: String);
  1414. Const
  1415. {$ifdef unix}
  1416. DefDir = '/usr/local/share/locale';
  1417. {$else}
  1418. DefDir = 'intl';
  1419. {$endif}
  1420. var
  1421. mo: TMOFile;
  1422. dir : string;
  1423. begin
  1424. dir:=modir;
  1425. If Dir='' then
  1426. Dir:=DefDir;
  1427. Dir:=IncludeTrailingPathDelimiter(Dir);
  1428. {$IFDEF Unix}
  1429. mo := TMOFile.Create(Format(Dir+'%s/LC_MESSAGES/dglobals.mo', [Lang]));
  1430. {$ELSE}
  1431. mo := TMOFile.Create(Format(Dir+'dglobals.%s.mo', [Lang]));
  1432. {$ENDIF}
  1433. try
  1434. TranslateResourceStrings(mo);
  1435. finally
  1436. mo.Free;
  1437. end;
  1438. end;
  1439. Function IsLinkNode(Node : TDomNode) : Boolean;
  1440. begin
  1441. Result:=Assigned(Node) and (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'link');
  1442. end;
  1443. Function IsExampleNode(Example : TDomNode) : Boolean;
  1444. begin
  1445. Result:=Assigned(Example) and (Example.NodeType = ELEMENT_NODE) and (Example.NodeName = 'example')
  1446. end;
  1447. function IsLinkAbsolute(ALink: String): boolean;
  1448. var
  1449. i: integer;
  1450. begin
  1451. Result := false;
  1452. for i := low(AbsoluteLinkPrefixes) to high(AbsoluteLinkPrefixes) do
  1453. if CompareText(AbsoluteLinkPrefixes[i], copy(ALink,1,length(AbsoluteLinkPrefixes[i])))=0 then begin
  1454. Result := true;
  1455. break;
  1456. end;
  1457. end;
  1458. {$IFDEF EXCEPTION_STACK}
  1459. function DumpExceptionCallStack(E: Exception):String;
  1460. var
  1461. I: Integer;
  1462. Frames: PPointer;
  1463. begin
  1464. Result := 'Program exception! ' + LineEnding +
  1465. 'Stacktrace:' + LineEnding + LineEnding;
  1466. if E <> nil then begin
  1467. Result := Result + 'Exception class: ' + E.ClassName + LineEnding +
  1468. 'Message: ' + E.Message + LineEnding;
  1469. end;
  1470. Result := Result + BackTraceStrFunc(ExceptAddr);
  1471. Frames := ExceptFrames;
  1472. for I := 0 to ExceptFrameCount - 1 do
  1473. Result := Result + LineEnding + BackTraceStrFunc(Frames[I]);
  1474. end;
  1475. {$ENDIF}
  1476. initialization
  1477. LEOL:=Length(LineEnding);
  1478. end.