dglobals.pp 47 KB

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