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