1 {  $Id: lazhelpintf.pas 58244 2018-06-13 13:59:07Z juha $  }
2 {
3  *****************************************************************************
4   This file is part of the Lazarus Component Library (LCL)
5 
6   See the file COPYING.modifiedLGPL.txt, included in this distribution,
7   for details about the license.
8  *****************************************************************************
9 
10   Author: Mattias Gaertner
11 
12   Abstract:
13     This unit defines various base classes for the LCL Help System.
14 
15   ToDo:
16     - fix TCHMHelpViewer
17     - Make THelpDatabase and THelpViewer components usable in the designer.
18     - localization support.
19     - Add Help Editing functions
20 }
21 unit LazHelpIntf;
22 
23 {$mode objfpc}{$H+}
24 
25 interface
26 
27 uses
28   Classes, SysUtils,
29   // LazUtils
30   FileUtil, LazFileUtils, LazUtilities, LazUTF8, LazConfigStorage, Masks,
31   // LCL
32   LCLProc, LCLStrConsts, Dialogs, HelpIntfs;
33 
34 type
35   { THelpQueryItem }
36 
37   THelpQueryItem = class
38   public
AsStringnull39     function AsString: string; virtual; abstract;
IsEqualnull40     function IsEqual(QueryItem: THelpQueryItem): boolean; virtual;
41   end;
42 
43   { TPascalHelpContextList }
44 
45   TPascalHelpContextType = (
46     pihcFilename,
47     pihcSourceName,  // unit name, library name, ..
48     pihcProperty,
49     pihcProcedure,
50     pihcParameterList,
51     pihcVariable,
52     pihcType,
53     pihcConst
54     );
55   TPascalHelpContext = record
56     Descriptor: TPascalHelpContextType;
57     Context: string;
58   end;
59   TPascalHelpContextPtr = ^TPascalHelpContext;
60 
61   TPascalHelpContextList = class(THelpQueryItem)
62   private
63     FCount: integer;
64     fItems: TPascalHelpContextPtr;
GetItemsnull65     function GetItems(Index: integer): TPascalHelpContext;
66   public
67     procedure Add(const Context: TPascalHelpContext);
68     procedure Add(Descriptor: TPascalHelpContextType; const Context: string);
69     procedure Insert(Index: integer; const Context: TPascalHelpContext);
70     procedure Clear;
71     destructor Destroy; override;
IsEqualnull72     function IsEqual(QueryItem: THelpQueryItem): boolean; override;
CompareListnull73     function CompareList(AList: TPascalHelpContextList): integer;
AsStringnull74     function AsString: string; override;
75   public
76     property Count: integer read FCount;
77     property Items[Index: integer]: TPascalHelpContext read GetItems;
78     property List: TPascalHelpContextPtr read fItems;
79   end;
80 
81 
82   THelpDatabase = class;
83 
84   { THelpNode
85     A help node is a position/place in a help database.
86     For example it points to a Help file or to a Link on a HTML file. }
87 
88   THelpNodeType = (
89     hntURLIDContext, // URL, ID and Context valid
90     hntURL,          // URL valid, ignore ID and Context
91     hntURLID,        // URL and ID valid, ignore Context
92     hntID,           // ID valid, ignore URL and Context
93     hntContext,      // Context valid, ignore URL and ID
94     hntURLContext    // URL and Context valid, ignore ID
95     );
96 
97   THelpNode = class(TPersistent)
98   private
99     FContext: THelpContext;
100     FURL: string;
101     FHelpType: THelpNodeType;
102     fID: string;
103     FOwner: THelpDatabase;
104     FTitle: string;
105   public
106     constructor Create(TheOwner: THelpDatabase; Node: THelpNode);
107     constructor Create(TheOwner: THelpDatabase;
108                        const TheTitle, TheURL, TheID: string;
109                        TheContext: THelpContext);
110     constructor CreateURL(TheOwner: THelpDatabase;
111                           const TheTitle, TheURL: string);
112     constructor CreateID(TheOwner: THelpDatabase; const TheTitle, TheID: string);
113     constructor CreateURLID(TheOwner: THelpDatabase; const TheTitle,
114                             TheURL, TheID: string);
115     constructor CreateContext(TheOwner: THelpDatabase; const TheTitle: string;
116                               TheContext: THelpContext);
117     constructor CreateURLContext(TheOwner: THelpDatabase;
118                                  const TheTitle, TheURL: string;
119                                  TheContext: THelpContext);
120   public
121     property Owner: THelpDatabase read FOwner write FOwner;
URLValidnull122     function URLValid: boolean;
IDValidnull123     function IDValid: boolean;
ContextValidnull124     function ContextValid: boolean;
AsStringnull125     function AsString: string;
126     procedure Assign(Source: TPersistent); override;
127   published
128     property Title: string read FTitle write FTitle;
129     property HelpType: THelpNodeType read FHelpType write FHelpType;
130     property URL: string read FURL write FURL;
131     property ID: string read fID write fID;
132     property Context: THelpContext read FContext write FContext;
133   end;
134 
135 
136   { THelpNodeQuery }
137 
138   THelpNodeQuery = class
139   private
140     FNode: THelpNode;
141     FQueryItem: THelpQueryItem;
142   public
143     constructor Create;
144     constructor Create(TheNode: THelpNode; TheQueryItem: THelpQueryItem);
IsEqualnull145     function IsEqual(TheNode: THelpNode; TheQueryItem: THelpQueryItem): boolean;
IsEqualnull146     function IsEqual(NodeQuery: THelpNodeQuery): boolean;
AsStringnull147     function AsString: string;
148     property Node: THelpNode read FNode write FNode;
149     property QueryItem: THelpQueryItem read FQueryItem write FQueryItem;
150   end;
151 
152 
153   { THelpNodeQueryList }
154 
155   THelpNodeQueryList = class
156   private
157     fItems: TFPList;
GetItemsnull158     function GetItems(Index: integer): THelpNodeQuery;
159     procedure SetItems(Index: integer; const AValue: THelpNodeQuery);
160   public
161     constructor Create;
162     destructor Destroy; override;
Countnull163     function Count: integer;
Addnull164     function Add(NodeQuery: THelpNodeQuery): integer;
Addnull165     function Add(Node: THelpNode; QueryItem: THelpQueryItem): integer;
166     procedure Delete(Index: integer);
IndexOfnull167     function IndexOf(NodeQuery: THelpNodeQuery): integer;
IndexOfnull168     function IndexOf(Node: THelpNode; QueryItem: THelpQueryItem): integer;
169     procedure Clear;
170     property Items[Index: integer]: THelpNodeQuery read GetItems write SetItems; default;
171   end;
172 
173 
174   { THelpDBItem
175     Base class for registration items associated with a THelpDatabase.
176     See THelpDBSISourceDirectory for an example.
177     Node is optional, pointing to a help page about the help item. }
178 
179   THelpDBItem = class(TPersistent)
180   private
181     FNode: THelpNode;
182   public
183     constructor Create(TheNode: THelpNode);
184     destructor Destroy; override;
185   published
186     property Node: THelpNode read FNode write FNode;
187   end;
188 
189 
190   { THelpDBSISourceFile
191     Help registration item for a single source file.
192     If Filename is relative, the BasePathObject is used to get a base directory.
193 
194     For example: If BasePathObject is a TLazPackage the Filename is relative to
195     the directory of the .lpk file }
196 
197   THelpDBISourceFile = class(THelpDBItem)
198   private
199     FBasePathObject: TObject;
200     FFilename: string;
201     procedure SetFilename(const AValue: string);
202   public
203     constructor Create(TheNode: THelpNode; const TheFilename: string);
FileMatchesnull204     function FileMatches(const AFilename: string): boolean; virtual;
GetFullFilenamenull205     function GetFullFilename: string; virtual;
GetBasePathnull206     function GetBasePath: string; virtual;
207   published
208     property BasePathObject: TObject read FBasePathObject write FBasePathObject;
209     property Filename: string read FFilename write SetFilename;
210   end;
211 
212 
213   { THelpDBISourceDirectory
214     Help registration item for source directory.
215     As THelpDBISourceFile, except that Filename is a directory and
216     the item is valid for all source files fitting the FileMask.
217     FileMask can be for example '*.pp;*.pas;*.inc'
218 
219     For example: A package providing help for all its source files registers
220     a THelpDBISourceDirectory. Node points to the fpdoc main page.
221     }
222 
223   THelpDBISourceDirectory = class(THelpDBISourceFile)
224   private
225     FFileMask: string;
226     FWithSubDirectories: boolean;
227   public
228     constructor Create(TheNode: THelpNode; const Directory,
229                        TheFileMask: string; Recursive: boolean);
FileMatchesnull230     function FileMatches(const AFilename: string): boolean; override;
231   published
232     property FileMask: string read FFileMask write FFileMask;
233     property WithSubDirectories: boolean read FWithSubDirectories
234                                          write FWithSubDirectories;
235   end;
236 
237 
238   { THelpDBISourceDirectories
239     Help registration item for source directories.
240     As THelpDBISourceDirectory, except that Filename are directories separated
241     by semicolon and the item is valid for all source files fitting the FileMask.
242     FileMask can be for example '*.pp;*.pas;*.inc'
243 
244     For example: A package providing help for all its source files registers
245     a THelpDBISourceDirectory. Node points to the fpdoc main page.
246     }
247 
248   THelpDBISourceDirectories = class(THelpDBISourceDirectory)
249   private
250     FBaseDirectory: string;
251   public
252     constructor Create(TheNode: THelpNode; const BaseDir, Directories,
253                        TheFileMask: string; Recursive: boolean);
FileMatchesnull254     function FileMatches(const AFilename: string): boolean; override;
GetFullFilenamenull255     function GetFullFilename: string; override;
GetBasePathnull256     function GetBasePath: string; override;
257   published
258     property BaseDirectory: string read FBaseDirectory write FBaseDirectory;
259   end;
260 
261   { THelpDBIClass
262     Help registration item for a class.
263     Used by the IDE to search for help for a class without source.
264     For example for a registered component class in the component palette, that
265     comes without source. If the component comes with source use the
266     THelpDBISourceDirectory or THelpDBISourceFile instead. }
267 
268   THelpDBIClass = class(THelpDBItem)
269   private
270     FTheClass: TClass;
271   public
272     property TheClass: TClass read FTheClass write FTheClass;
273   end;
274 
275 
276   { THelpDBIMessage
277     Help registration item for a message (e.g. an FPC warning).
278     Used by the IDE to search for help for one message (typically a line).
279     For example a line like
280       "/usr/share/lazarus/components/synedit/syneditkeycmds.pp(532,10) Warning: Function result does not seem to be set"
281     }
282 
283   THelpDBIMessage = class(THelpDBItem)
284   public
MessageMatchesnull285     function MessageMatches(const TheMessage: string; MessageParts: TStrings
286                             ): boolean; virtual; abstract;
287   end;
288 
289 
290   { THelpQueryNode }
291 
292   THelpQueryNode = class(THelpQuery)
293   private
294     FNode: THelpNode;
295   public
296     constructor Create(const TheHelpDatabaseID: THelpDatabaseID;
297                        const TheNode: THelpNode);
298     property Node: THelpNode read FNode write FNode;
299   end;
300 
301 
302   { THelpDatabase
303     Base class for a collection of help files or entries.
304     BasePathObject: THelpDatabase can be created by packages.
305                     The IDE will set BasePathObject accordingly. }
306 
307   THelpDatabases = class;
308   THelpViewer = class;
309 
310   TOnHelpDBFindViewer =
elpDBnull311     function(HelpDB: THelpDatabase; const MimeType: string;
312         var ErrMsg: string; out Viewer: THelpViewer): TShowHelpResult of object;
313 
314   THelpDatabase = class(TComponent)
315   private
316     FAutoRegister: boolean;
317     FBasePathObject: TObject;
318     FID: THelpDatabaseID;
319     FDatabases: THelpDatabases;
320     FOnFindViewer: TOnHelpDBFindViewer;
321     FRefCount: integer;
322     FSearchItems: TFPList;
323     FSupportedMimeTypes: TStrings;
324     FTOCNode: THelpNode;
325     procedure SetAutoRegister(const AValue: boolean);
326     procedure SetID(const AValue: THelpDatabaseID);
327     procedure SetDatabases(const AValue: THelpDatabases);
328   protected
329     procedure SetSupportedMimeTypes(List: TStrings); virtual;
330     procedure AddSupportedMimeType(const AMimeType: string); virtual;
331   public
332     constructor Create(TheOwner: TComponent); override;
333     destructor Destroy; override;
334     procedure Reference;
335     procedure RegisterSelf;
336     procedure Release;
337     procedure UnregisterSelf;
Registerednull338     function Registered: boolean;
CanShowTableOfContentsnull339     function CanShowTableOfContents: boolean; virtual;
340     procedure ShowTableOfContents; virtual;
341     procedure ShowError(ShowResult: TShowHelpResult; const ErrMsg: string); virtual;
ShowHelpnull342     function ShowHelp(Query: THelpQuery; BaseNode, NewNode: THelpNode;
343                       QueryItem: THelpQueryItem;
344                       var ErrMsg: string): TShowHelpResult; virtual;
ShowHelpFilenull345     function ShowHelpFile(Query: THelpQuery; BaseNode: THelpNode;
346                           const Title, Filename: string;
347                           var ErrMsg: string): TShowHelpResult; virtual;
SupportsMimeTypenull348     function SupportsMimeType(const AMimeType: string): boolean; virtual;
GetNodesForKeywordnull349     function GetNodesForKeyword(const HelpKeyword: string;
350                                 var ListOfNodes: THelpNodeQueryList;
351                                 var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForDirectivenull352     function GetNodesForDirective(const HelpDirective: string;
353                                 var ListOfNodes: THelpNodeQueryList;
354                                 var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForContextnull355     function GetNodesForContext(HelpContext: THelpContext;
356                                 var ListOfNodes: THelpNodeQueryList;
357                                 var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForPascalContextsnull358     function GetNodesForPascalContexts(ListOfPascalHelpContextList: TList;
359                                        var ListOfNodes: THelpNodeQueryList;
360                                        var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForClassnull361     function GetNodesForClass(AClass: TClass;
362                               var ListOfNodes: THelpNodeQueryList;
363                               var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForMessagenull364     function GetNodesForMessage(const AMessage: string; MessageParts: TStrings;
365                                 var ListOfNodes: THelpNodeQueryList;
366                                 var ErrMsg: string): TShowHelpResult; virtual;
FindViewernull367     function FindViewer(const MimeType: string; var ErrMsg: string;
368                         out Viewer: THelpViewer): TShowHelpResult; virtual;
369   public
370     // registration
371     procedure RegisterItem(NewItem: THelpDBItem);
372     procedure RegisterItemWithNode(Node: THelpNode);
373     procedure RegisterFileItemWithNode(const Filename: string; Node: THelpNode);
374     procedure UnregisterItem(AnItem: THelpDBItem);
375     procedure UnregisterAllItems;
RegisteredItemCountnull376     function RegisteredItemCount: integer;
GetRegisteredItemnull377     function GetRegisteredItem(Index: integer): THelpDBItem;
378     procedure Load(Storage: TConfigStorage); virtual;
379     procedure Save(Storage: TConfigStorage); virtual;
GetLocalizedNamenull380     function GetLocalizedName: string; virtual;
381   public
382     property Databases: THelpDatabases read FDatabases write SetDatabases;
383     property ID: THelpDatabaseID read FID write SetID;
384     property SupportedMimeTypes: TStrings read FSupportedMimeTypes;
385     property BasePathObject: TObject read FBasePathObject write FBasePathObject;
386     property TOCNode: THelpNode read FTOCNode write FTOCNode;
387     property AutoRegister: boolean read FAutoRegister write SetAutoRegister;
388     property OnFindViewer: TOnHelpDBFindViewer read FOnFindViewer write FOnFindViewer;
389   end;
390 
391   THelpDatabaseClass = class of THelpDatabase;
392 
393 
394   { THelpDatabases
395     Class for storing all registered THelpDatabase(s) }
396 
397   THelpDatabases = class(THelpManager)
398   private
399     FItems: TFPList;
400     FHelpDBClasses: TFPList;
GetItemsnull401     function GetItems(Index: integer): THelpDatabase;
402     procedure DoRegisterDatabase(ADatabase: THelpDatabase);
403     procedure DoUnregisterDatabase(ADatabase: THelpDatabase);
404   public
405     constructor Create;
406     destructor Destroy; override;
Countnull407     function Count: integer;
408     property Items[Index: integer]: THelpDatabase read GetItems; default;
409   public
FindDatabasenull410     function FindDatabase(ID: THelpDatabaseID): THelpDatabase;
GetDatabasenull411     function GetDatabase(ID: THelpDatabaseID; var HelpDB: THelpDatabase;
412                          var HelpResult: TShowHelpResult; var ErrMsg: string): boolean;
IndexOfnull413     function IndexOf(ID: THelpDatabaseID): integer;
CreateUniqueDatabaseIDnull414     function CreateUniqueDatabaseID(const WishID: string): THelpDatabaseID;
CreateHelpDatabasenull415     function CreateHelpDatabase(const WishID: string;
416                                 HelpDataBaseClass: THelpDatabaseClass;
417                                 AutoRegister: boolean): THelpDatabase;
ShowTableOfContentsnull418     function ShowTableOfContents(var ErrMsg: string): TShowHelpResult; override;
419     procedure ShowError(ShowResult: TShowHelpResult; const ErrMsg: string); override;
GetBaseURLForBasePathObjectnull420     function GetBaseURLForBasePathObject(BasePathObject: TObject): string; virtual;
GetBaseDirectoryForBasePathObjectnull421     function GetBaseDirectoryForBasePathObject(BasePathObject: TObject): string; virtual;
FindViewernull422     function FindViewer(const MimeType: string; var ErrMsg: string;
423                         var Viewer: THelpViewer): TShowHelpResult; virtual;
SubstituteMacrosnull424     function SubstituteMacros(var s: string): boolean; virtual;
425   public
426     // show help for ...
ShowHelpForNodesnull427     function ShowHelpForNodes(Query: THelpQuery; Nodes: THelpNodeQueryList;
428                               var ErrMsg: string): TShowHelpResult; virtual;
ShowHelpForQuerynull429     function ShowHelpForQuery(Query: THelpQuery; AutoFreeQuery: boolean;
430                               var ErrMsg: string): TShowHelpResult; override;
ShowHelpForContextnull431     function ShowHelpForContext(Query: THelpQueryContext;
432                                 var ErrMsg: string): TShowHelpResult; override;
ShowHelpForKeywordnull433     function ShowHelpForKeyword(Query: THelpQueryKeyword;
434                                 var ErrMsg: string): TShowHelpResult; override;
ShowHelpForDirectivenull435     function ShowHelpForDirective(Query: THelpQueryDirective;
436                                 var ErrMsg: string): TShowHelpResult; override;
ShowHelpForPascalContextsnull437     function ShowHelpForPascalContexts(Query: THelpQueryPascalContexts;
438                                        var ErrMsg: string): TShowHelpResult; override;
ShowHelpForSourcePositionnull439     function ShowHelpForSourcePosition(Query: THelpQuerySourcePosition;
440                                        var ErrMsg: string): TShowHelpResult; override;
ShowHelpForMessageLinenull441     function ShowHelpForMessageLine(Query: THelpQueryMessage;
442                                     var ErrMsg: string): TShowHelpResult; override;
ShowHelpForClassnull443     function ShowHelpForClass(Query: THelpQueryClass;
444                               var ErrMsg: string): TShowHelpResult; override;
ShowHelpFilenull445     function ShowHelpFile(const Filename, Title, MimeType: string;
446                       var ErrMsg: string): TShowHelpResult; override;
ShowHelpnull447     function ShowHelp(const URL, Title, MimeType: string;
448                       var ErrMsg: string): TShowHelpResult; override;
449     // search registered items in all databases
GetNodesForKeywordnull450     function GetNodesForKeyword(const HelpKeyword: string;
451                                 var ListOfNodes: THelpNodeQueryList;
452                                 var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForDirectivenull453     function GetNodesForDirective(const HelpDirective: string;
454                                 var ListOfNodes: THelpNodeQueryList;
455                                 var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForContextnull456     function GetNodesForContext(HelpContext: THelpContext;
457                                 var ListOfNodes: THelpNodeQueryList;
458                                 var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForPascalContextsnull459     function GetNodesForPascalContexts(ListOfPascalHelpContextList: TList;
460                                        var ListOfNodes: THelpNodeQueryList;
461                                        var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForClassnull462     function GetNodesForClass(AClass: TClass;
463                               var ListOfNodes: THelpNodeQueryList;
464                               var ErrMsg: string): TShowHelpResult; virtual;
GetNodesForMessagenull465     function GetNodesForMessage(const AMessage: string; MessageParts: TStrings;
466                                 var ListOfNodes: THelpNodeQueryList;
467                                 var ErrMsg: string): TShowHelpResult; virtual;
468     // Show the help selector
ShowHelpSelectornull469     function ShowHelpSelector(Query: THelpQuery; Nodes: THelpNodeQueryList;
470                               var ErrMsg: string;
471                               var Selection: THelpNodeQuery
472                               ): TShowHelpResult; virtual;
473   public
474     // registration of THelpDatabaseClass
475     procedure RegisterHelpDatabaseClass(NewHelpDB: THelpDatabaseClass);
476     procedure UnregisterHelpDatabaseClass(AHelpDB: THelpDatabaseClass);
HelpDatabaseClassCountnull477     function HelpDatabaseClassCount: integer;
GetHelpDatabaseClassnull478     function GetHelpDatabaseClass(Index: integer): THelpDatabaseClass;
479     procedure Load(Storage: TConfigStorage); virtual;
480     procedure Save(Storage: TConfigStorage); virtual;
481   end;
482 
483 
484   { THelpViewer
485     base class for all Help viewers }
486 
487   THelpViewer = class(TComponent)
488   private
489     FAutoRegister: boolean;
490     FParameterHelp: string;
491     FStorageName: string;
492     FSupportedMimeTypes: TStrings;
493     procedure SetAutoRegister(const AValue: boolean);
494   protected
495     procedure SetSupportedMimeTypes(List: TStrings); virtual;
496     procedure AddSupportedMimeType(const AMimeType: string); virtual;
497   public
498     constructor Create(TheOwner: TComponent); override;
499     destructor Destroy; override;
SupportsTableOfContentsnull500     function SupportsTableOfContents: boolean; virtual;
501     procedure ShowTableOfContents(Node: THelpNode); virtual;
SupportsMimeTypenull502     function SupportsMimeType(const AMimeType: string): boolean; virtual;
ShowNodenull503     function ShowNode(Node: THelpNode; var ErrMsg: string): TShowHelpResult; virtual;
504     procedure Hide; virtual;
505     procedure Assign(Source: TPersistent); override;
506     procedure Load(Storage: TConfigStorage); virtual;
507     procedure Save(Storage: TConfigStorage); virtual;
GetLocalizedNamenull508     function GetLocalizedName: string; virtual;
509     procedure RegisterSelf; virtual;
510     procedure UnregisterSelf; virtual;
511   public
512     property SupportedMimeTypes: TStrings read FSupportedMimeTypes;
513     property ParameterHelp: string read FParameterHelp write FParameterHelp;
514     property StorageName: string read FStorageName write FStorageName;
515     property AutoRegister: boolean read FAutoRegister write SetAutoRegister;
516   end;
517 
518   THelpViewerClass = class of THelpViewer;
519 
520 
521   { THelpViewers }
522 
523   THelpViewers = class
524   private
525     FItems: TFPList;
526     FDestroying: boolean;
GetItemsnull527     function GetItems(Index: integer): THelpViewer;
528   public
529     constructor Create;
530     destructor Destroy; override;
531     procedure Clear;
Countnull532     function Count: integer;
GetViewersSupportingMimeTypenull533     function GetViewersSupportingMimeType(const MimeType: string): TList;
534     procedure RegisterViewer(AHelpViewer: THelpViewer);
535     procedure UnregisterViewer(AHelpViewer: THelpViewer);
536     procedure Load(Storage: TConfigStorage); virtual;
537     procedure Save(Storage: TConfigStorage); virtual;
IndexOfnull538     function IndexOf(AHelpViewer: THelpViewer): integer;
539   public
540     property Items[Index: integer]: THelpViewer read GetItems; default;
541   end;
542 
543 
544   { THelpBasePathObject
545     Simple class to store a base file path for help databases. }
546 
547   THelpBasePathObject = class(TPersistent)
548   private
549     FBasePath: string;
550   protected
551     procedure SetBasePath(const AValue: string); virtual;
552   public
553     constructor Create;
554     constructor Create(const TheBasePath: string);
555     property BasePath: string read FBasePath write SetBasePath;
556   end;
557 
558   { THelpBaseURLObject
559     Simple class to store a base URL path for help databases. }
560 
561   THelpBaseURLObject = class(TPersistent)
562   private
563     FBaseURL: string;
564   protected
565     procedure SetBaseURL(const AValue: string);
566   public
567     constructor Create;
568     constructor Create(const TheBaseURL: string);
569     property BaseURL: string read FBaseURL write SetBaseURL;
570   end;
571 
572 var
573   HelpDatabases: THelpDatabases = nil; // initialized by the IDE
574   HelpViewers: THelpViewers = nil; // initialized by the IDE
575 
576 procedure CreateLCLHelpSystem;
577 procedure FreeLCLHelpSystem;
578 procedure FreeUnusedLCLHelpSystem;
579 
580 // URL functions
581 // used names:
582 //  URL: Type + Path + Params e.g. http://www.freepascal.org?param
583 //  URLType: e.g. file or http
584 //  URLPath: URL without type and without parameters (always / as path delimiter)
585 //  URLParams: parameters appended by ? or #
FilenameToURLnull586 function FilenameToURL(const Filename: string): string;
FilenameToURLPathnull587 function FilenameToURLPath(const Filename: string): string;
URLPathToFilenamenull588 function URLPathToFilename(const URLPath: string): string;
589 procedure SplitURL(const URL: string; out URLScheme, URLPath, URLParams: string);
CombineURLnull590 function CombineURL(const URLScheme, URLPath, URLParams: string): string;
URLFilenameIsAbsolutenull591 function URLFilenameIsAbsolute(const URLPath: string): boolean;
FindURLPathStartnull592 function FindURLPathStart(const URL: string): integer;
FindURLPathEndnull593 function FindURLPathEnd(const URL: string): integer;
ChompURLParamsnull594 function ChompURLParams(const URL: string): string;
ExtractURLPathnull595 function ExtractURLPath(const URL: string): string;
ExtractURLDirectorynull596 function ExtractURLDirectory(const URL: string): string;
TrimUrlnull597 function TrimUrl(const URL: string): string;
TrimURLPathnull598 function TrimURLPath(const URLPath: string): string;
IsFileURLnull599 function IsFileURL(const URL: string): boolean;
AppendURLPathDelimnull600 function AppendURLPathDelim(const URLPath: string): string;
601 
602 procedure CreateListAndAdd(const AnObject: TObject; var List: TList;
603   OnlyIfNotExists: boolean);
604 procedure CreateNodeQueryListAndAdd(const ANode: THelpNode;
605   const QueryItem: THelpQueryItem;
606   var List: THelpNodeQueryList; OnlyIfNotExists: boolean);
607 
608 
609 implementation
610 
611 
612 procedure CreateLCLHelpSystem;
613 begin
614   if (HelpDatabases<>nil) or (HelpManager<>nil) then exit;
615   HelpDatabases:=THelpDatabases.Create;
616   HelpManager:=HelpDatabases;
617   HelpViewers:=THelpViewers.Create;
618 end;
619 
620 procedure FreeLCLHelpSystem;
621 begin
622   FreeThenNil(HelpDatabases);
623   FreeThenNil(HelpViewers);
624   HelpManager:=nil;
625 end;
626 
627 procedure FreeUnusedLCLHelpSystem;
628 begin
629   if (HelpViewers<>nil) and (HelpViewers.Count>0) then exit;
630   if (HelpDatabases<>nil) and (HelpDatabases.Count>0) then exit;
631   FreeLCLHelpSystem;
632 end;
633 
FilenameToURLnull634 function FilenameToURL(const Filename: string): string;
635 begin
636   Result:=FilenameToURLPath(Filename);
637   if Result<>'' then
638     Result:='file://'+Result;
639 end;
640 
FilenameToURLPathnull641 function FilenameToURLPath(const Filename: string): string;
642 var
643   i: Integer;
644 begin
645   Result:=Filename;
646   {$warnings off}
647   if PathDelim<>'/' then
648     for i:=1 to length(Result) do
649       if Result[i]=PathDelim then
650         Result[i]:='/';
651   {$warnings on}
652 end;
653 
URLPathToFilenamenull654 function URLPathToFilename(const URLPath: string): string;
655 var
656   i: Integer;
657 begin
658   Result:=URLPath;
659   {$warnings off}
660   if PathDelim<>'/' then
661     for i:=1 to length(Result) do
662       if Result[i]='/' then
663         Result[i]:=PathDelim;
664   {$warnings on}
665 end;
666 
667 procedure SplitURL(const URL: string; out URLScheme, URLPath, URLParams: string);
668 var
669   Len: Integer;
670   ColonPos: Integer;
671   ParamStartPos: integer;
672   URLStartPos: Integer;
673 begin
674   URLScheme:='';
675   URLPath:='';
676   URLParams:='';
677   Len:=length(URL);
678   // search colon
679   ColonPos:=1;
680   while (ColonPos<=len) and (URL[ColonPos]<>':') do
681     inc(ColonPos);
682   if ColonPos>len then exit;
683   // get URLScheme
684   URLScheme:=copy(URL,1,ColonPos-1);
685   URLStartPos:=ColonPos+1;
686   // skip the '//' after the colon
687   if (URLStartPos<=len) and (URL[URLStartPos]='/') then inc(URLStartPos);
688   if (URLStartPos<=len) and (URL[URLStartPos]='/') then inc(URLStartPos);
689   // search for param delimiter (?) or anchor delimiter (#)
690   ParamStartPos:=ColonPos+1;
691   while (ParamStartPos<=len) and not (URL[ParamStartPos]in ['?', '#']) do
692     inc(ParamStartPos);
693   // get URLPath and URLParams
694   URLPath:=copy(URL,URLStartPos,ParamStartPos-URLStartPos);
695   URLParams:=copy(URL,ParamStartPos,len-ParamStartPos+1);
696 end;
697 
CombineURLnull698 function CombineURL(const URLScheme, URLPath, URLParams: string): string;
699 begin
700   Result:=URLScheme+'://'+URLPath;
701   if URLParams<>'' then
702     Result:=Result+URLParams;
703 end;
704 
URLFilenameIsAbsolutenull705 function URLFilenameIsAbsolute(const URLPath: string): boolean;
706 begin
707   Result:=FilenameIsAbsolute(URLPathToFilename(URLPath));
708 end;
709 
FindURLPathStartnull710 function FindURLPathStart(const URL: string): integer;
711 var
712   Len: Integer;
713   ColonPos: Integer;
714   URLStartPos: Integer;
715 begin
716   Result:=-1;
717   Len:=length(URL);
718   // search colon
719   ColonPos:=1;
720   while (ColonPos<=len) and (URL[ColonPos]<>':') do
721     inc(ColonPos);
722   if ColonPos=Len then exit;
723   URLStartPos:=ColonPos+1;
724   // skip the '//' after the colon
725   if (URLStartPos<=Len) and (URL[URLStartPos]='/') then inc(URLStartPos);
726   if (URLStartPos<=Len) and (URL[URLStartPos]='/') then inc(URLStartPos);
727   Result:=URLStartPos;
728 end;
729 
FindURLPathEndnull730 function FindURLPathEnd(const URL: string): integer;
731 var
732   Len: Integer;
733 begin
734   Result:=1;
735   Len:=length(URL);
736   while (Result<=Len) and not (URL[Result] in ['?','#']) do inc(Result);
737 end;
738 
ChompURLParamsnull739 function ChompURLParams(const URL: string): string;
740 begin
741   Result:=copy(URL,1,FindURLPathEnd(URL)-1);
742 end;
743 
ExtractURLDirectorynull744 function ExtractURLDirectory(const URL: string): string;
745 var
746   p: Integer;
747   PathStart: LongInt;
748 begin
749   Result:='';
750   PathStart:=FindURLPathStart(URL);
751   if PathStart<1 then exit;
752   p:=FindURLPathEnd(URL);
753   repeat
754     dec(p);
755   until (p<=0) or (URL[p]='/');
756   if p<=PathStart then exit;
757   Result:=copy(URL,1,p);
758 end;
759 
TrimUrlnull760 function TrimUrl(const URL: string): string;
761 var
762   URLType, URLPath, URLParams: string;
763 begin
764   SplitURL(URL,URLType,URLPath,URLParams);
765   Result:=CombineURL(URLType,TrimURLPath(URLPath),URLParams);
766 end;
767 
TrimURLPathnull768 function TrimURLPath(const URLPath: string): string;
769 begin
770   Result:=FilenameToURLPath(TrimFilename(URLPathToFilename(URLPath)));
771 end;
772 
IsFileURLnull773 function IsFileURL(const URL: string): boolean;
774 begin
775   Result:=(length(URL)>=7)
776           and (CompareByte(URL[1],'file://',7)=0);
777 end;
778 
AppendURLPathDelimnull779 function AppendURLPathDelim(const URLPath: string): string;
780 begin
781   if (URLPath<>'') and (URLPath[length(URLPath)]<>'/') then
782     Result:=URLPath+'/'
783   else
784     Result:=URLPath;
785 end;
786 
ExtractURLPathnull787 function ExtractURLPath(const URL: string): string;
788 var
789   URLType, URLPath, URLParams: string;
790 begin
791   SplitURL(URL,URLType,URLPath,URLParams);
792   Result:=URLPath;
793 end;
794 
795 procedure CreateListAndAdd(const AnObject: TObject; var List: TList;
796   OnlyIfNotExists: boolean);
797 begin
798   if List=nil then
799     List:=TList.Create
800   else if OnlyIfNotExists and (List.IndexOf(AnObject)>=0) then
801     exit;
802   List.Add(AnObject);
803 end;
804 
805 procedure CreateNodeQueryListAndAdd(const ANode: THelpNode;
806   const QueryItem: THelpQueryItem;
807   var List: THelpNodeQueryList; OnlyIfNotExists: boolean);
808 begin
809   if List=nil then
810     List:=THelpNodeQueryList.Create
811   else if OnlyIfNotExists and (List.IndexOf(ANode,QueryItem)>=0) then
812     exit;
813   List.Add(ANode,QueryItem);
814 end;
815 
816 { THelpDBISourceDirectories }
817 
818 constructor THelpDBISourceDirectories.Create(TheNode: THelpNode; const BaseDir,
819   Directories, TheFileMask: string; Recursive: boolean);
820 begin
821   inherited Create(TheNode,Directories,TheFileMask,Recursive);
822   FBaseDirectory:=BaseDir;
823 end;
824 
THelpDBISourceDirectories.FileMatchesnull825 function THelpDBISourceDirectories.FileMatches(const AFilename: string
826   ): boolean;
827 var
828   SearchPath: String;
829   EndPos: Integer;
830   StartPos: Integer;
831   Dir: String;
832 begin
833   Result:=false;
834   //debugln('THelpDBISourceDirectories.FileMatches AFilename="',AFilename,'" FFilename="',FFilename,'"');
835   if (FFilename='') or (AFilename='') then exit;
836   SearchPath:=GetFullFilename;
837   if SearchPath='' then begin
838     {$IFNDEF DisableChecks}
839     DebugLn(['WARNING: THelpDBISourceDirectory.FileMatches ',DbgSName(Self),' Filename="',Filename,'" -> ""']);
840     {$ENDIF}
841     exit;
842   end;
843   EndPos:=1;
844   while EndPos<=length(SearchPath) do begin
845     StartPos:=EndPos;
846     while (EndPos<=length(SearchPath)) and (SearchPath[EndPos]<>';') do
847       inc(EndPos);
848     Dir:=copy(SearchPath,StartPos,EndPos-StartPos);
849     inc(EndPos);
850     //debugln(['THelpDBISourceDirectories.FileMatches TheDirectory="',Dir,'" WithSubDirectories=',WithSubDirectories]);
851     if WithSubDirectories then begin
852       if not FileIsInPath(AFilename,Dir) then continue;
853     end else begin
854       if not FileIsInDirectory(AFilename,Dir) then continue;
855     end;
856     //debugln('THelpDBISourceDirectories.FileMatches FileMask="',FileMask,'"');
857     if (FileMask='')
858     or MatchesMaskList(ExtractFilename(AFilename),FileMask) then
859       exit(true);
860   end;
861 end;
862 
GetFullFilenamenull863 function THelpDBISourceDirectories.GetFullFilename: string;
864 var
865   ExpFilename: String;
866   EndPos: Integer;
867   StartPos: Integer;
868   Dir: String;
869   BaseDir: String;
870 begin
871   ExpFilename:=FFilename;
872   //DebugLn(['THelpDBISourceDirectories.GetFullFilename ExpFilename="',ExpFilename,'" HelpDatabases=',DbgSName(HelpDatabases)]);
873   if (HelpDatabases<>nil) then
874     HelpDatabases.SubstituteMacros(ExpFilename);
875   //DebugLn(['THelpDBISourceFile.GetFullFilename substituted ',ExpFilename]);
876   EndPos:=1;
877   Result:='';
878   BaseDir:='';
879   while EndPos<=length(ExpFilename) do begin
880     StartPos:=EndPos;
881     while (EndPos<=length(ExpFilename)) and (ExpFilename[EndPos]<>';') do
882       inc(EndPos);
883     Dir:=TrimFilename(GetForcedPathDelims(copy(ExpFilename,StartPos,EndPos-StartPos)));
884     if Dir<>'' then begin
885       if not FilenameIsAbsolute(Dir) then begin
886         if BaseDir='' then
887           BaseDir:=AppendPathDelim(GetBasePath);
888         Dir:=BaseDir+Dir;
889       end;
890       if Result<>'' then Result:=Result+';';
891       Result:=Result+Dir;
892     end;
893     inc(EndPos);
894   end;
895 end;
896 
GetBasePathnull897 function THelpDBISourceDirectories.GetBasePath: string;
898 begin
899   if BaseDirectory='' then
900     Result:=inherited GetBasePath
901   else begin
902     Result:=BaseDirectory;
903     if (HelpDatabases<>nil) then
904       HelpDatabases.SubstituteMacros(Result);
905   end;
906   Result:=TrimFilename(GetForcedPathDelims(Result));
907 end;
908 
909 { THelpDatabase }
910 
911 procedure THelpDatabase.SetID(const AValue: THelpDatabaseID);
912 var
913   OldRegistered: Boolean;
914 begin
915   if FID=AValue then exit;
916   OldRegistered:=Registered;
917   if OldRegistered then UnregisterSelf;
918   FID:=AValue;
919   if OldRegistered then RegisterSelf;
920 end;
921 
922 procedure THelpDatabase.SetAutoRegister(const AValue: boolean);
923 begin
924   if FAutoRegister=AValue then exit;
925   FAutoRegister:=AValue;
926   if not (csDesigning in ComponentState) then begin
927     if FAutoRegister then begin
928       if FID='' then
929         FID:=Name;
930       if Databases=nil then RegisterSelf;
931     end else begin
932       if Databases<>nil then UnregisterSelf;
933     end;
934   end;
935 end;
936 
937 procedure THelpDatabase.SetDatabases(const AValue: THelpDatabases);
938 begin
939   if AValue=Databases then exit;
940   Reference;
941   if FDatabases<>nil then FDatabases.DoUnregisterDatabase(Self);
942   FDatabases:=AValue;
943   if FDatabases<>nil then FDatabases.DoRegisterDatabase(Self);
944   Release;
945 end;
946 
947 procedure THelpDatabase.SetSupportedMimeTypes(List: TStrings);
948 begin
949   FSupportedMimeTypes.Free;
950   FSupportedMimeTypes:=List;
951 end;
952 
953 procedure THelpDatabase.AddSupportedMimeType(const AMimeType: string);
954 begin
955   if FSupportedMimeTypes=nil then SetSupportedMimeTypes(TStringList.Create);
956   FSupportedMimeTypes.Add(AMimeType);
957 end;
958 
959 constructor THelpDatabase.Create(TheOwner: TComponent);
960 begin
961   inherited Create(TheOwner);
962 end;
963 
964 destructor THelpDatabase.Destroy;
965 var
966   i: Integer;
967 begin
968   Reference; // reference to not call Free again
969   if Databases<>nil then UnregisterSelf;
970   FSupportedMimeTypes.Free;
971   if FSearchItems<>nil then begin
972     for i:=FSearchItems.Count-1 downto 0 do
973       THelpNode(FSearchItems[i]).Free;
974     FSearchItems.Free;
975   end;
976   FTOCNode.Free;
977   inherited Destroy;
978 end;
979 
980 procedure THelpDatabase.RegisterSelf;
981 begin
982   if Databases<>nil then
983     raise EHelpSystemException.Create(Format(rsHelpAlreadyRegistered, [ID]));
984   if HelpDatabases=nil then CreateLCLHelpSystem;
985   Databases:=HelpDatabases;
986 end;
987 
988 procedure THelpDatabase.UnregisterSelf;
989 begin
990   if Databases=nil then
991     raise EHelpSystemException.Create(Format(rsHelpNotRegistered, [ID]));
992   Databases:=nil;
993   FreeUnusedLCLHelpSystem;
994 end;
995 
THelpDatabase.Registerednull996 function THelpDatabase.Registered: boolean;
997 begin
998   Result:=Databases<>nil;
999 end;
1000 
CanShowTableOfContentsnull1001 function THelpDatabase.CanShowTableOfContents: boolean;
1002 begin
1003   Result:=TOCNode<>nil;
1004 end;
1005 
1006 procedure THelpDatabase.ShowTableOfContents;
1007 var
1008   ErrMsg: string;
1009   ShowResult: TShowHelpResult;
1010   Query: THelpQueryTOC;
1011 begin
1012   if TOCNode=nil then exit;
1013   ErrMsg:='';
1014   Query:=THelpQueryTOC.Create(ID);
1015   try
1016     ShowResult:=ShowHelp(Query,nil,TOCNode,nil,ErrMsg);
1017   finally
1018     Query.Free;
1019   end;
1020   ShowError(ShowResult,ErrMsg);
1021 end;
1022 
1023 procedure THelpDatabase.ShowError(ShowResult: TShowHelpResult;
1024   const ErrMsg: string);
1025 begin
1026   if ShowResult=shrSuccess then exit;
1027   if Databases<>nil then
1028     Databases.ShowError(ShowResult,ErrMsg)
1029   else
1030     raise EHelpSystemException.Create(ErrMsg);
1031 end;
1032 
THelpDatabase.ShowHelpnull1033 function THelpDatabase.ShowHelp(Query: THelpQuery; BaseNode, NewNode: THelpNode;
1034   QueryItem: THelpQueryItem; var ErrMsg: string): TShowHelpResult;
1035 begin
1036   ErrMsg:='';
1037   Result:=shrContextNotFound;
1038 end;
1039 
ShowHelpFilenull1040 function THelpDatabase.ShowHelpFile(Query: THelpQuery; BaseNode: THelpNode;
1041   const Title, Filename: string; var ErrMsg: string): TShowHelpResult;
1042 var
1043   FileNode: THelpNode;
1044 begin
1045   FileNode:=THelpNode.CreateURL(Self,Title,FilenameToURL(Filename));
1046   try
1047     Result:=ShowHelp(Query,BaseNode,FileNode,nil,ErrMsg);
1048   finally
1049     FileNode.Free;
1050   end;
1051 end;
1052 
THelpDatabase.SupportsMimeTypenull1053 function THelpDatabase.SupportsMimeType(const AMimeType: string): boolean;
1054 begin
1055   Result:=false;
1056   if FSupportedMimeTypes<>nil then
1057     Result:=(FSupportedMimeTypes.IndexOf(AMimeType)>=0);
1058 end;
1059 
GetNodesForKeywordnull1060 function THelpDatabase.GetNodesForKeyword(const HelpKeyword: string;
1061   var ListOfNodes: THelpNodeQueryList; var ErrMsg: string): TShowHelpResult;
1062 // if ListOfNodes<>nil new nodes will be appended
1063 // if ListOfNodes=nil and nodes exists a new list will be created
1064 var
1065   i: Integer;
1066   Node: THelpNode;
1067 begin
1068   Result:=shrSuccess;
1069   ErrMsg:='';
1070   if csDesigning in ComponentState then exit;
1071   // add the registered nodes
1072   if FSearchItems<>nil then begin
1073     for i:=0 to FSearchItems.Count-1 do begin
1074       Node:=THelpDBItem(FSearchItems[i]).Node;
1075       if (Node=nil) or (not Node.IDValid) then continue;
1076       if UTF8CompareText(Node.ID,HelpKeyword)<>0 then continue;
1077       CreateNodeQueryListAndAdd(Node,nil,ListOfNodes,true);
1078     end;
1079   end;
1080 end;
1081 
THelpDatabase.GetNodesForDirectivenull1082 function THelpDatabase.GetNodesForDirective(const HelpDirective: string;
1083   var ListOfNodes: THelpNodeQueryList; var ErrMsg: string): TShowHelpResult;
1084 // if ListOfNodes<>nil new nodes will be appended
1085 // if ListOfNodes=nil and nodes exists a new list will be created
1086 var
1087   i: Integer;
1088   Node: THelpNode;
1089 begin
1090   Result:=shrSuccess;
1091   ErrMsg:='';
1092   if csDesigning in ComponentState then exit;
1093   // add the registered nodes
1094   if FSearchItems<>nil then begin
1095     for i:=0 to FSearchItems.Count-1 do begin
1096       Node:=THelpDBItem(FSearchItems[i]).Node;
1097       if (Node=nil) or (not Node.IDValid) then continue;
1098       if UTF8CompareText(Node.ID,HelpDirective)<>0 then continue;
1099       CreateNodeQueryListAndAdd(Node,nil,ListOfNodes,true);
1100     end;
1101   end;
1102 end;
1103 
THelpDatabase.GetNodesForContextnull1104 function THelpDatabase.GetNodesForContext(HelpContext: THelpContext;
1105   var ListOfNodes: THelpNodeQueryList; var ErrMsg: string): TShowHelpResult;
1106 // if ListOfNodes<>nil new nodes will be appended
1107 // if ListOfNodes=nil and nodes exists a new list will be created
1108 var
1109   i: Integer;
1110   Node: THelpNode;
1111 begin
1112   Result:=shrSuccess;
1113   ErrMsg:='';
1114   if csDesigning in ComponentState then exit;
1115   // add the registered nodes
1116   if FSearchItems<>nil then begin
1117     for i:=0 to FSearchItems.Count-1 do begin
1118       Node:=THelpDBItem(FSearchItems[i]).Node;
1119       if (Node=nil) or (not Node.ContextValid) then continue;
1120       if Node.Context<>HelpContext then continue;
1121       CreateNodeQueryListAndAdd(Node,nil,ListOfNodes,true);
1122     end;
1123   end;
1124 end;
1125 
GetNodesForPascalContextsnull1126 function THelpDatabase.GetNodesForPascalContexts(
1127   ListOfPascalHelpContextList: TList; var ListOfNodes: THelpNodeQueryList;
1128   var ErrMsg: string): TShowHelpResult;
1129 // if ListOfNodes<>nil new nodes will be appended
1130 // if ListOfNodes=nil and nodes exists a new list will be created
1131 var
1132   i: Integer;
1133   j: Integer;
1134   SearchItem: THelpDBItem;
1135   PascalContext: TPascalHelpContextList;
1136   FileItem: THelpDBISourceFile;
1137   Filename: String;
1138 begin
1139   Result:=shrSuccess;
1140   ErrMsg:='';
1141   if csDesigning in ComponentState then exit;
1142   if (ListOfPascalHelpContextList=nil) or
1143     (ListOfPascalHelpContextList.Count=0) then exit;
1144   // add the registered nodes
1145   //debugln('THelpDatabase.GetNodesForPascalContexts A ID="',ID,'" ListOfPascalHelpContextList.Count=',dbgs(ListOfPascalHelpContextList.Count));
1146   if FSearchItems<>nil then begin
1147     // check every Pascal context
1148     for j:=0 to ListOfPascalHelpContextList.Count-1 do begin
1149       PascalContext:=TPascalHelpContextList(ListOfPascalHelpContextList[j]);
1150       //debugln('THelpDatabase.GetNodesForPascalContexts A ID="',ID,'" PascalContext.Count=',dbgs(PascalContext.Count));
1151       if (PascalContext.Count>0) and
1152         (PascalContext.List[0].Descriptor=pihcFilename) then begin
1153         Filename:=PascalContext.List[0].Context;
1154         // search file item
1155         for i:=0 to FSearchItems.Count-1 do begin
1156           SearchItem:=THelpDBItem(FSearchItems[i]);
1157           if not (SearchItem is THelpDBISourceFile) then continue;
1158           FileItem:=THelpDBISourceFile(SearchItem);
1159           //debugln('THelpDatabase.GetNodesForPascalContexts B FileItem.ClassName=',FileItem.ClassName,' Filename=',Filename,' FileItem.GetFullFilename="',FileItem.GetFullFilename,'"');
1160           if (FileItem.FileMatches(Filename)) then begin
1161             CreateNodeQueryListAndAdd(FileItem.Node,PascalContext,ListOfNodes,true);
1162             {$IFNDEF DisableChecks}
1163             debugln(['THelpDatabase.GetNodesForPascalContexts C ID="',ID,'" ',i+1,'/',ListOfPascalHelpContextList.Count,' FileItem.ClassName=',FileItem.ClassName,' Filename=',Filename,' ',ListOfNodes.Count]);
1164             {$ENDIF}
1165           end;
1166         end;
1167       end;
1168     end;
1169   end;
1170 end;
1171 
THelpDatabase.GetNodesForClassnull1172 function THelpDatabase.GetNodesForClass(AClass: TClass;
1173   var ListOfNodes: THelpNodeQueryList; var ErrMsg: string): TShowHelpResult;
1174 // if ListOfNodes<>nil new nodes will be appended
1175 // if ListOfNodes=nil and nodes exists a new list will be created
1176 var
1177   i: Integer;
1178   SearchItem: THelpDBItem;
1179 begin
1180   Result:=shrSuccess;
1181   ErrMsg:='';
1182   if csDesigning in ComponentState then exit;
1183   // add the registered nodes
1184   if FSearchItems<>nil then begin
1185     for i:=0 to FSearchItems.Count-1 do begin
1186       SearchItem:=THelpDBItem(FSearchItems[i]);
1187       if not (SearchItem is THelpDBIClass) then continue;
1188       if THelpDBIClass(SearchItem).TheClass<>AClass then continue;
1189       CreateNodeQueryListAndAdd(SearchItem.Node,nil,ListOfNodes,true);
1190     end;
1191   end;
1192 end;
1193 
GetNodesForMessagenull1194 function THelpDatabase.GetNodesForMessage(const AMessage: string;
1195   MessageParts: TStrings; var ListOfNodes: THelpNodeQueryList;
1196   var ErrMsg: string): TShowHelpResult;
1197 // if ListOfNodes<>nil new nodes will be appended
1198 // if ListOfNodes=nil and nodes exists a new list will be created
1199 var
1200   i: Integer;
1201   SearchItem: THelpDBItem;
1202 begin
1203   Result:=shrSuccess;
1204   ErrMsg:='';
1205   if csDesigning in ComponentState then exit;
1206   // add the registered nodes
1207   if FSearchItems<>nil then begin
1208     for i:=0 to FSearchItems.Count-1 do begin
1209       SearchItem:=THelpDBItem(FSearchItems[i]);
1210       if not (SearchItem is THelpDBIMessage) then continue;
1211       if not THelpDBIMessage(SearchItem).MessageMatches(AMessage,MessageParts)
1212       then continue;
1213       CreateNodeQueryListAndAdd(SearchItem.Node,nil,ListOfNodes,true);
1214     end;
1215   end;
1216 end;
1217 
FindViewernull1218 function THelpDatabase.FindViewer(const MimeType: string; var ErrMsg: string;
1219   out Viewer: THelpViewer): TShowHelpResult;
1220 var
1221   Viewers: TList;
1222 begin
1223   Viewer:=nil;
1224   if Assigned(OnFindViewer) then begin
1225     Result:=OnFindViewer(Self,MimeType,ErrMsg,Viewer);
1226     exit;
1227   end;
1228 
1229   Viewers:=HelpViewers.GetViewersSupportingMimeType(MimeType);
1230   try
1231     if (Viewers=nil) or (Viewers.Count=0) then begin
1232       ErrMsg:=Format(rsHelpHelpDatabaseDidNotFoundAViewerForAHelpPageOfType,
1233                      [ID, MimeType]);
1234       Result:=shrViewerNotFound;
1235     end else begin
1236       Viewer:=THelpViewer(Viewers[0]);
1237       Result:=shrSuccess;
1238     end;
1239   finally
1240     Viewers.Free;
1241   end;
1242 end;
1243 
1244 procedure THelpDatabase.RegisterItem(NewItem: THelpDBItem);
1245 begin
1246   if NewItem=nil then
1247     raise EHelpSystemException.Create('THelpDatabase.RegisterItem NewItem=nil');
1248   if FSearchItems=nil then FSearchItems:=TFPList.Create;
1249   if FSearchItems.IndexOf(NewItem)<0 then
1250     FSearchItems.Add(NewItem)
1251   else
1252     NewItem.Free;
1253 end;
1254 
1255 procedure THelpDatabase.RegisterItemWithNode(Node: THelpNode);
1256 begin
1257   if Node=nil then
1258     raise EHelpSystemException.Create('THelpDatabase.RegisterItemWithNode Node=nil');
1259   RegisterItem(THelpDBItem.Create(Node));
1260 end;
1261 
1262 procedure THelpDatabase.RegisterFileItemWithNode(const Filename: string;
1263   Node: THelpNode);
1264 begin
1265   RegisterItem(THelpDBISourceFile.Create(Node,Filename));
1266 end;
1267 
1268 procedure THelpDatabase.UnregisterItem(AnItem: THelpDBItem);
1269 begin
1270   if FSearchItems=nil then exit;
1271   FSearchItems.Remove(AnItem);
1272 end;
1273 
1274 procedure THelpDatabase.UnregisterAllItems;
1275 var
1276   i: Integer;
1277 begin
1278   if FSearchItems=nil then exit;
1279   for i:=0 to FSearchItems.Count-1 do
1280     TObject(FSearchItems[i]).Free;
1281   FSearchItems.Clear;
1282 end;
1283 
RegisteredItemCountnull1284 function THelpDatabase.RegisteredItemCount: integer;
1285 begin
1286   if FSearchItems=nil then
1287     Result:=0
1288   else
1289     Result:=FSearchItems.Count;
1290 end;
1291 
GetRegisteredItemnull1292 function THelpDatabase.GetRegisteredItem(Index: integer): THelpDBItem;
1293 begin
1294   Result:=THelpDBItem(FSearchItems[Index]);
1295 end;
1296 
1297 procedure THelpDatabase.Load(Storage: TConfigStorage);
1298 begin
1299 
1300 end;
1301 
1302 procedure THelpDatabase.Save(Storage: TConfigStorage);
1303 begin
1304 
1305 end;
1306 
GetLocalizedNamenull1307 function THelpDatabase.GetLocalizedName: string;
1308 begin
1309   Result:=ID;
1310 end;
1311 
1312 procedure THelpDatabase.Reference;
1313 begin
1314   inc(FRefCount);
1315 end;
1316 
1317 procedure THelpDatabase.Release;
1318 begin
1319   if FRefCount=0 then
1320     raise EHelpSystemException.Create('THelpDatabase.Release');
1321   dec(FRefCount);
1322   if FRefCount=0 then Free;
1323 end;
1324 
1325 { THelpDatabases }
1326 
THelpDatabases.GetItemsnull1327 function THelpDatabases.GetItems(Index: integer): THelpDatabase;
1328 begin
1329   Result:=THelpDatabase(FItems[Index]);
1330 end;
1331 
1332 procedure THelpDatabases.DoRegisterDatabase(ADatabase: THelpDatabase);
1333 begin
1334   ADatabase.Reference;
1335   if FItems=nil then FItems:=TFPList.Create;
1336   FItems.Add(ADatabase);
1337 end;
1338 
1339 procedure THelpDatabases.DoUnregisterDatabase(ADatabase: THelpDatabase);
1340 begin
1341   if FItems<>nil then
1342     FItems.Remove(ADatabase);
1343   ADatabase.Release;
1344 end;
1345 
1346 constructor THelpDatabases.Create;
1347 begin
1348 
1349 end;
1350 
1351 destructor THelpDatabases.Destroy;
1352 begin
1353   while (Count>0) do Items[Count-1].UnregisterSelf;
1354   FItems.Free;
1355   FHelpDBClasses.Free;
1356   inherited Destroy;
1357 end;
1358 
THelpDatabases.Countnull1359 function THelpDatabases.Count: integer;
1360 begin
1361   if FItems=nil then
1362     Result:=0
1363   else
1364     Result:=FItems.Count;
1365 end;
1366 
THelpDatabases.FindDatabasenull1367 function THelpDatabases.FindDatabase(ID: THelpDatabaseID): THelpDatabase;
1368 var
1369   Index: LongInt;
1370 begin
1371   Index:=IndexOf(ID);
1372   if Index>=0 then
1373     Result:=Items[Index]
1374   else
1375     Result:=nil;
1376 end;
1377 
THelpDatabases.GetDatabasenull1378 function THelpDatabases.GetDatabase(ID: THelpDatabaseID; var HelpDB: THelpDatabase;
1379   var HelpResult: TShowHelpResult; var ErrMsg: string): boolean;
1380 begin
1381   HelpDB:=FindDatabase(ID);
1382   if HelpDB=nil then begin
1383     Result:=false;
1384     HelpResult:=shrDatabaseNotFound;
1385     ErrMsg:=Format(rsHelpHelpDatabaseNotFound, [ID]);
1386   end else begin
1387     HelpResult:=shrSuccess;
1388     Result:=true;
1389     ErrMsg:='';
1390   end;
1391 end;
1392 
THelpDatabases.IndexOfnull1393 function THelpDatabases.IndexOf(ID: THelpDatabaseID): integer;
1394 begin
1395   Result:=Count-1;
1396   while (Result>=0) and (UTF8CompareText(ID,Items[Result].ID)<>0) do
1397     dec(Result);
1398 end;
1399 
CreateUniqueDatabaseIDnull1400 function THelpDatabases.CreateUniqueDatabaseID(
1401   const WishID: string): THelpDatabaseID;
1402 var
1403   i: Integer;
1404 begin
1405   if (WishID<>'') and (FindDatabase(WishID)=nil) then begin
1406     Result:=WishID;
1407   end else begin
1408     i:=1;
1409     repeat
1410       Result:=WishID+IntToStr(i);
1411       if FindDatabase(Result)=nil then exit;
1412       inc(i);
1413     until false;
1414   end;
1415 end;
1416 
THelpDatabases.CreateHelpDatabasenull1417 function THelpDatabases.CreateHelpDatabase(const WishID: string;
1418   HelpDataBaseClass: THelpDatabaseClass; AutoRegister: boolean): THelpDatabase;
1419 begin
1420   Result:=HelpDataBaseClass.Create(nil);
1421   Result.FID:=CreateUniqueDatabaseID(WishID);
1422   if AutoRegister then Result.RegisterSelf;
1423 end;
1424 
ShowTableOfContentsnull1425 function THelpDatabases.ShowTableOfContents(var ErrMsg: string
1426   ): TShowHelpResult;
1427 begin
1428   Result:=shrHelpNotFound;
1429   ErrMsg:='THelpDatabases.ShowTableOfContents not implemented';
1430   // ToDo
1431 end;
1432 
1433 procedure THelpDatabases.ShowError(ShowResult: TShowHelpResult;
1434   const ErrMsg: string);
1435 var
1436   ErrorCaption: String;
1437 begin
1438   case ShowResult of
1439   shrNone: ErrorCaption:=rsHelpError;
1440   shrSuccess: exit;
1441   shrCancel: exit;
1442   shrDatabaseNotFound: ErrorCaption:=rsHelpDatabaseNotFound;
1443   shrContextNotFound: ErrorCaption:=rsHelpContextNotFound;
1444   shrViewerNotFound: ErrorCaption:=rsHelpViewerNotFound;
1445   shrHelpNotFound: ErrorCaption:=rsHelpNotFound;
1446   shrViewerError: ErrorCaption:=rsHelpViewerError;
1447   shrSelectorError: ErrorCaption:=rsHelpSelectorError;
1448   else ErrorCaption:=rsUnknownErrorPleaseReportThisBug;
1449   end;
1450   MessageDlg(ErrorCaption,ErrMsg,mtError,[mbCancel],0);
1451 end;
1452 
GetBaseURLForBasePathObjectnull1453 function THelpDatabases.GetBaseURLForBasePathObject(BasePathObject: TObject
1454   ): string;
1455 begin
1456   // this method will be overriden by the IDE
1457   // provide some useful defaults:
1458   if (BasePathObject is THelpBaseURLObject) then begin
1459     Result:=THelpBaseURLObject(BasePathObject).BaseURL;
1460   end else begin
1461     // otherwise fetch a filename
1462     Result:=GetBaseDirectoryForBasePathObject(BasePathObject);
1463     if Result='' then exit;
1464     Result:=FilenameToURL(Result);
1465   end;
1466   Result:=AppendURLPathDelim(Result);
1467 end;
1468 
THelpDatabases.GetBaseDirectoryForBasePathObjectnull1469 function THelpDatabases.GetBaseDirectoryForBasePathObject(
1470   BasePathObject: TObject): string;
1471 // returns the base file directory of the BasePathObject
1472 begin
1473   if (BasePathObject is THelpBaseURLObject) then begin
1474     Result:=THelpBaseURLObject(BasePathObject).BaseURL;
1475     if Result='' then exit;
1476     if not IsFileURL(Result) then begin
1477       Result:='';
1478       exit;
1479     end;
1480     Result:=ExtractURLPath(Result);
1481   end else if (BasePathObject is THelpBasePathObject) then
1482     Result:=THelpBasePathObject(BasePathObject).BasePath
1483   else
1484     Result:='';
1485   Result:=AppendURLPathDelim(Result);
1486 end;
1487 
THelpDatabases.FindViewernull1488 function THelpDatabases.FindViewer(const MimeType: string; var ErrMsg: string;
1489   var Viewer: THelpViewer): TShowHelpResult;
1490 var
1491   Viewers: TList;
1492 begin
1493   Viewer:=nil;
1494   Viewers:=HelpViewers.GetViewersSupportingMimeType(MimeType);
1495   try
1496     if (Viewers=nil) or (Viewers.Count=0) then begin
1497       ErrMsg:=Format(rsHelpThereIsNoViewerForHelpType, [MimeType]);
1498       Result:=shrViewerNotFound;
1499     end else begin
1500       Viewer:=THelpViewer(Viewers[0]);
1501       Result:=shrSuccess;
1502     end;
1503   finally
1504     Viewers.Free;
1505   end;
1506 end;
1507 
THelpDatabases.SubstituteMacrosnull1508 function THelpDatabases.SubstituteMacros(var s: string): boolean;
1509 begin
1510   Result:=true;
1511 end;
1512 
THelpDatabases.ShowHelpForNodesnull1513 function THelpDatabases.ShowHelpForNodes(Query: THelpQuery;
1514   Nodes: THelpNodeQueryList; var ErrMsg: string): TShowHelpResult;
1515 var
1516   NodeQuery: THelpNodeQuery;
1517   Node: THelpNode;
1518 begin
1519   // check if several nodes found
1520   //debugln('THelpDatabases.ShowHelpForNodes A Nodes.Count=',dbgs(Nodes.Count));
1521   NodeQuery:=nil;
1522   if (Nodes.Count>1) then begin
1523     Result:=ShowHelpSelector(Query,Nodes,ErrMsg,NodeQuery);
1524     if Result<>shrSuccess then exit;
1525     if NodeQuery=nil then exit;
1526   end else begin
1527     NodeQuery:=Nodes[0];
1528   end;
1529 
1530   // show node
1531   Node:=NodeQuery.Node;
1532   if Node.Owner=nil then begin
1533     Result:=shrDatabaseNotFound;
1534     ErrMsg:=Format(rsHelpHelpNodeHasNoHelpDatabase, [Node.Title]);
1535     exit;
1536   end;
1537   {$IFDEF VerboseLCLHelp}
1538   debugln(['THelpDatabases.ShowHelpForNodes Node.Owner=',DbgSName(Node.Owner),' UnitName=',Node.Owner.UnitName]);
1539   {$ENDIF}
1540   Result:=Node.Owner.ShowHelp(Query,nil,Node,NodeQuery.QueryItem,ErrMsg);
1541 end;
1542 
ShowHelpForQuerynull1543 function THelpDatabases.ShowHelpForQuery(Query: THelpQuery;
1544   AutoFreeQuery: boolean; var ErrMsg: string): TShowHelpResult;
1545 begin
1546   try
1547     // descendants first
1548     if Query is THelpQueryPascalContexts then
1549       Result:=ShowHelpForPascalContexts(THelpQueryPascalContexts(Query),ErrMsg)
1550     else if Query is THelpQueryTOC then
1551       Result:=ShowTableOfContents(ErrMsg)
1552     else if Query is THelpQueryContext then
1553       Result:=ShowHelpForContext(THelpQueryContext(Query),ErrMsg)
1554     else if Query is THelpQueryKeyword then
1555       Result:=ShowHelpForKeyword(THelpQueryKeyword(Query),ErrMsg)
1556     else if Query is THelpQueryDirective then
1557       Result:=ShowHelpForDirective(THelpQueryDirective(Query),ErrMsg)
1558     else if Query is THelpQuerySourcePosition then
1559       Result:=ShowHelpForSourcePosition(THelpQuerySourcePosition(Query),ErrMsg)
1560     else if Query is THelpQueryMessage then
1561       Result:=ShowHelpForMessageLine(THelpQueryMessage(Query),ErrMsg)
1562     else if Query is THelpQueryClass then
1563       Result:=ShowHelpForClass(THelpQueryClass(Query),ErrMsg)
1564     else
1565       Result:=shrContextNotFound;
1566   finally
1567     if AutoFreeQuery then Query.Free;
1568   end;
1569 end;
1570 
ShowHelpForContextnull1571 function THelpDatabases.ShowHelpForContext(Query: THelpQueryContext;
1572   var ErrMsg: string): TShowHelpResult;
1573 var
1574   Nodes: THelpNodeQueryList;
1575   HelpDB: THelpDatabase;
1576 begin
1577   ErrMsg:='';
1578   Result:=shrHelpNotFound;
1579 
1580   // search node
1581   Nodes:=nil;
1582   try
1583     if Query.HelpDatabaseID<>'' then begin
1584       HelpDB:=nil;
1585       if not GetDatabase(Query.HelpDatabaseID,HelpDB,Result,ErrMsg) then exit;
1586       Result:=HelpDB.GetNodesForContext(Query.Context,Nodes,ErrMsg);
1587       if Result<>shrSuccess then exit;
1588     end else begin
1589       Result:=GetNodesForContext(Query.Context,Nodes,ErrMsg);
1590       if Result<>shrSuccess then exit;
1591     end;
1592 
1593     // check if at least one node found
1594     if (Nodes=nil) or (Nodes.Count=0) then begin
1595       Result:=shrContextNotFound;
1596       if Query.HelpDatabaseID<>'' then
1597         ErrMsg:=Format(rsHelpHelpContextNotFoundInDatabase,
1598                        [IntToStr(Query.Context), Query.HelpDatabaseID])
1599       else
1600         ErrMsg:=Format(rsHelpHelpContextNotFound, [IntToStr(Query.Context)]);
1601       exit;
1602     end;
1603 
1604     Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
1605   finally
1606     Nodes.Free;
1607   end;
1608 end;
1609 
ShowHelpForKeywordnull1610 function THelpDatabases.ShowHelpForKeyword(Query: THelpQueryKeyword;
1611   var ErrMsg: string): TShowHelpResult;
1612 var
1613   Nodes: THelpNodeQueryList;
1614   HelpDB: THelpDatabase;
1615 begin
1616   ErrMsg:='';
1617   Result:=shrHelpNotFound;
1618 
1619   // search node
1620   Nodes:=nil;
1621   try
1622     if Query.HelpDatabaseID<>'' then begin
1623       HelpDB:=nil;
1624       if not GetDatabase(Query.HelpDatabaseID,HelpDB,Result,ErrMsg) then exit;
1625       Result:=HelpDB.GetNodesForKeyword(Query.Keyword,Nodes,ErrMsg);
1626       if Result<>shrSuccess then exit;
1627     end else begin
1628       Result:=GetNodesForKeyword(Query.Keyword,Nodes,ErrMsg);
1629       if Result<>shrSuccess then exit;
1630     end;
1631 
1632     // check if at least one node found
1633     if (Nodes=nil) or (Nodes.Count=0) then begin
1634       Result:=shrContextNotFound;
1635       if Query.HelpDatabaseID<>'' then
1636         ErrMsg:=Format(rsHelpHelpKeywordNotFoundInDatabase, [Query.Keyword, Query.HelpDatabaseID])
1637       else
1638         ErrMsg:=Format(rsHelpHelpKeywordNotFound, [Query.Keyword]);
1639       exit;
1640     end;
1641 
1642     Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
1643   finally
1644     Nodes.Free;
1645   end;
1646 end;
1647 
ShowHelpForDirectivenull1648 function THelpDatabases.ShowHelpForDirective(Query: THelpQueryDirective;
1649   var ErrMsg: string): TShowHelpResult;
1650 var
1651   Nodes: THelpNodeQueryList;
1652   HelpDB: THelpDatabase;
1653 begin
1654   ErrMsg:='';
1655   Result:=shrHelpNotFound;
1656 
1657   // search node
1658   Nodes:=nil;
1659   try
1660     if Query.HelpDatabaseID<>'' then begin
1661       HelpDB:=nil;
1662       if not GetDatabase(Query.HelpDatabaseID,HelpDB,Result,ErrMsg) then exit;
1663       Result:=HelpDB.GetNodesForKeyword(Query.Directive,Nodes,ErrMsg);
1664       if Result<>shrSuccess then exit;
1665     end else begin
1666       Result:=GetNodesForDirective(Query.Directive,Nodes,ErrMsg);
1667       if Result<>shrSuccess then exit;
1668     end;
1669 
1670     // check if at least one node found
1671     if (Nodes=nil) or (Nodes.Count=0) then begin
1672       Result:=shrContextNotFound;
1673       if Query.HelpDatabaseID<>'' then
1674         ErrMsg:=Format(rsHelpHelpForDirectiveNotFoundInDatabase, [Query.Directive, Query.HelpDatabaseID])
1675       else
1676         ErrMsg:=Format(rsHelpHelpForDirectiveNotFound, [Query.Directive]);
1677       exit;
1678     end;
1679 
1680     Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
1681   finally
1682     Nodes.Free;
1683   end;
1684 end;
1685 
ShowHelpForPascalContextsnull1686 function THelpDatabases.ShowHelpForPascalContexts(
1687   Query: THelpQueryPascalContexts; var ErrMsg: string): TShowHelpResult;
1688 var
1689   Nodes: THelpNodeQueryList;
1690 begin
1691   ErrMsg:='';
1692   Result:=shrSuccess;
1693 
1694   {$IFDEF VerboseLCLHelp}
1695   debugln('THelpDatabases.ShowHelpForPascalContexts A Count=',dbgs(Query.ListOfPascalHelpContextList.Count));
1696   {$ENDIF}
1697   // search node
1698   Nodes:=nil;
1699   try
1700     Result:=GetNodesForPascalContexts(Query.ListOfPascalHelpContextList,Nodes,
1701                                       ErrMsg);
1702     if Result<>shrSuccess then exit;
1703 
1704     // check if at least one node found
1705     if (Nodes=nil) or (Nodes.Count=0) then begin
1706       Result:=shrHelpNotFound;
1707       ErrMsg:=format(rsHelpNoHelpFoundForSource,
1708         [Query.SourcePosition.y, Query.SourcePosition.x, Query.Filename]);
1709       exit;
1710     end;
1711     {$IFDEF VerboseLCLHelp}
1712     debugln('THelpDatabases.ShowHelpForPascalContexts B Nodes.Count=',dbgs(Nodes.Count));
1713     {$ENDIF}
1714 
1715     Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
1716   finally
1717     Nodes.Free;
1718   end;
1719 end;
1720 
THelpDatabases.ShowHelpForSourcePositionnull1721 function THelpDatabases.ShowHelpForSourcePosition(
1722   Query: THelpQuerySourcePosition; var ErrMsg: string): TShowHelpResult;
1723 begin
1724   Result:=shrHelpNotFound;
1725   ErrMsg:='THelpDatabases.ShowHelpForPascalSource not implemented';
1726 end;
1727 
ShowHelpForMessageLinenull1728 function THelpDatabases.ShowHelpForMessageLine(Query: THelpQueryMessage;
1729   var ErrMsg: string): TShowHelpResult;
1730 var
1731   Nodes: THelpNodeQueryList;
1732 begin
1733   ErrMsg:='';
1734   Result:=shrSuccess;
1735 
1736   {$IFDEF VerboseLCLHelp}
1737   debugln('THelpDatabases.ShowHelpForMessageLine A Msg="',Query.WholeMessage,'"');
1738   {$ENDIF}
1739   // search node
1740   Nodes:=nil;
1741   try
1742     Result:=GetNodesForMessage(Query.WholeMessage,Query.MessageParts,Nodes,
1743                                ErrMsg);
1744     if Result<>shrSuccess then exit;
1745 
1746     // check if at least one node found
1747     if (Nodes=nil) or (Nodes.Count=0) then begin
1748       Result:=shrHelpNotFound;
1749       ErrMsg:='No help found for "'+Query.WholeMessage+'"';
1750       exit;
1751     end;
1752 
1753     Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
1754   finally
1755     Nodes.Free;
1756   end;
1757 end;
1758 
ShowHelpForClassnull1759 function THelpDatabases.ShowHelpForClass(Query: THelpQueryClass;
1760   var ErrMsg: string): TShowHelpResult;
1761 var
1762   Nodes: THelpNodeQueryList;
1763 begin
1764   ErrMsg:='';
1765   Result:=shrSuccess;
1766 
1767   {$IFDEF VerboseLCLHelp}
1768   debugln('THelpDatabases.ShowHelpForClass A ',Query.TheClass.ClassName);
1769   {$ENDIF}
1770   // search node
1771   Nodes:=nil;
1772   try
1773     Result:=GetNodesForClass(Query.TheClass,Nodes,ErrMsg);
1774     if Result<>shrSuccess then exit;
1775 
1776     // check if at least one node found
1777     if (Nodes=nil) or (Nodes.Count=0) then begin
1778       // no node found for the class is not a bug
1779       Result:=shrSuccess;
1780       ErrMsg:='';
1781       exit;
1782     end;
1783 
1784     Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
1785   finally
1786     Nodes.Free;
1787   end;
1788 end;
1789 
THelpDatabases.ShowHelpFilenull1790 function THelpDatabases.ShowHelpFile(const Filename, Title, MimeType: string;
1791   var ErrMsg: string): TShowHelpResult;
1792 begin
1793   Result:=ShowHelp(FilenameToURL(Filename),Title,MimeType,ErrMsg);
1794 end;
1795 
ShowHelpnull1796 function THelpDatabases.ShowHelp(const URL, Title, MimeType: string;
1797   var ErrMsg: string): TShowHelpResult;
1798 var
1799   Viewer: THelpViewer;
1800   Node: THelpNode;
1801 begin
1802   ErrMsg:='';
1803   // get a viewer for this file
1804   Result:=FindViewer(MimeType,ErrMsg,Viewer);
1805   if Result<>shrSuccess then exit;
1806 
1807   // call viewer
1808   Node:=nil;
1809   try
1810     Node:=THelpNode.CreateURL(nil,Title,URL);
1811     Result:=Viewer.ShowNode(Node,ErrMsg);
1812   finally
1813     Node.Free;
1814   end;
1815 end;
1816 
GetNodesForKeywordnull1817 function THelpDatabases.GetNodesForKeyword(const HelpKeyword: string;
1818   var ListOfNodes: THelpNodeQueryList; var ErrMsg: string): TShowHelpResult;
1819 // if ListOfNodes<>nil then new nodes will be appended
1820 // if ListOfNodes=nil and nodes exists a new list will be created
1821 var
1822   i: Integer;
1823 begin
1824   ErrMsg:='';
1825   for i:=Count-1 downto 0 do begin
1826     Result:=Items[i].GetNodesForKeyword(HelpKeyword,ListOfNodes,ErrMsg);
1827     if Result=shrCancel then exit;
1828   end;
1829   Result:=shrSuccess;
1830 end;
1831 
THelpDatabases.GetNodesForDirectivenull1832 function THelpDatabases.GetNodesForDirective(const HelpDirective: string;
1833   var ListOfNodes: THelpNodeQueryList; var ErrMsg: string): TShowHelpResult;
1834 // if ListOfNodes<>nil then new nodes will be appended
1835 // if ListOfNodes=nil and nodes exists a new list will be created
1836 var
1837   i: Integer;
1838 begin
1839   ErrMsg:='';
1840   for i:=Count-1 downto 0 do begin
1841     Result:=Items[i].GetNodesForDirective(HelpDirective,ListOfNodes,ErrMsg);
1842     if Result=shrCancel then exit;
1843   end;
1844   Result:=shrSuccess;
1845 end;
1846 
GetNodesForContextnull1847 function THelpDatabases.GetNodesForContext(HelpContext: THelpContext;
1848   var ListOfNodes: THelpNodeQueryList; var ErrMsg: string): TShowHelpResult;
1849 // if ListOfNodes<>nil then new nodes will be appended
1850 // if ListOfNodes=nil and nodes exists a new list will be created
1851 var
1852   i: Integer;
1853 begin
1854   ErrMsg:='';
1855   for i:=Count-1 downto 0 do begin
1856     Result:=Items[i].GetNodesForContext(HelpContext,ListOfNodes,ErrMsg);
1857     if Result=shrCancel then exit;
1858   end;
1859   Result:=shrSuccess;
1860 end;
1861 
GetNodesForPascalContextsnull1862 function THelpDatabases.GetNodesForPascalContexts(
1863   ListOfPascalHelpContextList: TList; var ListOfNodes: THelpNodeQueryList;
1864   var ErrMsg: string): TShowHelpResult;
1865 // if ListOfNodes<>nil then new nodes will be appended
1866 // if ListOfNodes=nil and nodes exists a new list will be created
1867 var
1868   i: Integer;
1869 begin
1870   ErrMsg:='';
1871   for i:=Count-1 downto 0 do begin
1872     Result:=Items[i].GetNodesForPascalContexts(ListOfPascalHelpContextList,
1873                                                ListOfNodes,ErrMsg);
1874     if Result=shrCancel then exit;
1875   end;
1876   Result:=shrSuccess;
1877 end;
1878 
THelpDatabases.GetNodesForClassnull1879 function THelpDatabases.GetNodesForClass(AClass: TClass;
1880   var ListOfNodes: THelpNodeQueryList; var ErrMsg: string): TShowHelpResult;
1881 // if ListOfNodes<>nil then new nodes will be appended
1882 // if ListOfNodes=nil and nodes exists a new list will be created
1883 var
1884   i: Integer;
1885 begin
1886   ErrMsg:='';
1887   for i:=Count-1 downto 0 do begin
1888     Result:=Items[i].GetNodesForClass(AClass,ListOfNodes,ErrMsg);
1889     if Result=shrCancel then exit;
1890   end;
1891   Result:=shrSuccess;
1892 end;
1893 
THelpDatabases.GetNodesForMessagenull1894 function THelpDatabases.GetNodesForMessage(const AMessage: string;
1895   MessageParts: TStrings; var ListOfNodes: THelpNodeQueryList;
1896   var ErrMsg: string): TShowHelpResult;
1897 // if ListOfNodes<>nil then new nodes will be appended
1898 // if ListOfNodes=nil and nodes exists a new list will be created
1899 var
1900   i: Integer;
1901 begin
1902   ErrMsg:='';
1903   for i:=Count-1 downto 0 do begin
1904     Result:=Items[i].GetNodesForMessage(AMessage,MessageParts,ListOfNodes,
1905                                         ErrMsg);
1906     if Result=shrCancel then exit;
1907   end;
1908   Result:=shrSuccess;
1909 end;
1910 
ShowHelpSelectornull1911 function THelpDatabases.ShowHelpSelector(Query: THelpQuery;
1912   Nodes: THelpNodeQueryList; var ErrMsg: string;
1913   var Selection: THelpNodeQuery): TShowHelpResult;
1914 // to override
1915 // default is to always take the first node
1916 begin
1917   if (Nodes=nil) or (Nodes.Count=0) then begin
1918     Result:=shrSelectorError;
1919     Selection:=nil;
1920     ErrMsg:=rsHelpNoHelpNodesAvailable;
1921   end else begin
1922     Selection:=THelpNodeQuery(Nodes[0]);
1923     Result:=shrSuccess;
1924     ErrMsg:='';
1925   end;
1926 end;
1927 
1928 procedure THelpDatabases.RegisterHelpDatabaseClass(NewHelpDB: THelpDatabaseClass);
1929 begin
1930   if FHelpDBClasses=nil then FHelpDBClasses:=TFPList.Create;
1931   if FHelpDBClasses.IndexOf(NewHelpDB)<0 then
1932     FHelpDBClasses.Add(NewHelpDB);
1933 end;
1934 
1935 procedure THelpDatabases.UnregisterHelpDatabaseClass(
1936   AHelpDB: THelpDatabaseClass);
1937 begin
1938   if FHelpDBClasses=nil then exit;
1939   FHelpDBClasses.Remove(AHelpDB);
1940 end;
1941 
HelpDatabaseClassCountnull1942 function THelpDatabases.HelpDatabaseClassCount: integer;
1943 begin
1944   if FHelpDBClasses=nil then
1945     Result:=0
1946   else
1947     Result:=FHelpDBClasses.Count;
1948 end;
1949 
THelpDatabases.GetHelpDatabaseClassnull1950 function THelpDatabases.GetHelpDatabaseClass(Index: integer
1951   ): THelpDatabaseClass;
1952 begin
1953   Result:=THelpDatabaseClass(FHelpDBClasses[Index]);
1954 end;
1955 
1956 procedure THelpDatabases.Load(Storage: TConfigStorage);
1957 var
1958   i: Integer;
1959   HelpDB: THelpDatabase;
1960   Path: String;
1961 begin
1962   for i:=0 to Count-1 do begin
1963     HelpDB:=Items[i];
1964     Path:=HelpDB.ID;
1965     if not IsValidIdent(Path) then continue;
1966     Storage.AppendBasePath(Path);
1967     try
1968       HelpDB.Load(Storage);
1969     finally
1970       Storage.UndoAppendBasePath;
1971     end;
1972   end;
1973 end;
1974 
1975 procedure THelpDatabases.Save(Storage: TConfigStorage);
1976 var
1977   i: Integer;
1978   HelpDB: THelpDatabase;
1979   Path: String;
1980 begin
1981   for i:=0 to Count-1 do begin
1982     HelpDB:=Items[i];
1983     Path:=HelpDB.ID;
1984     if not IsValidIdent(Path) then continue;
1985     Storage.AppendBasePath(Path);
1986     try
1987       HelpDB.Save(Storage);
1988     finally
1989       Storage.UndoAppendBasePath;
1990     end;
1991   end;
1992 end;
1993 
1994 { THelpViewers }
1995 
THelpViewers.GetItemsnull1996 function THelpViewers.GetItems(Index: integer): THelpViewer;
1997 begin
1998   Result:=THelpViewer(FItems[Index]);
1999 end;
2000 
2001 constructor THelpViewers.Create;
2002 begin
2003   FItems:=TFPList.Create;
2004 end;
2005 
2006 destructor THelpViewers.Destroy;
2007 begin
2008   FDestroying:=true;
2009   Clear;
2010   FreeAndNil(fItems);
2011   inherited Destroy;
2012 end;
2013 
2014 procedure THelpViewers.Clear;
2015 var
2016   i: Integer;
2017 begin
2018   i:=Count-1;
2019   while (i>=0) do begin
2020     if i<Count then begin
2021       if Items[i].Owner=nil then begin
2022         Items[i].Free;
2023         if fItems=nil then exit;
2024       end;
2025       if i<Count then
2026         FItems[i]:=nil;
2027     end;
2028     dec(i);
2029   end;
2030   FItems.Clear;
2031 end;
2032 
THelpViewers.Countnull2033 function THelpViewers.Count: integer;
2034 begin
2035   if fItems<>nil then
2036     Result:=FItems.Count
2037   else
2038     Result:=0;
2039 end;
2040 
THelpViewers.GetViewersSupportingMimeTypenull2041 function THelpViewers.GetViewersSupportingMimeType(
2042   const MimeType: string): TList;
2043 var
2044   i: Integer;
2045 begin
2046   Result:=nil;
2047   // LIFO: last registered, first shown
2048   for i:=Count-1 downto 0 do
2049     if Items[i].SupportsMimeType(MimeType) then begin
2050       if Result=nil then Result:=TList.Create;
2051       Result.Add(Items[i]);
2052     end;
2053 end;
2054 
2055 procedure THelpViewers.RegisterViewer(AHelpViewer: THelpViewer);
2056 begin
2057   FItems.Add(AHelpViewer);
2058 end;
2059 
2060 procedure THelpViewers.UnregisterViewer(AHelpViewer: THelpViewer);
2061 begin
2062   if FDestroying then exit;
2063   FItems.Remove(AHelpViewer);
2064 end;
2065 
2066 procedure THelpViewers.Load(Storage: TConfigStorage);
2067 var
2068   i: Integer;
2069   Viewer: THelpViewer;
2070   Path: String;
2071 begin
2072   for i:=0 to Count-1 do begin
2073     Viewer:=Items[i];
2074     Path:=Viewer.StorageName;
2075     if not IsValidIdent(Path) then continue;
2076     Storage.AppendBasePath(Path);
2077     try
2078       Viewer.Load(Storage);
2079     finally
2080       Storage.UndoAppendBasePath;
2081     end;
2082   end;
2083 end;
2084 
2085 procedure THelpViewers.Save(Storage: TConfigStorage);
2086 var
2087   i: Integer;
2088   Viewer: THelpViewer;
2089   Path: String;
2090 begin
2091   for i:=0 to Count-1 do begin
2092     Viewer:=Items[i];
2093     Path:=Viewer.StorageName;
2094     if not IsValidIdent(Path) then continue;
2095     Storage.AppendBasePath(Path);
2096     try
2097       Viewer.Save(Storage);
2098     finally
2099       Storage.UndoAppendBasePath;
2100     end;
2101   end;
2102 end;
2103 
IndexOfnull2104 function THelpViewers.IndexOf(AHelpViewer: THelpViewer): integer;
2105 begin
2106   Result:=FItems.IndexOf(AHelpViewer);
2107 end;
2108 
2109 { THelpViewer }
2110 
2111 procedure THelpViewer.SetAutoRegister(const AValue: boolean);
2112 begin
2113   if FAutoRegister=AValue then exit;
2114   FAutoRegister:=AValue;
2115   if not (csDesigning in ComponentState) then begin
2116     if FAutoRegister then begin
2117       RegisterSelf;
2118     end else begin
2119       UnregisterSelf;
2120     end;
2121   end;
2122 end;
2123 
2124 procedure THelpViewer.SetSupportedMimeTypes(List: TStrings);
2125 begin
2126   if FSupportedMimeTypes<>nil then FSupportedMimeTypes.Free;
2127   FSupportedMimeTypes:=nil;
2128 end;
2129 
2130 procedure THelpViewer.AddSupportedMimeType(const AMimeType: string);
2131 begin
2132   if FSupportedMimeTypes=nil then FSupportedMimeTypes:=TStringList.Create;
2133   FSupportedMimeTypes.Add(AMimeType);
2134 end;
2135 
2136 constructor THelpViewer.Create(TheOwner: TComponent);
2137 begin
2138   inherited Create(TheOwner);
2139   FStorageName:=ClassName;
2140 end;
2141 
2142 destructor THelpViewer.Destroy;
2143 begin
2144   UnregisterSelf;
2145   FreeAndNil(FSupportedMimeTypes);
2146   inherited Destroy;
2147 end;
2148 
SupportsTableOfContentsnull2149 function THelpViewer.SupportsTableOfContents: boolean;
2150 begin
2151   Result:=false;
2152 end;
2153 
2154 procedure THelpViewer.ShowTableOfContents(Node: THelpNode);
2155 begin
2156   raise EHelpSystemException.Create('THelpViewer.ShowTableOfContents not implemented');
2157 end;
2158 
SupportsMimeTypenull2159 function THelpViewer.SupportsMimeType(const AMimeType: string): boolean;
2160 begin
2161   Result:=false;
2162   if FSupportedMimeTypes<>nil then
2163     Result:=(FSupportedMimeTypes.IndexOf(AMimeType)>=0);
2164 end;
2165 
THelpViewer.ShowNodenull2166 function THelpViewer.ShowNode(Node: THelpNode; var ErrMsg: string
2167   ): TShowHelpResult;
2168 begin
2169   // for descendents to override
2170   Result:=shrViewerError;
2171   ErrMsg:='THelpViewer.ShowNode not implemented for this help type';
2172 end;
2173 
2174 procedure THelpViewer.Hide;
2175 begin
2176   // override this
2177 end;
2178 
2179 procedure THelpViewer.Assign(Source: TPersistent);
2180 begin
2181   if Source is THelpViewer then begin
2182 
2183   end;
2184   inherited Assign(Source);
2185 end;
2186 
2187 procedure THelpViewer.Load(Storage: TConfigStorage);
2188 begin
2189 
2190 end;
2191 
2192 procedure THelpViewer.Save(Storage: TConfigStorage);
2193 begin
2194 
2195 end;
2196 
THelpViewer.GetLocalizedNamenull2197 function THelpViewer.GetLocalizedName: string;
2198 begin
2199   Result:=StorageName;
2200 end;
2201 
2202 procedure THelpViewer.RegisterSelf;
2203 begin
2204   if (HelpViewers<>nil) and (HelpViewers.IndexOf(Self)>=0) then
2205     raise EHelpSystemException.Create('help viewer is already registered');
2206   CreateLCLHelpSystem;
2207   HelpViewers.RegisterViewer(Self);
2208 end;
2209 
2210 procedure THelpViewer.UnregisterSelf;
2211 begin
2212   if (HelpViewers=nil) or (HelpViewers.IndexOf(Self)<0) then exit;
2213   HelpViewers.UnregisterViewer(Self);
2214   FreeUnusedLCLHelpSystem;
2215 end;
2216 
2217 { THelpNode }
2218 
2219 constructor THelpNode.Create(TheOwner: THelpDatabase; Node: THelpNode);
2220 begin
2221   FOwner:=TheOwner;
2222   Assign(Node);
2223 end;
2224 
2225 constructor THelpNode.Create(TheOwner: THelpDatabase; const TheTitle,
2226   TheURL, TheID: string; TheContext: THelpContext);
2227 begin
2228   FOwner:=TheOwner;
2229   FHelpType:=hntURLIDContext;
2230   FTitle:=TheTitle;
2231   FURL:=TheURL;
2232   FID:=TheID;
2233   FContext:=TheContext;
2234 end;
2235 
2236 constructor THelpNode.CreateURL(TheOwner: THelpDatabase; const TheTitle,
2237   TheURL: string);
2238 begin
2239   FOwner:=TheOwner;
2240   FHelpType:=hntURL;
2241   FTitle:=TheTitle;
2242   FURL:=TheURL;
2243 end;
2244 
2245 constructor THelpNode.CreateID(TheOwner: THelpDatabase;
2246   const TheTitle, TheID: string);
2247 begin
2248   FOwner:=TheOwner;
2249   FHelpType:=hntID;
2250   FTitle:=TheTitle;
2251   FID:=TheID;
2252 end;
2253 
2254 constructor THelpNode.CreateURLID(TheOwner: THelpDatabase;
2255   const TheTitle, TheURL, TheID: string);
2256 begin
2257   FOwner:=TheOwner;
2258   FHelpType:=hntURLID;
2259   FTitle:=TheTitle;
2260   FURL:=TheURL;
2261   FID:=TheID;
2262 end;
2263 
2264 constructor THelpNode.CreateContext(TheOwner: THelpDatabase;
2265   const TheTitle: string; TheContext: THelpContext);
2266 begin
2267   FOwner:=TheOwner;
2268   FHelpType:=hntContext;
2269   FTitle:=TheTitle;
2270   FContext:=TheContext;
2271 end;
2272 
2273 constructor THelpNode.CreateURLContext(TheOwner: THelpDatabase; const TheTitle,
2274   TheURL: string; TheContext: THelpContext);
2275 begin
2276   FOwner:=TheOwner;
2277   FHelpType:=hntURLContext;
2278   FTitle:=TheTitle;
2279   FURL:=TheURL;
2280   FContext:=TheContext;
2281 end;
2282 
URLValidnull2283 function THelpNode.URLValid: boolean;
2284 begin
2285   Result:=FHelpType in [hntURL,hntURLIDContext,hntURLID,hntURLContext];
2286 end;
2287 
THelpNode.IDValidnull2288 function THelpNode.IDValid: boolean;
2289 begin
2290   Result:=FHelpType in [hntURLIDContext,hntURLID,hntID];
2291 end;
2292 
THelpNode.ContextValidnull2293 function THelpNode.ContextValid: boolean;
2294 begin
2295   Result:=FHelpType in [hntURLIDContext,hntURLContext,hntContext];
2296 end;
2297 
AsStringnull2298 function THelpNode.AsString: string;
2299 begin
2300   Result:=Title;
2301 end;
2302 
2303 procedure THelpNode.Assign(Source: TPersistent);
2304 var
2305   Node: THelpNode;
2306 begin
2307   if Source is THelpNode then begin
2308     Node:=THelpNode(Source);
2309     FHelpType:=Node.HelpType;
2310     FTitle:=Node.Title;
2311     FURL:=Node.URL;
2312     FID:=Node.ID;
2313     FContext:=Node.Context;
2314   end else
2315     inherited Assign(Source);
2316 end;
2317 
2318 { THelpDBItem }
2319 
2320 constructor THelpDBItem.Create(TheNode: THelpNode);
2321 begin
2322   Node:=TheNode
2323 end;
2324 
2325 destructor THelpDBItem.Destroy;
2326 begin
2327   Node.Free;
2328   inherited Destroy;
2329 end;
2330 
2331 { TPascalHelpContextList }
2332 
TPascalHelpContextList.GetItemsnull2333 function TPascalHelpContextList.GetItems(Index: integer): TPascalHelpContext;
2334 begin
2335   Result:=fItems[Index];
2336 end;
2337 
2338 procedure TPascalHelpContextList.Add(const Context: TPascalHelpContext);
2339 begin
2340   inc(FCount);
2341   ReAllocMem(fItems,SizeOf(TPascalHelpContext)*FCount);
2342   // to prevent freeing uninitialized strings, initialize the new strings to nil
2343   FillChar(fItems[FCount-1], SizeOf(TPascalHelpContext), 0);
2344   fItems[FCount-1]:=Context;
2345 end;
2346 
2347 procedure TPascalHelpContextList.Add(Descriptor: TPascalHelpContextType;
2348   const Context: string);
2349 var
2350   CurContext: TPascalHelpContext;
2351 begin
2352   CurContext.Descriptor:=Descriptor;
2353   CurContext.Context:=Context;
2354   Add(CurContext);
2355 end;
2356 
2357 procedure TPascalHelpContextList.Insert(Index: integer;
2358   const Context: TPascalHelpContext);
2359 begin
2360   inc(FCount);
2361   ReAllocMem(fItems,SizeOf(TPascalHelpContext)*FCount);
2362   if Index<FCount-1 then
2363     System.Move(fItems[Index],fItems[Index+1],
2364                 SizeOf(TPascalHelpContext)*(FCount-Index-1));
2365   // to prevent freeing uninitialized strings, initialize the new strings to nil
2366   FillChar(fItems[Index], SizeOf(TPascalHelpContext), 0);
2367   fItems[Index]:=Context;
2368 end;
2369 
2370 procedure TPascalHelpContextList.Clear;
2371 var
2372   Index: Integer;
2373 begin
2374   // Set all item strings to '', so fpc will finalize them.
2375   for Index := 0 to FCount-1 do
2376     fItems[Index].Context := '';
2377   ReAllocMem(fItems,0);
2378 end;
2379 
2380 destructor TPascalHelpContextList.Destroy;
2381 begin
2382   Clear;
2383   inherited Destroy;
2384 end;
2385 
TPascalHelpContextList.IsEqualnull2386 function TPascalHelpContextList.IsEqual(QueryItem: THelpQueryItem): boolean;
2387 begin
2388   Result:=(QueryItem is TPascalHelpContextList)
2389           and (CompareList(TPascalHelpContextList(QueryItem))=0);
2390 end;
2391 
CompareListnull2392 function TPascalHelpContextList.CompareList(AList: TPascalHelpContextList
2393   ): integer;
2394 var
2395   i: Integer;
2396 begin
2397   i:=0;
2398   while (i<Count) and (i<AList.Count) do begin
2399     if fItems[i].Descriptor<AList.fItems[i].Descriptor then begin
2400       Result:=1;
2401       exit;
2402     end else if fItems[i].Descriptor>AList.fItems[i].Descriptor then begin
2403       Result:=-1;
2404       exit;
2405     end else begin
2406       Result:=CompareText(fItems[i].Context,AList.fItems[i].Context);
2407       if Result<>0 then exit;
2408     end;
2409     inc(i);
2410   end;
2411   if Count>i then
2412     Result:=-1
2413   else
2414     Result:=1;
2415 end;
2416 
AsStringnull2417 function TPascalHelpContextList.AsString: string;
2418 var
2419   i: Integer;
2420   Item: TPascalHelpContext;
2421   Filename: String;
2422 begin
2423   Result:='';
2424   i:=0;
2425   while (i<Count) and (Items[i].Descriptor=pihcFilename) do begin
2426     Filename:=Items[i].Context;
2427     inc(i);
2428   end;
2429   while i<Count do begin
2430     Item:=Items[i];
2431     case Item.Descriptor of
2432     pihcFilename: Result:=Result+Item.Context;
2433     pihcSourceName: ;
2434     pihcProperty: Result:=Result+' property '+Item.Context;
2435     pihcProcedure: Result:=Result+' procedure/function '+Item.Context;
2436     pihcParameterList: Result:=Result+Item.Context;
2437     pihcVariable: Result:=Result+' var '+Item.Context;
2438     pihcType: Result:=Result+' type '+Item.Context;
2439     pihcConst: Result:=Result+' const '+Item.Context;
2440     end;
2441     //DebugLn(['TPascalHelpContextList.AsString ',i,' ',Item.Descriptor,' ',Result]);
2442     inc(i);
2443   end;
2444   if Filename<>'' then
2445     Result:=Result+' in '+Filename;
2446 end;
2447 
2448 { THelpDBISourceFile }
2449 
2450 procedure THelpDBISourceFile.SetFilename(const AValue: string);
2451 begin
2452   FFilename:=AValue;
2453 end;
2454 
2455 constructor THelpDBISourceFile.Create(TheNode: THelpNode;
2456   const TheFilename: string);
2457 begin
2458   inherited Create(TheNode);
2459   FFilename:=TrimFilename(GetForcedPathDelims(TheFilename));
2460 end;
2461 
THelpDBISourceFile.FileMatchesnull2462 function THelpDBISourceFile.FileMatches(const AFilename: string): boolean;
2463 begin
2464   if (FFilename<>'') and (AFilename<>'') then
2465     Result:=CompareFilenames(GetFullFilename,AFilename)=0
2466   else
2467     Result:=false;
2468 end;
2469 
GetFullFilenamenull2470 function THelpDBISourceFile.GetFullFilename: string;
2471 var
2472   BaseDir: String;
2473   ExpFilename: String;
2474 begin
2475   ExpFilename:=FFilename;
2476   //DebugLn(['THelpDBISourceFile.GetFullFilename ExpFilename="',ExpFilename,'" HelpDatabases=',DbgSName(HelpDatabases)]);
2477   if (HelpDatabases<>nil) then
2478     HelpDatabases.SubstituteMacros(ExpFilename);
2479   //DebugLn(['THelpDBISourceFile.GetFullFilename substituted ',ExpFilename]);
2480   ExpFilename:=TrimFilename(GetForcedPathDelims(ExpFilename));
2481   if FilenameIsAbsolute(ExpFilename) then
2482     Result:=ExpFilename
2483   else begin
2484     BaseDir:=GetBasePath;
2485     Result:=AppendPathDelim(BaseDir)+ExpFilename;
2486   end;
2487 end;
2488 
THelpDBISourceFile.GetBasePathnull2489 function THelpDBISourceFile.GetBasePath: string;
2490 begin
2491   if BasePathObject=nil then
2492     Result:=''
2493   else
2494     Result:=AppendPathDelim(TrimFilename(GetForcedPathDelims(
2495              HelpDatabases.GetBaseDirectoryForBasePathObject(BasePathObject))));
2496 end;
2497 
2498 { THelpDBISourceDirectory }
2499 
2500 constructor THelpDBISourceDirectory.Create(TheNode: THelpNode;
2501   const Directory, TheFileMask: string; Recursive: boolean);
2502 begin
2503   inherited Create(TheNode,Directory);
2504   FFileMask:=GetForcedPathDelims(TheFileMask);
2505   WithSubDirectories:=Recursive;
2506 end;
2507 
THelpDBISourceDirectory.FileMatchesnull2508 function THelpDBISourceDirectory.FileMatches(const AFilename: string
2509   ): boolean;
2510 var
2511   TheDirectory: String;
2512 begin
2513   Result:=false;
2514   //debugln('THelpDBISourceDirectory.FileMatches AFilename="',AFilename,'" FFilename="',FFilename,'"');
2515   if (FFilename='') or (AFilename='') then exit;
2516   TheDirectory:=GetFullFilename;
2517   if TheDirectory='' then begin
2518     {$IFNDEF DisableChecks}
2519     DebugLn(['WARNING: THelpDBISourceDirectory.FileMatches ',DbgSName(Self),' Filename="',Filename,'" -> ""']);
2520     {$ENDIF}
2521     exit;
2522   end;
2523   //debugln('THelpDBISourceDirectory.FileMatches TheDirectory="',TheDirectory,'" WithSubDirectories=',dbgs(WithSubDirectories));
2524   if WithSubDirectories then begin
2525     if not FileIsInPath(AFilename,TheDirectory) then exit;
2526   end else begin
2527     if not FileIsInDirectory(AFilename,TheDirectory) then exit;
2528   end;
2529   //debugln('THelpDBISourceDirectory.FileMatches FileMask="',FileMask,'"');
2530   if (FileMask<>'')
2531   and (not MatchesMaskList(ExtractFilename(AFilename),FileMask)) then exit;
2532   //debugln('THelpDBISourceDirectory.FileMatches Success');
2533   Result:=true;
2534 end;
2535 
2536 { THelpQueryNode }
2537 
2538 constructor THelpQueryNode.Create(const TheHelpDatabaseID: THelpDatabaseID;
2539   const TheNode: THelpNode);
2540 begin
2541   inherited Create(TheHelpDatabaseID);
2542   FNode:=TheNode;
2543 end;
2544 
2545 { THelpBasePathObject }
2546 
2547 procedure THelpBasePathObject.SetBasePath(const AValue: string);
2548 begin
2549   if FBasePath=AValue then exit;
2550   FBasePath:=AValue;
2551 end;
2552 
2553 constructor THelpBasePathObject.Create;
2554 begin
2555 
2556 end;
2557 
2558 constructor THelpBasePathObject.Create(const TheBasePath: string);
2559 begin
2560   BasePath:=TheBasePath;
2561 end;
2562 
2563 { THelpNodeQuery }
2564 
2565 constructor THelpNodeQuery.Create;
2566 begin
2567 
2568 end;
2569 
2570 constructor THelpNodeQuery.Create(TheNode: THelpNode;
2571   TheQueryItem: THelpQueryItem);
2572 begin
2573   Create;
2574   FNode:=TheNode;
2575   FQueryItem:=TheQueryItem;
2576 end;
2577 
THelpNodeQuery.IsEqualnull2578 function THelpNodeQuery.IsEqual(TheNode: THelpNode; TheQueryItem: THelpQueryItem
2579   ): boolean;
2580 begin
2581   Result:=(Node=TheNode) and (QueryItem.IsEqual(TheQueryItem))
2582 end;
2583 
THelpNodeQuery.IsEqualnull2584 function THelpNodeQuery.IsEqual(NodeQuery: THelpNodeQuery): boolean;
2585 begin
2586   Result:=IsEqual(NodeQuery.Node,NodeQuery.QueryItem)
2587 end;
2588 
AsStringnull2589 function THelpNodeQuery.AsString: string;
2590 begin
2591   Result:=Node.AsString;
2592   if QueryItem<>nil then
2593     Result:=Result+' ('+QueryItem.AsString+')';
2594 end;
2595 
2596 { THelpNodeQueryList }
2597 
THelpNodeQueryList.GetItemsnull2598 function THelpNodeQueryList.GetItems(Index: integer): THelpNodeQuery;
2599 begin
2600   Result:=THelpNodeQuery(fItems[Index]);
2601 end;
2602 
2603 procedure THelpNodeQueryList.SetItems(Index: integer;
2604   const AValue: THelpNodeQuery);
2605 begin
2606   fItems[Index]:=AValue;
2607 end;
2608 
2609 constructor THelpNodeQueryList.Create;
2610 begin
2611   fItems:=TFPList.Create;
2612 end;
2613 
2614 destructor THelpNodeQueryList.Destroy;
2615 begin
2616   Clear;
2617   fItems.Free;
2618   inherited Destroy;
2619 end;
2620 
Countnull2621 function THelpNodeQueryList.Count: integer;
2622 begin
2623   Result:=fItems.Count;
2624 end;
2625 
Addnull2626 function THelpNodeQueryList.Add(NodeQuery: THelpNodeQuery): integer;
2627 begin
2628   Result:=fItems.Add(NodeQuery);
2629 end;
2630 
Addnull2631 function THelpNodeQueryList.Add(Node: THelpNode; QueryItem: THelpQueryItem
2632   ): integer;
2633 begin
2634   Result:=Add(THelpNodeQuery.Create(Node,QueryItem));
2635 end;
2636 
2637 procedure THelpNodeQueryList.Delete(Index: integer);
2638 begin
2639   TObject(fItems[Index]).Free;
2640   fItems.Delete(Index);
2641 end;
2642 
IndexOfnull2643 function THelpNodeQueryList.IndexOf(NodeQuery: THelpNodeQuery): integer;
2644 begin
2645   Result:=Count;
2646   while (Result>=0) and (not Items[Result].IsEqual(NodeQuery)) do
2647     dec(Result);
2648 end;
2649 
IndexOfnull2650 function THelpNodeQueryList.IndexOf(Node: THelpNode; QueryItem: THelpQueryItem
2651   ): integer;
2652 begin
2653   Result:=Count-1;
2654   while (Result>=0) and (not Items[Result].IsEqual(Node,QueryItem)) do
2655     dec(Result);
2656 end;
2657 
2658 procedure THelpNodeQueryList.Clear;
2659 var
2660   i: Integer;
2661 begin
2662   for i:=0 to Count-1 do TObject(fItems[i]).Free;
2663   fItems.Clear;
2664 end;
2665 
2666 { THelpQueryItem }
2667 
THelpQueryItem.IsEqualnull2668 function THelpQueryItem.IsEqual(QueryItem: THelpQueryItem): boolean;
2669 begin
2670   Result:=AsString=QueryItem.AsString;
2671 end;
2672 
2673 { THelpBaseURLObject }
2674 
2675 procedure THelpBaseURLObject.SetBaseURL(const AValue: string);
2676 begin
2677   if FBaseURL=AValue then exit;
2678   FBaseURL:=AValue;
2679 end;
2680 
2681 constructor THelpBaseURLObject.Create;
2682 begin
2683 
2684 end;
2685 
2686 constructor THelpBaseURLObject.Create(const TheBaseURL: string);
2687 begin
2688   BaseURL:=TheBaseURL;
2689 end;
2690 
2691 end.
2692 
2693