{ ***************************************************************************** * * * 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 IndexAList.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.