paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-26 02:02:36 +02:00
Code Issues Packages Projects Releases Wiki Activity
1c4a8462c7
lazarus/ideintf/helpintf.pas
mattias 623d8f33d0 implemented streaming of anchorsides 
git-svn-id: trunk@6651 -
2005-01-21 10:34:56 +00:00

2229 lines
63 KiB
ObjectPascal
Raw Blame History

{
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Mattias Gaertner
Abstract:
This unit defines various base classes for the Help System used by the IDE.
ToDo:
- localization support.
- Add Help Editing functions
- Standalone help system for LCL applications
}
unit HelpIntf;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LCLProc, Controls, FileUtil, ConfigStorage, MacroIntf,
ObjInspStrConsts;
type
// All help-specific error messages should be thrown as this type.
EHelpSystemException = class(Exception);
TShowHelpResult = (
shrNone,
shrSuccess,
shrDatabaseNotFound,
shrContextNotFound,
shrViewerNotFound,
shrHelpNotFound,
shrViewerError,
shrSelectorError
);
TShowHelpResults = set of TShowHelpResult;
{ TPascalHelpContextList }
TPascalHelpContextType = (
pihcFilename,
pihcSourceName, // unit name, library name, ..
pihcProperty,
pihcProcedure,
pihcParameterList,
pihcVariable,
pihcType,
pihcConst
);
TPascalHelpContext = record
Descriptor: TPascalHelpContextType;
Context: string;
end;
TPascalHelpContextPtr = ^TPascalHelpContext;
TPascalHelpContextList = class
private
FCount: integer;
// TODO: convert to dynamic array, when fpc 1.0 support is removed.
fItems: TPascalHelpContextPtr;
function GetItems(Index: integer): TPascalHelpContext;
public
procedure Add(const Context: TPascalHelpContext);
procedure Insert(Index: integer; const Context: TPascalHelpContext);
procedure Clear;
destructor Destroy; override;
function IsEqual(AList: TPascalHelpContextList): boolean;
function CompareList(AList: TPascalHelpContextList): integer;
public
property Count: integer read FCount;
property Items[Index: integer]: TPascalHelpContext read GetItems;
property List: TPascalHelpContextPtr read fItems;
end;
THelpDatabase = class;
THelpDatabaseID = string;
{ THelpNode
A help node is a position/place in a help database.
For example it points to Help file or to a Link on a HTML file. }
THelpNodeType = (
hntURLIDContext, // URL, ID and Context valid
hntURL, // URL valid, ignore ID and Context
hntURLID, // URL and ID valid, ignore Context
hntID, // ID valid, ignore URL and Context
hntContext, // Context valid, ignore URL and ID
hntURLContext // URL and Context valid, ignore ID
);
THelpNode = class(TPersistent)
private
FContext: THelpContext;
FQueryItem: TObject;
FURL: string;
FHelpType: THelpNodeType;
fID: string;
FOwner: THelpDatabase;
FTitle: string;
public
constructor Create(TheOwner: THelpDatabase; Node: THelpNode);
constructor Create(TheOwner: THelpDatabase;
const TheTitle, TheURL, TheID: string;
TheContext: THelpContext);
constructor CreateURL(TheOwner: THelpDatabase;
const TheTitle, TheURL: string);
constructor CreateID(TheOwner: THelpDatabase; const TheTitle, TheID: string);
constructor CreateURLID(TheOwner: THelpDatabase; const TheTitle,
TheURL, TheID: string);
constructor CreateContext(TheOwner: THelpDatabase; const TheTitle: string;
TheContext: THelpContext);
constructor CreateURLContext(TheOwner: THelpDatabase;
const TheTitle, TheURL: string;
TheContext: THelpContext);
public
property Owner: THelpDatabase read FOwner write FOwner;
function URLValid: boolean;
function IDValid: boolean;
function ContextValid: boolean;
procedure Assign(Source: TPersistent); override;
published
property Title: string read FTitle write FTitle;
property HelpType: THelpNodeType read FHelpType write FHelpType;
property URL: string read FURL write FURL;
property ID: string read fID write fID;
property Context: THelpContext read FContext write FContext;
property QueryItem: TObject read FQueryItem write FQueryItem;
end;
{ THelpDBItem
Base class for registration items associated with a THelpDatabase.
See THelpDBSISourceDirectory for an example.
Node is optional, pointing to a help page about the help item. }
THelpDBItem = class(TPersistent)
private
FNode: THelpNode;
public
constructor Create(TheNode: THelpNode);
destructor Destroy; override;
published
property Node: THelpNode read FNode write FNode;
end;
{ THelpDBSISourceFile
Help registration item for a single source file.
If Filename is relative, the BasePathObject is used to get a base directory.
For example: If BasePathObject is a TLazPackage the Filename is relative to
the directory of the .lpk file }
THelpDBISourceFile = class(THelpDBItem)
private
FBasePathObject: TObject;
FFilename: string;
procedure SetFilename(const AValue: string);
public
constructor Create(TheNode: THelpNode; const TheFilename: string);
function FileMatches(const AFilename: string): boolean; virtual;
function GetFullFilename: string; virtual;
function GetBasePath: string; virtual;
published
property BasePathObject: TObject read FBasePathObject write FBasePathObject;
property Filename: string read FFilename write SetFilename;
end;
{ THelpDBISourceDirectory
Help registration item for a source directory.
As THelpDBISourceFile, except that Filename is a directory and
the item is valid for all source files fitting the FileMask.
FileMask can be for example '*.pp;*.pas;*.inc'
For example: A package providing help for all its source files registers
a THelpDBISourceDirectory. Node points to the fpdoc main page.
}
THelpDBISourceDirectory = class(THelpDBISourceFile)
private
FFileMask: string;
FWithSubDirectories: boolean;
public
constructor Create(TheNode: THelpNode; const TheFilename,
TheFileMask: string; Recursive: boolean);
function FileMatches(const AFilename: string): boolean; override;
published
property FileMask: string read FFileMask write FFileMask;
property WithSubDirectories: boolean read FWithSubDirectories
write FWithSubDirectories;
end;
{ THelpDBIClass
Help registration item for a class.
Used by the IDE to search for help for a class without source.
For example for a registered component class in the component palette, that
comes without source. If the component comes with source use the
THelpDBISourceDirectory or THelpDBISourceFile instead. }
THelpDBIClass = class(THelpDBItem)
private
FTheClass: TClass;
public
property TheClass: TClass read FTheClass write FTheClass;
end;
{ THelpDBIMessage
Help registration item for a class.
Used by the IDE to search for help for a class without source.
For example for a registered component class in the component palette, that
comes without source. If the component comes with source use the
THelpDBISourceDirectory or THelpDBISourceFile instead. }
THelpDBIMessage = class(THelpDBItem)
public
function MessageMatches(const TheMessage: string): boolean; virtual; abstract;
end;
{ THelpQuery }
THelpQuery = class(TPersistent)
private
FHelpDatabaseID: THelpDatabaseID;
public
constructor Create(const TheHelpDatabaseID: THelpDatabaseID);
property HelpDatabaseID: THelpDatabaseID read FHelpDatabaseID
write FHelpDatabaseID;
end;
{ THelpQueryNode }
THelpQueryNode = class(THelpQuery)
private
FNode: THelpNode;
public
constructor Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheNode: THelpNode);
property Node: THelpNode read FNode write FNode;
end;
{ THelpQueryTOC }
THelpQueryTOC = class(THelpQueryNode)
end;
{ THelpQueryContext }
THelpQueryContext = class(THelpQuery)
private
FContext: THelpContext;
public
constructor Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheContext: THelpContext);
property Context: THelpContext read FContext write FContext;
end;
{ THelpQueryKeyword }
THelpQueryKeyword = class(THelpQuery)
private
FKeyword: string;
public
constructor Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheKeyWord: string);
property Keyword: string read FKeyword write FKeyword;
end;
{ THelpQuerySourcePosition }
THelpQuerySourcePosition = class(THelpQuery)
private
FFilename: string;
FSourcePosition: TPoint;
public
constructor Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheFilename: string; const SrcPos: TPoint);
property Filename: string read FFilename write FFilename;
property SourcePosition: TPoint read FSourcePosition write FSourcePosition;
end;
{ THelpQueryPascalContexts }
THelpQueryPascalContexts = class(THelpQuerySourcePosition)
private
FContextLists: TList;
public
constructor Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheFilename: string; const SrcPos: TPoint;
ContextLists: TList);
property ListOfPascalHelpContextList: TList read FContextLists
write FContextLists;
end;
{ THelpQueryMessage }
THelpQueryMessage = class(THelpQuery)
private
FWholeMessage: string;
public
constructor Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheMessage: string);
property WholeMessage: string read FWholeMessage write FWholeMessage;
end;
{ THelpQueryClass }
THelpQueryClass = class(THelpQuery)
private
FTheClass: TClass;
public
constructor Create(const TheHelpDatabaseID: THelpDatabaseID;
const AClass: TClass);
property TheClass: TClass read FTheClass write FTheClass;
end;
{ THelpDatabase
Base class for a collection of help files or entries.
BasePathObject: THelpDatabase can be created by packages.
The IDE will set BasePathObject accordingly. }
THelpDatabases = class;
THelpViewer = class;
THelpDatabase = class(TPersistent)
private
FBasePathObject: TObject;
FID: THelpDatabaseID;
FDatabases: THelpDatabases;
FRefCount: integer;
FSearchItems: TList;
FSupportedMimeTypes: TStrings;
FTOCNode: THelpNode;
procedure SetID(const AValue: THelpDatabaseID);
procedure SetDatabases(const AValue: THelpDatabases);
protected
procedure SetSupportedMimeTypes(List: TStrings); virtual;
procedure AddSupportedMimeType(const AMimeType: string); virtual;
public
constructor Create(TheID: THelpDatabaseID); virtual;
destructor Destroy; override;
procedure Reference;
procedure RegisterSelf;
procedure Release;
procedure UnregisterSelf;
function Registered: boolean;
function CanShowTableOfContents: boolean; virtual;
procedure ShowTableOfContents; virtual;
procedure ShowError(ShowResult: TShowHelpResult; const ErrMsg: string); virtual;
function ShowHelp(Query: THelpQuery; BaseNode, NewNode: THelpNode;
var ErrMsg: string): TShowHelpResult; virtual;
function ShowHelpFile(Query: THelpQuery; BaseNode: THelpNode;
const Title, Filename: string;
var ErrMsg: string): TShowHelpResult; virtual;
function SupportsMimeType(const AMimeType: string): boolean; virtual;
function GetNodesForKeyword(const HelpKeyword: string;
var ListOfNodes: TList; var ErrMsg: string
): TShowHelpResult; virtual;
function GetNodesForContext(HelpContext: THelpContext;
var ListOfNodes: TList; var ErrMsg: string
): TShowHelpResult; virtual;
function GetNodesForPascalContexts(ListOfPascalHelpContextList: TList;
var ListOfNodes: TList;
var ErrMsg: string): TShowHelpResult; virtual;
function GetNodesForClass(AClass: TClass;
var ListOfNodes: TList; var ErrMsg: string
): TShowHelpResult; virtual;
function GetNodesForMessage(const AMessage: string;
var ListOfNodes: TList; var ErrMsg: string
): TShowHelpResult; virtual;
function FindViewer(const MimeType: string; var ErrMsg: string;
var Viewer: THelpViewer): TShowHelpResult; virtual;
public
// registration
procedure RegisterItem(NewItem: THelpDBItem);
procedure RegisterItemWithNode(Node: THelpNode);
procedure RegisterFileItemWithNode(const Filename: string; Node: THelpNode);
procedure UnregisterItem(AnItem: THelpDBItem);
function RegisteredItemCount: integer;
function GetRegisteredItem(Index: integer): THelpDBItem;
procedure Load(Storage: TConfigStorage); virtual;
procedure Save(Storage: TConfigStorage); virtual;
function GetLocalizedName: string; virtual;
public
property Databases: THelpDatabases read FDatabases write SetDatabases;
property ID: THelpDatabaseID read FID write SetID;
property SupportedMimeTypes: TStrings read FSupportedMimeTypes;
property BasePathObject: TObject read FBasePathObject write FBasePathObject;
property TOCNode: THelpNode read FTOCNode write FTOCNode;
end;
THelpDatabaseClass = class of THelpDatabase;
{ THelpDatabases
Class for storing all registered THelpDatabase }
THelpDatabases = class
private
FItems: TList;
FHelpDBClasses: TList;
function GetItems(Index: integer): THelpDatabase;
procedure DoRegisterDatabase(ADatabase: THelpDatabase);
procedure DoUnregisterDatabase(ADatabase: THelpDatabase);
public
constructor Create;
destructor Destroy; override;
function Count: integer;
property Items[Index: integer]: THelpDatabase read GetItems; default;
public
function FindDatabase(ID: THelpDatabaseID): THelpDatabase;
function GetDatabase(ID: THelpDatabaseID; var HelpDB: THelpDatabase;
var HelpResult: TShowHelpResult; var ErrMsg: string): boolean;
function IndexOf(ID: THelpDatabaseID): integer;
function CreateUniqueDatabaseID(const WishID: string): THelpDatabaseID;
function CreateHelpDatabase(const WishID: string;
HelpDataBaseClass: THelpDatabaseClass;
AutoRegister: boolean): THelpDatabase;
function ShowTableOfContents(var ErrMsg: string): TShowHelpResult;
procedure ShowError(ShowResult: TShowHelpResult; const ErrMsg: string); virtual; abstract;
function GetBaseURLForBasePathObject(BasePathObject: TObject): string; virtual;
function GetBaseDirectoryForBasePathObject(BasePathObject: TObject): string; virtual;
public
// show help for ...
function ShowHelpForNodes(Query: THelpQuery; Nodes: TList;
var ErrMsg: string): TShowHelpResult; virtual;
function ShowHelpForQuery(Query: THelpQuery; AutoFreeQuery: boolean;
var ErrMsg: string): TShowHelpResult; virtual;
function ShowHelpForContext(Query: THelpQueryContext;
var ErrMsg: string): TShowHelpResult; virtual;
function ShowHelpForKeyword(Query: THelpQueryKeyword;
var ErrMsg: string): TShowHelpResult; virtual;
function ShowHelpForPascalContexts(Query: THelpQueryPascalContexts;
var ErrMsg: string): TShowHelpResult; virtual;
function ShowHelpForSourcePosition(Query: THelpQuerySourcePosition;
var ErrMsg: string): TShowHelpResult; virtual;
function ShowHelpForMessageLine(Query: THelpQueryMessage;
var ErrMsg: string): TShowHelpResult; virtual;
function ShowHelpForClass(Query: THelpQueryClass;
var ErrMsg: string): TShowHelpResult; virtual;
// search registered items in all databases
function GetNodesForKeyword(const HelpKeyword: string;
var ListOfNodes: TList; var ErrMsg: string
): TShowHelpResult; virtual;
function GetNodesForContext(HelpContext: THelpContext;
var ListOfNodes: TList; var ErrMsg: string
): TShowHelpResult; virtual;
function GetNodesForPascalContexts(ListOfPascalHelpContextList: TList;
var ListOfNodes: TList;
var ErrMsg: string): TShowHelpResult; virtual;
function GetNodesForClass(AClass: TClass;
var ListOfNodes: TList; var ErrMsg: string
): TShowHelpResult; virtual;
function GetNodesForMessage(const AMessage: string;
var ListOfNodes: TList; var ErrMsg: string
): TShowHelpResult; virtual;
function ShowHelpSelector(Query: THelpQuery; Nodes: TList;
var ErrMsg: string;
var Selection: THelpNode): TShowHelpResult; virtual;
public
// registration of THelpDatabaseClass
procedure RegisterHelpDatabaseClass(NewHelpDB: THelpDatabaseClass);
procedure UnregisterHelpDatabaseClass(AHelpDB: THelpDatabaseClass);
function HelpDatabaseClassCount: integer;
function GetHelpDatabaseClass(Index: integer): THelpDatabaseClass;
procedure Load(Storage: TConfigStorage); virtual;
procedure Save(Storage: TConfigStorage); virtual;
end;
{ THelpViewer
base class for all Help viewers }
THelpViewer = class(TPersistent)
private
FParameterHelp: string;
FStorageName: string;
FSupportedMimeTypes: TStrings;
protected
procedure SetSupportedMimeTypes(List: TStrings); virtual;
procedure AddSupportedMimeType(const AMimeType: string); virtual;
public
constructor Create;
destructor Destroy; override;
function SupportsTableOfContents: boolean; virtual;
procedure ShowTableOfContents(Node: THelpNode); virtual;
function SupportsMimeType(const AMimeType: string): boolean; virtual;
function ShowNode(Node: THelpNode; var ErrMsg: string): TShowHelpResult; virtual;
procedure Hide; virtual;
procedure Assign(Source: TPersistent); override;
procedure Load(Storage: TConfigStorage); virtual;
procedure Save(Storage: TConfigStorage); virtual;
function GetLocalizedName: string; virtual;
public
property SupportedMimeTypes: TStrings read FSupportedMimeTypes;
property ParameterHelp: string read FParameterHelp write FParameterHelp;
property StorageName: string read FStorageName write FStorageName;
end;
THelpViewerClass = class of THelpViewer;
{ THelpViewers }
THelpViewers = class
private
FItems: TList;
function GetItems(Index: integer): THelpViewer;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function Count: integer;
function GetViewersSupportingMimeType(const MimeType: string): TList;
procedure RegisterViewer(AHelpViewer: THelpViewer);
procedure UnregisterViewer(AHelpViewer: THelpViewer);
procedure Load(Storage: TConfigStorage); virtual;
procedure Save(Storage: TConfigStorage); virtual;
public
property Items[Index: integer]: THelpViewer read GetItems; default;
end;
{ THelpBasePathObject }
THelpBasePathObject = class(TPersistent)
private
FBasePath: string;
protected
procedure SetBasePath(const AValue: string); virtual;
public
property BasePath: string read FBasePath write SetBasePath;
end;
var
HelpDatabases: THelpDatabases; // initialized by the IDE
HelpViewers: THelpViewers; // initialized by the IDE
//==============================================================================
{ Showing help (how it works):
- starts the help system, if not already started
- search all appropriate help Databases for the given context
If multiple contexts fit, a help selector is shown and the user chooses one.
- calls the help Database to show the context
The help Database will search an appropriate help viewer and starts it.
}
// table of contents
function ShowTableOfContents: TShowHelpResult;
function ShowTableOfContents(var ErrMsg: string): TShowHelpResult;
// help by ID
function ShowHelpOrErrorForContext(HelpDatabaseID: THelpDatabaseID;
HelpContext: THelpContext): TShowHelpResult;
function ShowHelpForContext(HelpDatabaseID: THelpDatabaseID;
HelpContext: THelpContext; var ErrMsg: string): TShowHelpResult;
function ShowHelpForContext(HelpContext: THelpContext; var ErrMsg: string
): TShowHelpResult;
// help by keyword
function ShowHelpOrErrorForKeyword(HelpDatabaseID: THelpDatabaseID;
const HelpKeyword: string): TShowHelpResult;
function ShowHelpForKeyword(HelpDatabaseID: THelpDatabaseID;
const HelpKeyword: string; var ErrMsg: string): TShowHelpResult;
function ShowHelpForKeyword(const HelpKeyword: string; var ErrMsg: string
): TShowHelpResult;
// help for pascal sources
function ShowHelpForPascalContexts(const Filename: string;
const SourcePosition: TPoint; ListOfPascalHelpContextList: TList;
var ErrMsg: string): TShowHelpResult;
function ShowHelpOrErrorForSourcePosition(const Filename: string;
const SourcePosition: TPoint): TShowHelpResult;
// help for messages (compiler messages, codetools messages, make messages, ...)
function ShowHelpForMessageLine(const MessageLine: string;
var ErrMsg: string): TShowHelpResult;
function ShowHelpOrErrorForMessageLine(const MessageLine: string
): TShowHelpResult;
// URL functions
function FilenameToURL(const Filename: string): string;
procedure SplitURL(const URL: string; var URLType, URLPath, URLParams: string);
function CombineURL(const URLType, URLPath, URLParams: string): string;
function URLFilenameIsAbsolute(const Filename: string): boolean;
function FindURLPathStart(const URL: string): integer;
function FindURLPathEnd(const URL: string): integer;
function ChompURLParams(const URL: string): string;
function ExtractURLDirectory(const URL: string): string;
function TrimUrl(const URL: string): string;
implementation
function ShowTableOfContents: TShowHelpResult;
var
ErrMsg: String;
begin
ErrMsg:='';
Result:=ShowTableOfContents(ErrMsg);
HelpDatabases.ShowError(Result,ErrMsg);
end;
function ShowTableOfContents(var ErrMsg: string): TShowHelpResult;
begin
Result:=HelpDatabases.ShowTableOfContents(ErrMsg);
end;
function ShowHelpOrErrorForContext(HelpDatabaseID: THelpDatabaseID;
HelpContext: THelpContext): TShowHelpResult;
var
ErrMsg: String;
begin
ErrMsg:='';
Result:=ShowHelpForContext(HelpDatabaseID,HelpContext,ErrMsg);
HelpDatabases.ShowError(Result,ErrMsg);
end;
function ShowHelpForContext(HelpDatabaseID: THelpDatabaseID;
HelpContext: THelpContext; var ErrMsg: string): TShowHelpResult;
begin
Result:=HelpDatabases.ShowHelpForQuery(
THelpQueryContext.Create(HelpDatabaseID,HelpContext),
true,ErrMsg);
end;
function ShowHelpForContext(HelpContext: THelpContext; var ErrMsg: string
): TShowHelpResult;
begin
Result:=ShowHelpForContext('',HelpContext,ErrMsg);
end;
function ShowHelpOrErrorForKeyword(HelpDatabaseID: THelpDatabaseID;
const HelpKeyword: string): TShowHelpResult;
var
ErrMsg: String;
begin
ErrMsg:='';
Result:=ShowHelpForKeyword(HelpDatabaseID,HelpKeyword,ErrMsg);
HelpDatabases.ShowError(Result,ErrMsg);
end;
function ShowHelpForKeyword(HelpDatabaseID: THelpDatabaseID;
const HelpKeyword: string; var ErrMsg: string): TShowHelpResult;
begin
Result:=HelpDatabases.ShowHelpForQuery(
THelpQueryKeyword.Create(HelpDatabaseID,HelpKeyword),
true,ErrMsg);
end;
function ShowHelpForKeyword(const HelpKeyword: string; var ErrMsg: string
): TShowHelpResult;
begin
Result:=ShowHelpForKeyword('',HelpKeyword,ErrMsg);
end;
function ShowHelpForPascalContexts(const Filename: string;
const SourcePosition: TPoint; ListOfPascalHelpContextList: TList;
var ErrMsg: string): TShowHelpResult;
begin
Result:=HelpDatabases.ShowHelpForQuery(
THelpQueryPascalContexts.Create('',Filename,
SourcePosition,ListOfPascalHelpContextList),
true,ErrMsg);
end;
function ShowHelpOrErrorForSourcePosition(const Filename: string;
const SourcePosition: TPoint): TShowHelpResult;
var
ErrMsg: String;
begin
ErrMsg:='';
Result:=HelpDatabases.ShowHelpForQuery(
THelpQuerySourcePosition.Create('',Filename,
SourcePosition),
true,ErrMsg);
HelpDatabases.ShowError(Result,ErrMsg);
end;
function ShowHelpForMessageLine(const MessageLine: string;
var ErrMsg: string): TShowHelpResult;
begin
Result:=HelpDatabases.ShowHelpForQuery(
THelpQueryMessage.Create('',MessageLine),
true,ErrMsg);
end;
function ShowHelpOrErrorForMessageLine(const MessageLine: string
): TShowHelpResult;
var
ErrMsg: String;
begin
ErrMsg:='';
Result:=ShowHelpForMessageLine(MessageLine,ErrMsg);
HelpDatabases.ShowError(Result,ErrMsg);
end;
function FilenameToURL(const Filename: string): string;
var
i: Integer;
begin
Result:=Filename;
{$warnings off}
if PathDelim<>'/' then
for i:=1 to length(Result) do
if Result[i]=PathDelim then
Result[i]:='/';
{$warnings on}
if Result<>'' then
Result:='file://'+Result;
end;
procedure SplitURL(const URL: string; var URLType, URLPath, URLParams: string);
var
Len: Integer;
ColonPos: Integer;
ParamStartPos: integer;
URLStartPos: Integer;
begin
URLType:='';
URLPath:='';
URLParams:='';
Len:=length(URL);
// search colon
ColonPos:=1;
while (ColonPos<=len) and (URL[ColonPos]<>':') do
inc(ColonPos);
if ColonPos=len then exit;
// get URLType
URLType:=copy(URL,1,ColonPos-1);
URLStartPos:=ColonPos+1;
// skip the '//' after the colon
if (URLStartPos<=len) and (URL[URLStartPos]='/') then inc(URLStartPos);
if (URLStartPos<=len) and (URL[URLStartPos]='/') then inc(URLStartPos);
// search param delimiter ?
ParamStartPos:=ColonPos+1;
while (ParamStartPos<=len) and (URL[ParamStartPos]<>'?') do
inc(ParamStartPos);
// get URLPath and URLParams
URLPath:=copy(URL,URLStartPos,ParamStartPos-URLStartPos);
URLParams:=copy(URL,ParamStartPos+1,len-ParamStartPos);
end;
function CombineURL(const URLType, URLPath, URLParams: string): string;
begin
Result:=URLType+'://'+URLPath;
if URLParams<>'' then
Result:=Result+'?'+URLParams;
end;
function URLFilenameIsAbsolute(const Filename: string): boolean;
begin
{$warnings off}
if PathDelim='/' then
Result:=FilenameIsAbsolute(Filename)
else
Result:=FilenameIsAbsolute(SetDirSeparators(Filename));
{$warnings on}
end;
function FindURLPathStart(const URL: string): integer;
var
Len: Integer;
ColonPos: Integer;
URLStartPos: Integer;
begin
Result:=-1;
Len:=length(URL);
// search colon
ColonPos:=1;
while (ColonPos<=len) and (URL[ColonPos]<>':') do
inc(ColonPos);
if ColonPos=Len then exit;
URLStartPos:=ColonPos+1;
// skip the '//' after the colon
if (URLStartPos<=Len) and (URL[URLStartPos]='/') then inc(URLStartPos);
if (URLStartPos<=Len) and (URL[URLStartPos]='/') then inc(URLStartPos);
Result:=URLStartPos;
end;
function FindURLPathEnd(const URL: string): integer;
var
Len: Integer;
begin
Result:=1;
Len:=length(URL);
while (Result<=Len) and (URL[Result]<>'?') do inc(Result);
end;
function ChompURLParams(const URL: string): string;
begin
Result:=copy(URL,1,FindURLPathEnd(URL)-1);
end;
function ExtractURLDirectory(const URL: string): string;
var
p: Integer;
PathStart: LongInt;
begin
Result:='';
PathStart:=FindURLPathStart(URL);
if PathStart<1 then exit;
p:=FindURLPathEnd(URL);
while (p>0) and (URL[p]<>'/') do dec(p);
if p<=PathStart then exit;
Result:=copy(URL,1,p);
end;
function TrimUrl(const URL: string): string;
var
URLType, URLPath, URLParams: string;
begin
SplitURL(URL,URLType,URLPath,URLParams);
Result:=CombineURL(URLType,TrimFilename(URLPath),URLParams);
end;
procedure CreateListAndAdd(const AnObject: TObject; var List: TList;
OnlyIfNotExists: boolean);
begin
if List=nil then
List:=TList.Create
else if OnlyIfNotExists and (List.IndexOf(AnObject)>=0) then
exit;
List.Add(AnObject);
end;
{ THelpDatabase }
procedure THelpDatabase.SetID(const AValue: THelpDatabaseID);
var
OldRegistered: Boolean;
begin
if FID=AValue then exit;
OldRegistered:=Registered;
if OldRegistered then UnregisterSelf;
FID:=AValue;
if OldRegistered then RegisterSelf;
end;
procedure THelpDatabase.SetDatabases(const AValue: THelpDatabases);
begin
if AValue=Databases then exit;
Reference;
if FDatabases<>nil then FDatabases.DoUnregisterDatabase(Self);
FDatabases:=AValue;
if FDatabases<>nil then FDatabases.DoRegisterDatabase(Self);
Release;
end;
procedure THelpDatabase.SetSupportedMimeTypes(List: TStrings);
begin
FSupportedMimeTypes.Free;
FSupportedMimeTypes:=List;
end;
procedure THelpDatabase.AddSupportedMimeType(const AMimeType: string);
begin
if FSupportedMimeTypes=nil then SetSupportedMimeTypes(TStringList.Create);
FSupportedMimeTypes.Add(AMimeType);
end;
constructor THelpDatabase.Create(TheID: THelpDatabaseID);
begin
FID:=TheID;
end;
destructor THelpDatabase.Destroy;
var
i: Integer;
begin
Reference; // reference to not call Free again
if Databases<>nil then UnregisterSelf;
FSupportedMimeTypes.Free;
if FSearchItems<>nil then begin
for i:=FSearchItems.Count-1 downto 0 do
THelpNode(FSearchItems[i]).Free;
FSearchItems.Free;
end;
FTOCNode.Free;
inherited Destroy;
end;
procedure THelpDatabase.RegisterSelf;
begin
if Databases<>nil then
raise EHelpSystemException.Create(Format(oisHelpAlreadyRegistered, [ID]));
Databases:=HelpDatabases;
end;
procedure THelpDatabase.UnregisterSelf;
begin
if Databases=nil then
raise EHelpSystemException.Create(Format(oisHelpNotRegistered, [ID]));
Databases:=nil;
end;
function THelpDatabase.Registered: boolean;
begin
Result:=Databases<>nil;
end;
function THelpDatabase.CanShowTableOfContents: boolean;
begin
Result:=TOCNode<>nil;
end;
procedure THelpDatabase.ShowTableOfContents;
var
ErrMsg: string;
ShowResult: TShowHelpResult;
Query: THelpQueryTOC;
begin
if TOCNode=nil then exit;
ErrMsg:='';
Query:=THelpQueryTOC.Create(ID,TOCNode);
try
ShowResult:=ShowHelp(Query,nil,TOCNode,ErrMsg);
finally
Query.Free;
end;
ShowError(ShowResult,ErrMsg);
end;
procedure THelpDatabase.ShowError(ShowResult: TShowHelpResult;
const ErrMsg: string);
begin
if ShowResult=shrSuccess then exit;
if Databases<>nil then
Databases.ShowError(ShowResult,ErrMsg)
else
raise EHelpSystemException.Create(ErrMsg);
end;
function THelpDatabase.ShowHelp(Query: THelpQuery; BaseNode, NewNode: THelpNode;
var ErrMsg: string): TShowHelpResult;
begin
ErrMsg:='';
Result:=shrContextNotFound;
end;
function THelpDatabase.ShowHelpFile(Query: THelpQuery; BaseNode: THelpNode;
const Title, Filename: string; var ErrMsg: string): TShowHelpResult;
var
FileNode: THelpNode;
begin
FileNode:=THelpNode.CreateURL(Self,Title,FilenameToURL(Filename));
try
Result:=ShowHelp(Query,BaseNode,FileNode,ErrMsg);
finally
FileNode.Free;
end;
end;
function THelpDatabase.SupportsMimeType(const AMimeType: string): boolean;
begin
Result:=false;
if FSupportedMimeTypes<>nil then
Result:=(FSupportedMimeTypes.IndexOf(AMimeType)>=0);
end;
function THelpDatabase.GetNodesForKeyword(const HelpKeyword: string;
var ListOfNodes: TList; var ErrMsg: string): TShowHelpResult;
// if ListOfNodes<>nil new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
Node: THelpNode;
begin
Result:=shrSuccess;
ErrMsg:='';
// add the registered nodes
if FSearchItems<>nil then begin
for i:=0 to FSearchItems.Count-1 do begin
Node:=THelpDBItem(FSearchItems[i]).Node;
if (Node=nil) or (not Node.IDValid) then continue;
if AnsiCompareText(Node.ID,HelpKeyword)<>0 then continue;
CreateListAndAdd(Node,ListOfNodes,true);
end;
end;
end;
function THelpDatabase.GetNodesForContext(HelpContext: THelpContext;
var ListOfNodes: TList; var ErrMsg: string): TShowHelpResult;
// if ListOfNodes<>nil new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
Node: THelpNode;
begin
Result:=shrSuccess;
ErrMsg:='';
// add the registered nodes
if FSearchItems<>nil then begin
for i:=0 to FSearchItems.Count-1 do begin
Node:=THelpDBItem(FSearchItems[i]).Node;
if (Node=nil) or (not Node.ContextValid) then continue;
if Node.Context<>HelpContext then continue;
CreateListAndAdd(Node,ListOfNodes,true);
end;
end;
end;
function THelpDatabase.GetNodesForPascalContexts(
ListOfPascalHelpContextList: TList; var ListOfNodes: TList; var ErrMsg: string
): TShowHelpResult;
// if ListOfNodes<>nil new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
j: Integer;
SearchItem: THelpDBItem;
PascalContext: TPascalHelpContextList;
FileItem: THelpDBISourceFile;
Filename: String;
begin
Result:=shrSuccess;
ErrMsg:='';
if (ListOfPascalHelpContextList=nil)
or (ListOfPascalHelpContextList.Count=0) then exit;
// add the registered nodes
if FSearchItems<>nil then begin
// check every pascal context
for j:=0 to ListOfPascalHelpContextList.Count-1 do begin
PascalContext:=TPascalHelpContextList(ListOfPascalHelpContextList[j]);
//debugln('THelpDatabase.GetNodesForPascalContexts A PascalContext.Count=',dbgs(PascalContext.Count));
if (PascalContext.Count>0)
and (PascalContext.List[0].Descriptor=pihcFilename) then begin
// search file item
for i:=0 to FSearchItems.Count-1 do begin
SearchItem:=THelpDBItem(FSearchItems[i]);
if not (SearchItem is THelpDBISourceFile) then continue;
FileItem:=THelpDBISourceFile(SearchItem);
Filename:=PascalContext.List[0].Context;
//debugln('THelpDatabase.GetNodesForPascalContexts B FileItem.ClassName=',FileItem.ClassName,' Filename=',Filename);
if (FileItem.FileMatches(Filename)) then begin
FileItem.Node.QueryItem:=PascalContext;
CreateListAndAdd(FileItem.Node,ListOfNodes,true);
end;
end;
end;
end;
end;
end;
function THelpDatabase.GetNodesForClass(AClass: TClass; var ListOfNodes: TList;
var ErrMsg: string): TShowHelpResult;
// if ListOfNodes<>nil new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
SearchItem: THelpDBItem;
begin
Result:=shrSuccess;
ErrMsg:='';
// add the registered nodes
if FSearchItems<>nil then begin
for i:=0 to FSearchItems.Count-1 do begin
SearchItem:=THelpDBItem(FSearchItems[i]);
if not (SearchItem is THelpDBIClass) then continue;
if THelpDBIClass(SearchItem).TheClass<>AClass then continue;
CreateListAndAdd(SearchItem.Node,ListOfNodes,true);
end;
end;
end;
function THelpDatabase.GetNodesForMessage(const AMessage: string;
var ListOfNodes: TList; var ErrMsg: string): TShowHelpResult;
// if ListOfNodes<>nil new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
SearchItem: THelpDBItem;
begin
Result:=shrSuccess;
ErrMsg:='';
// add the registered nodes
if FSearchItems<>nil then begin
for i:=0 to FSearchItems.Count-1 do begin
SearchItem:=THelpDBItem(FSearchItems[i]);
if not (SearchItem is THelpDBIMessage) then continue;
if not THelpDBIMessage(SearchItem).MessageMatches(AMessage) then continue;
CreateListAndAdd(SearchItem.Node,ListOfNodes,true);
end;
end;
end;
function THelpDatabase.FindViewer(const MimeType: string; var ErrMsg: string;
var Viewer: THelpViewer): TShowHelpResult;
var
Viewers: TList;
begin
Viewer:=nil;
Viewers:=HelpViewers.GetViewersSupportingMimeType(MimeType);
try
if (Viewers=nil) or (Viewers.Count=0) then begin
ErrMsg:=Format(oisHelpHelpDatabaseDidNotFoundAViewerForAHelpPageOfType, [
'"', ID, '"', MimeType]);
Result:=shrViewerNotFound;
end else begin
Viewer:=THelpViewer(Viewers[0]);
Result:=shrSuccess;
end;
finally
Viewers.Free;
end;
end;
procedure THelpDatabase.RegisterItem(NewItem: THelpDBItem);
begin
if NewItem=nil then
raise EHelpSystemException.Create('THelpDatabase.RegisterItem NewItem=nil');
if FSearchItems=nil then FSearchItems:=TList.Create;
if FSearchItems.IndexOf(NewItem)<0 then
FSearchItems.Add(NewItem)
else
NewItem.Free;
end;
procedure THelpDatabase.RegisterItemWithNode(Node: THelpNode);
begin
if Node=nil then
raise EHelpSystemException.Create('THelpDatabase.RegisterItemWithNode Node=nil');
RegisterItem(THelpDBItem.Create(Node));
end;
procedure THelpDatabase.RegisterFileItemWithNode(const Filename: string;
Node: THelpNode);
begin
RegisterItem(THelpDBISourceFile.Create(Node,Filename));
end;
procedure THelpDatabase.UnregisterItem(AnItem: THelpDBItem);
begin
if FSearchItems=nil then exit;
FSearchItems.Remove(AnItem);
end;
function THelpDatabase.RegisteredItemCount: integer;
begin
if FSearchItems=nil then
Result:=0
else
Result:=FSearchItems.Count;
end;
function THelpDatabase.GetRegisteredItem(Index: integer): THelpDBItem;
begin
Result:=THelpDBItem(FSearchItems[Index]);
end;
procedure THelpDatabase.Load(Storage: TConfigStorage);
begin
end;
procedure THelpDatabase.Save(Storage: TConfigStorage);
begin
end;
function THelpDatabase.GetLocalizedName: string;
begin
Result:=ID;
end;
procedure THelpDatabase.Reference;
begin
inc(FRefCount);
end;
procedure THelpDatabase.Release;
begin
if FRefCount=0 then
raise EHelpSystemException.Create('THelpDatabase.Release');
dec(FRefCount);
if FRefCount=0 then Free;
end;
{ THelpDatabases }
function THelpDatabases.GetItems(Index: integer): THelpDatabase;
begin
Result:=THelpDatabase(FItems[Index]);
end;
procedure THelpDatabases.DoRegisterDatabase(ADatabase: THelpDatabase);
begin
ADatabase.Reference;
if FItems=nil then FItems:=TList.Create;
FItems.Add(ADatabase);
end;
procedure THelpDatabases.DoUnregisterDatabase(ADatabase: THelpDatabase);
begin
if FItems<>nil then
FItems.Remove(ADatabase);
ADatabase.Release;
end;
constructor THelpDatabases.Create;
begin
end;
destructor THelpDatabases.Destroy;
begin
while (Count>0) do Items[Count-1].UnregisterSelf;
FItems.Free;
FHelpDBClasses.Free;
inherited Destroy;
end;
function THelpDatabases.Count: integer;
begin
if FItems=nil then
Result:=0
else
Result:=FItems.Count;
end;
function THelpDatabases.FindDatabase(ID: THelpDatabaseID): THelpDatabase;
var
Index: LongInt;
begin
Index:=IndexOf(ID);
if Index>=0 then
Result:=Items[Index]
else
Result:=nil;
end;
function THelpDatabases.GetDatabase(ID: THelpDatabaseID; var HelpDB: THelpDatabase;
var HelpResult: TShowHelpResult; var ErrMsg: string): boolean;
begin
HelpDB:=FindDatabase(ID);
if HelpDB=nil then begin
Result:=false;
HelpResult:=shrDatabaseNotFound;
ErrMsg:=Format(oisHelpHelpDatabaseNotFound, ['"', ID, '"']);
end else begin
HelpResult:=shrSuccess;
Result:=true;
ErrMsg:='';
end;
end;
function THelpDatabases.IndexOf(ID: THelpDatabaseID): integer;
begin
Result:=Count-1;
while (Result>=0) and (AnsiCompareText(ID,Items[Result].ID)<>0) do
dec(Result);
end;
function THelpDatabases.CreateUniqueDatabaseID(
const WishID: string): THelpDatabaseID;
var
i: Integer;
begin
if (WishID<>'') and (FindDatabase(WishID)=nil) then begin
Result:=WishID;
end else begin
i:=1;
repeat
Result:=WishID+IntToStr(i);
if FindDatabase(Result)=nil then exit;
inc(i);
until false;
end;
end;
function THelpDatabases.CreateHelpDatabase(const WishID: string;
HelpDataBaseClass: THelpDatabaseClass; AutoRegister: boolean): THelpDatabase;
begin
Result:=HelpDataBaseClass.Create(CreateUniqueDatabaseID(WishID));
if AutoRegister then Result.RegisterSelf;
end;
function THelpDatabases.ShowTableOfContents(var ErrMsg: string
): TShowHelpResult;
begin
Result:=shrHelpNotFound;
ErrMsg:='THelpDatabases.ShowTableOfContents not implemented';
// ToDo
end;
function THelpDatabases.GetBaseURLForBasePathObject(BasePathObject: TObject
): string;
begin
Result:=GetBaseDirectoryForBasePathObject(BasePathObject);
if Result='' then exit;
Result:=FilenameToURL(Result);
end;
function THelpDatabases.GetBaseDirectoryForBasePathObject(BasePathObject: TObject
): string;
begin
Result:='';
end;
function THelpDatabases.ShowHelpForNodes(Query: THelpQuery; Nodes: TList;
var ErrMsg: string): TShowHelpResult;
var
Node: THelpNode;
begin
// check if several nodes found
if (Nodes.Count>1) then begin
Node:=nil;
Result:=ShowHelpSelector(Query,Nodes,ErrMsg,Node);
if Result<>shrSuccess then exit;
if Node=nil then exit;
end else begin
Node:=THelpNode(Nodes[0]);
end;
// show node
if Node.Owner=nil then begin
Result:=shrDatabaseNotFound;
ErrMsg:=Format(oisHelpHelpNodeHasNoHelpDatabase, ['"', Node.Title, '"']);
exit;
end;
Result:=Node.Owner.ShowHelp(Query,nil,Node,ErrMsg);
end;
function THelpDatabases.ShowHelpForQuery(Query: THelpQuery;
AutoFreeQuery: boolean; var ErrMsg: string): TShowHelpResult;
begin
try
// descendents first
if Query is THelpQueryPascalContexts then
Result:=ShowHelpForPascalContexts(THelpQueryPascalContexts(Query),ErrMsg)
else if Query is THelpQueryTOC then
Result:=ShowTableOfContents(ErrMsg)
else if Query is THelpQueryContext then
Result:=ShowHelpForContext(THelpQueryContext(Query),ErrMsg)
else if Query is THelpQueryKeyword then
Result:=ShowHelpForKeyword(THelpQueryKeyword(Query),ErrMsg)
else if Query is THelpQuerySourcePosition then
Result:=ShowHelpForSourcePosition(THelpQuerySourcePosition(Query),ErrMsg)
else if Query is THelpQueryMessage then
Result:=ShowHelpForMessageLine(THelpQueryMessage(Query),ErrMsg)
else if Query is THelpQueryClass then
Result:=ShowHelpForClass(THelpQueryClass(Query),ErrMsg)
else
Result:=shrContextNotFound;
finally
if AutoFreeQuery then Query.Free;
end;
end;
function THelpDatabases.ShowHelpForContext(Query: THelpQueryContext;
var ErrMsg: string): TShowHelpResult;
var
Nodes: TList;
HelpDB: THelpDatabase;
begin
ErrMsg:='';
Result:=shrHelpNotFound;
// search node
Nodes:=nil;
try
if Query.HelpDatabaseID<>'' then begin
HelpDB:=nil;
if not GetDatabase(Query.HelpDatabaseID,HelpDB,Result,ErrMsg) then exit;
Result:=HelpDB.GetNodesForContext(Query.Context,Nodes,ErrMsg);
if Result<>shrSuccess then exit;
end else begin
Result:=GetNodesForContext(Query.Context,Nodes,ErrMsg);
if Result<>shrSuccess then exit;
end;
// check if at least one node found
if (Nodes<>nil) then Nodes.Pack;
if (Nodes=nil) or (Nodes.Count=0) then begin
Result:=shrContextNotFound;
if Query.HelpDatabaseID<>'' then
ErrMsg:=Format(oisHelpHelpContextNotFoundInDatabase, [IntToStr(
Query.Context), '"', Query.HelpDatabaseID, '"'])
else
ErrMsg:=Format(oisHelpHelpContextNotFound,
[IntToStr(Query.Context)]);
exit;
end;
Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
finally
Nodes.Free;
end;
end;
function THelpDatabases.ShowHelpForKeyword(Query: THelpQueryKeyword;
var ErrMsg: string): TShowHelpResult;
var
Nodes: TList;
HelpDB: THelpDatabase;
begin
ErrMsg:='';
Result:=shrHelpNotFound;
// search node
Nodes:=nil;
try
if Query.HelpDatabaseID<>'' then begin
HelpDB:=nil;
if not GetDatabase(Query.HelpDatabaseID,HelpDB,Result,ErrMsg) then exit;
Result:=HelpDB.GetNodesForKeyword(Query.Keyword,Nodes,ErrMsg);
if Result<>shrSuccess then exit;
end else begin
Result:=GetNodesForKeyword(Query.Keyword,Nodes,ErrMsg);
if Result<>shrSuccess then exit;
end;
// check if at least one node found
if (Nodes<>nil) then Nodes.Pack;
if (Nodes=nil) or (Nodes.Count=0) then begin
Result:=shrContextNotFound;
if Query.HelpDatabaseID<>'' then
ErrMsg:=Format(oisHelpHelpKeywordNotFoundInDatabase, ['"',Query.Keyword,
'"', '"', Query.HelpDatabaseID, '"'])
else
ErrMsg:=Format(oisHelpHelpKeywordNotFound, ['"',Query.Keyword,'"']);
exit;
end;
Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
finally
Nodes.Free;
end;
end;
function THelpDatabases.ShowHelpForPascalContexts(
Query: THelpQueryPascalContexts; var ErrMsg: string): TShowHelpResult;
var
Nodes: TList;
begin
ErrMsg:='';
Result:=shrSuccess;
debugln('THelpDatabases.ShowHelpForPascalContexts A');
// search node
Nodes:=nil;
try
Result:=GetNodesForPascalContexts(Query.ListOfPascalHelpContextList,Nodes,
ErrMsg);
if Result<>shrSuccess then exit;
// check if at least one node found
if (Nodes<>nil) then Nodes.Pack;
if (Nodes=nil) or (Nodes.Count=0) then begin
Result:=shrHelpNotFound;
ErrMsg:=format(oisHelpNoHelpFoundForSource,
[Query.SourcePosition.y, Query.SourcePosition.x, Query.Filename]);
exit;
end;
Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
finally
Nodes.Free;
end;
end;
function THelpDatabases.ShowHelpForSourcePosition(
Query: THelpQuerySourcePosition; var ErrMsg: string): TShowHelpResult;
begin
Result:=shrHelpNotFound;
ErrMsg:='THelpDatabases.ShowHelpForPascalSource not implemented';
end;
function THelpDatabases.ShowHelpForMessageLine(Query: THelpQueryMessage;
var ErrMsg: string): TShowHelpResult;
var
Nodes: TList;
begin
ErrMsg:='';
Result:=shrSuccess;
debugln('THelpDatabases.ShowHelpForMessageLine A Msg="',Query.WholeMessage,'"');
// search node
Nodes:=nil;
try
Result:=GetNodesForMessage(Query.WholeMessage,Nodes,ErrMsg);
if Result<>shrSuccess then exit;
// check if at least one node found
if (Nodes<>nil) then Nodes.Pack;
if (Nodes=nil) or (Nodes.Count=0) then begin
// no node found for the message is not a bug
Result:=shrSuccess;
ErrMsg:='';
exit;
end;
Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
finally
Nodes.Free;
end;
end;
function THelpDatabases.ShowHelpForClass(Query: THelpQueryClass;
var ErrMsg: string): TShowHelpResult;
var
Nodes: TList;
begin
ErrMsg:='';
Result:=shrSuccess;
debugln('THelpDatabases.ShowHelpForClass A ',Query.TheClass.ClassName);
// search node
Nodes:=nil;
try
Result:=GetNodesForClass(Query.TheClass,Nodes,ErrMsg);
if Result<>shrSuccess then exit;
// check if at least one node found
if (Nodes<>nil) then Nodes.Pack;
if (Nodes=nil) or (Nodes.Count=0) then begin
// no node found for the class is not a bug
Result:=shrSuccess;
ErrMsg:='';
exit;
end;
Result:=ShowHelpForNodes(Query,Nodes,ErrMsg);
finally
Nodes.Free;
end;
end;
function THelpDatabases.GetNodesForKeyword(const HelpKeyword: string;
var ListOfNodes: TList; var ErrMsg: string): TShowHelpResult;
// if ListOfNodes<>nil then new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
begin
Result:=shrSuccess;
ErrMsg:='';
for i:=Count-1 downto 0 do begin
Result:=Items[i].GetNodesForKeyword(HelpKeyword,ListOfNodes,ErrMsg);
if Result<>shrSuccess then exit;
end;
end;
function THelpDatabases.GetNodesForContext(HelpContext: THelpContext;
var ListOfNodes: TList; var ErrMsg: string): TShowHelpResult;
// if ListOfNodes<>nil then new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
begin
Result:=shrSuccess;
ErrMsg:='';
for i:=Count-1 downto 0 do begin
Result:=Items[i].GetNodesForContext(HelpContext,ListOfNodes,ErrMsg);
if Result<>shrSuccess then exit;
end;
end;
function THelpDatabases.GetNodesForPascalContexts(
ListOfPascalHelpContextList: TList; var ListOfNodes: TList;
var ErrMsg: string): TShowHelpResult;
// if ListOfNodes<>nil then new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
begin
Result:=shrSuccess;
ErrMsg:='';
for i:=Count-1 downto 0 do begin
Result:=Items[i].GetNodesForPascalContexts(ListOfPascalHelpContextList,
ListOfNodes,ErrMsg);
if Result<>shrSuccess then exit;
end;
end;
function THelpDatabases.GetNodesForClass(AClass: TClass;
var ListOfNodes: TList; var ErrMsg: string): TShowHelpResult;
// if ListOfNodes<>nil then new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
begin
Result:=shrSuccess;
ErrMsg:='';
for i:=Count-1 downto 0 do begin
Result:=Items[i].GetNodesForClass(AClass,ListOfNodes,ErrMsg);
if Result<>shrSuccess then exit;
end;
end;
function THelpDatabases.GetNodesForMessage(const AMessage: string;
var ListOfNodes: TList; var ErrMsg: string): TShowHelpResult;
// if ListOfNodes<>nil then new nodes will be appended
// if ListOfNodes=nil and nodes exists a new list will be created
var
i: Integer;
begin
Result:=shrSuccess;
ErrMsg:='';
for i:=Count-1 downto 0 do begin
Result:=Items[i].GetNodesForMessage(AMessage,ListOfNodes,ErrMsg);
if Result<>shrSuccess then exit;
end;
end;
function THelpDatabases.ShowHelpSelector(Query: THelpQuery; Nodes: TList;
var ErrMsg: string; var Selection: THelpNode): TShowHelpResult;
// Nodes is a list of THelpNode
begin
Result:=shrSelectorError;
// TODO
ErrMsg:='THelpDatabases.ShowHelpSelector not implemented';
end;
procedure THelpDatabases.RegisterHelpDatabaseClass(NewHelpDB: THelpDatabaseClass
);
begin
if FHelpDBClasses=nil then FHelpDBClasses:=TList.Create;
if FHelpDBClasses.IndexOf(NewHelpDB)<0 then
FHelpDBClasses.Add(NewHelpDB);
end;
procedure THelpDatabases.UnregisterHelpDatabaseClass(
AHelpDB: THelpDatabaseClass);
begin
if FHelpDBClasses=nil then exit;
FHelpDBClasses.Remove(AHelpDB);
end;
function THelpDatabases.HelpDatabaseClassCount: integer;
begin
if FHelpDBClasses=nil then
Result:=0
else
Result:=FHelpDBClasses.Count;
end;
function THelpDatabases.GetHelpDatabaseClass(Index: integer
): THelpDatabaseClass;
begin
Result:=THelpDatabaseClass(FHelpDBClasses[Index]);
end;
procedure THelpDatabases.Load(Storage: TConfigStorage);
var
i: Integer;
HelpDB: THelpDatabase;
Path: String;
begin
for i:=0 to Count-1 do begin
HelpDB:=Items[i];
Path:=HelpDB.ID;
if (Path='') or (not IsValidIdent(Path)) then continue;
Storage.AppendBasePath(Path);
try
HelpDB.Load(Storage);
finally
Storage.UndoAppendBasePath;
end;
end;
end;
procedure THelpDatabases.Save(Storage: TConfigStorage);
var
i: Integer;
HelpDB: THelpDatabase;
Path: String;
begin
for i:=0 to Count-1 do begin
HelpDB:=Items[i];
Path:=HelpDB.ID;
if (Path='') or (not IsValidIdent(Path)) then continue;
Storage.AppendBasePath(Path);
try
HelpDB.Save(Storage);
finally
Storage.UndoAppendBasePath;
end;
end;
end;
{ THelpViewers }
function THelpViewers.GetItems(Index: integer): THelpViewer;
begin
Result:=THelpViewer(FItems[Index]);
end;
constructor THelpViewers.Create;
begin
FItems:=TList.Create;
end;
destructor THelpViewers.Destroy;
begin
Clear;
FItems.Free;
inherited Destroy;
end;
procedure THelpViewers.Clear;
var
i: Integer;
begin
for i:=0 to Count-1 do Items[Count-1].Free;
FItems.Clear;
end;
function THelpViewers.Count: integer;
begin
Result:=FItems.Count;
end;
function THelpViewers.GetViewersSupportingMimeType(
const MimeType: string): TList;
var
i: Integer;
begin
Result:=nil;
// LIFO: last registered, first shown
for i:=Count-1 downto 0 do
if Items[i].SupportsMimeType(MimeType) then begin
if Result=nil then Result:=TList.Create;
Result.Add(Items[i]);
end;
end;
procedure THelpViewers.RegisterViewer(AHelpViewer: THelpViewer);
begin
FItems.Add(AHelpViewer);
end;
procedure THelpViewers.UnregisterViewer(AHelpViewer: THelpViewer);
begin
FItems.Remove(AHelpViewer);
end;
procedure THelpViewers.Load(Storage: TConfigStorage);
var
i: Integer;
Viewer: THelpViewer;
Path: String;
begin
for i:=0 to Count-1 do begin
Viewer:=Items[i];
Path:=Viewer.StorageName;
if (Path='') or (not IsValidIdent(Path)) then continue;
Storage.AppendBasePath(Path);
try
Viewer.Load(Storage);
finally
Storage.UndoAppendBasePath;
end;
end;
end;
procedure THelpViewers.Save(Storage: TConfigStorage);
var
i: Integer;
Viewer: THelpViewer;
Path: String;
begin
for i:=0 to Count-1 do begin
Viewer:=Items[i];
Path:=Viewer.StorageName;
if (Path='') or (not IsValidIdent(Path)) then continue;
Storage.AppendBasePath(Path);
try
Viewer.Save(Storage);
finally
Storage.UndoAppendBasePath;
end;
end;
end;
{ THelpViewer }
procedure THelpViewer.SetSupportedMimeTypes(List: TStrings);
begin
if FSupportedMimeTypes<>nil then FSupportedMimeTypes.Free;
FSupportedMimeTypes:=nil;
end;
procedure THelpViewer.AddSupportedMimeType(const AMimeType: string);
begin
if FSupportedMimeTypes=nil then FSupportedMimeTypes:=TStringList.Create;
FSupportedMimeTypes.Add(AMimeType);
end;
constructor THelpViewer.Create;
begin
FStorageName:=ClassName;
end;
destructor THelpViewer.Destroy;
begin
FSupportedMimeTypes.Free;
inherited Destroy;
end;
function THelpViewer.SupportsTableOfContents: boolean;
begin
Result:=false;
end;
procedure THelpViewer.ShowTableOfContents(Node: THelpNode);
begin
raise EHelpSystemException.Create('THelpViewer.ShowTableOfContents not implemented');
end;
function THelpViewer.SupportsMimeType(const AMimeType: string): boolean;
begin
Result:=false;
if FSupportedMimeTypes<>nil then
Result:=(FSupportedMimeTypes.IndexOf(AMimeType)>=0);
end;
function THelpViewer.ShowNode(Node: THelpNode; var ErrMsg: string
): TShowHelpResult;
begin
// for descendents to override
Result:=shrViewerError;
ErrMsg:='THelpViewer.ShowNode not implemented for this help type';
end;
procedure THelpViewer.Hide;
begin
// override this
end;
procedure THelpViewer.Assign(Source: TPersistent);
begin
if Source is THelpViewer then begin
end;
inherited Assign(Source);
end;
procedure THelpViewer.Load(Storage: TConfigStorage);
begin
end;
procedure THelpViewer.Save(Storage: TConfigStorage);
begin
end;
function THelpViewer.GetLocalizedName: string;
begin
Result:=StorageName;
end;
{ THelpNode }
constructor THelpNode.Create(TheOwner: THelpDatabase; Node: THelpNode);
begin
FOwner:=TheOwner;
Assign(Node);
end;
constructor THelpNode.Create(TheOwner: THelpDatabase; const TheTitle,
TheURL, TheID: string; TheContext: THelpContext);
begin
FOwner:=TheOwner;
FHelpType:=hntURLIDContext;
FTitle:=TheTitle;
FURL:=TheURL;
FID:=TheID;
FContext:=TheContext;
end;
constructor THelpNode.CreateURL(TheOwner: THelpDatabase; const TheTitle,
TheURL: string);
begin
FOwner:=TheOwner;
FHelpType:=hntURL;
FTitle:=TheTitle;
FURL:=TheURL;
end;
constructor THelpNode.CreateID(TheOwner: THelpDatabase;
const TheTitle, TheID: string);
begin
FOwner:=TheOwner;
FHelpType:=hntID;
FTitle:=TheTitle;
FID:=TheID;
end;
constructor THelpNode.CreateURLID(TheOwner: THelpDatabase;
const TheTitle, TheURL, TheID: string);
begin
FOwner:=TheOwner;
FHelpType:=hntURLID;
FTitle:=TheTitle;
FURL:=TheURL;
FID:=TheID;
end;
constructor THelpNode.CreateContext(TheOwner: THelpDatabase;
const TheTitle: string; TheContext: THelpContext);
begin
FOwner:=TheOwner;
FHelpType:=hntContext;
FTitle:=TheTitle;
FContext:=TheContext;
end;
constructor THelpNode.CreateURLContext(TheOwner: THelpDatabase; const TheTitle,
TheURL: string; TheContext: THelpContext);
begin
FOwner:=TheOwner;
FHelpType:=hntURLContext;
FTitle:=TheTitle;
FURL:=TheURL;
FContext:=TheContext;
end;
function THelpNode.URLValid: boolean;
begin
Result:=FHelpType in [hntURL,hntURLIDContext,hntURLID,hntURLContext];
end;
function THelpNode.IDValid: boolean;
begin
Result:=FHelpType in [hntURLIDContext,hntURLID,hntID];
end;
function THelpNode.ContextValid: boolean;
begin
Result:=FHelpType in [hntURLIDContext,hntURLContext,hntContext];
end;
procedure THelpNode.Assign(Source: TPersistent);
var
Node: THelpNode;
begin
if Source is THelpNode then begin
Node:=THelpNode(Source);
FHelpType:=Node.HelpType;
FTitle:=Node.Title;
FURL:=Node.URL;
FContext:=Node.Context;
end else
inherited Assign(Source);
end;
{ THelpDBItem }
constructor THelpDBItem.Create(TheNode: THelpNode);
begin
Node:=TheNode
end;
destructor THelpDBItem.Destroy;
begin
Node.Free;
inherited Destroy;
end;
{ TPascalHelpContextList }
function TPascalHelpContextList.GetItems(Index: integer): TPascalHelpContext;
begin
Result:=fItems[Index];
end;
procedure TPascalHelpContextList.Add(const Context: TPascalHelpContext);
begin
inc(FCount);
ReAllocMem(fItems,SizeOf(TPascalHelpContext)*FCount);
// to prevent freeing uninitialized strings, initialize the new strings to nil
FillChar(fItems[FCount-1], SizeOf(TPascalHelpContext), 0);
fItems[FCount-1]:=Context;
end;
procedure TPascalHelpContextList.Insert(Index: integer;
const Context: TPascalHelpContext);
begin
inc(FCount);
ReAllocMem(fItems,SizeOf(TPascalHelpContext)*FCount);
if Index<FCount-1 then
System.Move(fItems[Index],fItems[Index+1],
SizeOf(TPascalHelpContext)*(FCount-Index-1));
// to prevent freeing uninitialized strings, initialize the new strings to nil
FillChar(fItems[Index], SizeOf(TPascalHelpContext), 0);
fItems[Index]:=Context;
end;
procedure TPascalHelpContextList.Clear;
var
Index: Integer;
begin
// Set all item strings to '', so fpc will finalize them.
for Index := 0 to FCount-1 do
fItems[Index].Context := '';
ReAllocMem(fItems,0);
end;
destructor TPascalHelpContextList.Destroy;
begin
Clear;
inherited Destroy;
end;
function TPascalHelpContextList.IsEqual(AList: TPascalHelpContextList): boolean;
begin
Result:=CompareList(AList)=0;
end;
function TPascalHelpContextList.CompareList(AList: TPascalHelpContextList
): integer;
var
i: Integer;
begin
i:=0;
while (i<Count) and (i<AList.Count) do begin
if fItems[i].Descriptor<AList.fItems[i].Descriptor then begin
Result:=1;
exit;
end else if fItems[i].Descriptor>AList.fItems[i].Descriptor then begin
Result:=-1;
exit;
end else begin
Result:=CompareText(fItems[i].Context,AList.fItems[i].Context);
if Result<>0 then exit;
end;
inc(i);
end;
if Count>i then
Result:=-1
else
Result:=1;
end;
{ THelpDBISourceFile }
procedure THelpDBISourceFile.SetFilename(const AValue: string);
begin
FFilename:=AValue;
end;
constructor THelpDBISourceFile.Create(TheNode: THelpNode;
const TheFilename: string);
begin
inherited Create(TheNode);
FFilename:=TrimFilename(SetDirSeparators(TheFilename));
end;
function THelpDBISourceFile.FileMatches(const AFilename: string): boolean;
begin
if (FFilename<>'') and (AFilename<>'') then
Result:=CompareFilenames(GetFullFilename,AFilename)=0
else
Result:=false;
end;
function THelpDBISourceFile.GetFullFilename: string;
var
BaseDir: String;
ExpFilename: String;
begin
ExpFilename:=FFilename;
if (HelpDatabases<>nil) then
IDEMacros.SubstituteMacros(ExpFilename);
ExpFilename:=TrimFilename(ExpFilename);
if FilenameIsAbsolute(ExpFilename) then
Result:=ExpFilename
else begin
BaseDir:=GetBasePath;
Result:=BaseDir+ExpFilename;
end;
end;
function THelpDBISourceFile.GetBasePath: string;
begin
if BasePathObject=nil then
Result:=''
else
Result:=AppendPathDelim(
HelpDatabases.GetBaseDirectoryForBasePathObject(BasePathObject));
end;
{ THelpDBISourceDirectory }
constructor THelpDBISourceDirectory.Create(TheNode: THelpNode;
const TheFilename, TheFileMask: string; Recursive: boolean);
begin
inherited Create(TheNode,TheFilename);
FFileMask:=SetDirSeparators(TheFileMask);
WithSubDirectories:=Recursive;
end;
function THelpDBISourceDirectory.FileMatches(const AFilename: string
): boolean;
var
TheDirectory: String;
begin
Result:=false;
//debugln('THelpDBISourceDirectory.FileMatches AFilename="',AFilename,'" FFilename="',FFilename,'"');
if (FFilename='') or (AFilename='') then exit;
TheDirectory:=GetFullFilename;
//debugln('THelpDBISourceDirectory.FileMatches TheDirectory="',TheDirectory,'" WithSubDirectories=',dbgs(WithSubDirectories));
if WithSubDirectories then begin
if not FileIsInPath(AFilename,TheDirectory) then exit;
end else begin
if not FileIsInDirectory(AFilename,TheDirectory) then exit;
end;
//debugln('THelpDBISourceDirectory.FileMatches FileMask="',FileMask,'"');
if (FileMask<>'')
and (not FileInFilenameMasks(ExtractFilename(AFilename),FileMask)) then exit;
//debugln('THelpDBISourceDirectory.FileMatches Success');
Result:=true;
end;
{ THelpQuery }
constructor THelpQuery.Create(const TheHelpDatabaseID: THelpDatabaseID);
begin
FHelpDatabaseID:=TheHelpDatabaseID;
end;
{ THelpQueryContext }
constructor THelpQueryContext.Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheContext: THelpContext);
begin
inherited Create(TheHelpDatabaseID);
FContext:=TheContext;
end;
{ THelpQueryKeyword }
constructor THelpQueryKeyword.Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheKeyWord: string);
begin
inherited Create(TheHelpDatabaseID);
FKeyword:=TheKeyWord;
end;
{ THelpQuerySourcePosition }
constructor THelpQuerySourcePosition.Create(
const TheHelpDatabaseID: THelpDatabaseID; const TheFilename: string;
const SrcPos: TPoint);
begin
inherited Create(TheHelpDatabaseID);
FFilename:=TheFilename;
FSourcePosition:=SrcPos;
end;
{ THelpQueryPascalContext }
constructor THelpQueryPascalContexts.Create(
const TheHelpDatabaseID: THelpDatabaseID; const TheFilename: string;
const SrcPos: TPoint; ContextLists: TList);
begin
inherited Create(TheHelpDatabaseID,TheFilename,SrcPos);
FContextLists:=ContextLists;
end;
{ THelpQueryMessage }
constructor THelpQueryMessage.Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheMessage: string);
begin
inherited Create(TheHelpDatabaseID);
FWholeMessage:=TheMessage;
end;
{ THelpQueryClass }
constructor THelpQueryClass.Create(const TheHelpDatabaseID: THelpDatabaseID;
const AClass: TClass);
begin
inherited Create(TheHelpDatabaseID);
FTheClass:=AClass;
end;
{ THelpQueryNode }
constructor THelpQueryNode.Create(const TheHelpDatabaseID: THelpDatabaseID;
const TheNode: THelpNode);
begin
inherited Create(TheHelpDatabaseID);
FNode:=TheNode;
end;
{ THelpBasePathObject }
procedure THelpBasePathObject.SetBasePath(const AValue: string);
begin
if FBasePath=AValue then exit;
FBasePath:=AValue;
end;
initialization
HelpDatabases:=nil;
end.
Reference in New Issue View Git Blame Copy Permalink