dglobals.pp 46 KB

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