mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-16 21:09:30 +02:00
implemented Help for fpc messages using the fpc comment file (errore.msg) and the custom pages in the wiki
git-svn-id: trunk@9174 -
This commit is contained in:
mattias
parent
bf86223f23
commit
8703fcd1e2
@ -37,37 +37,298 @@ unit HelpFPCMessages;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, HelpIntf, HelpHTML;
|
||||
Classes, SysUtils, LCLProc, Dialogs, FileUtil, TextTools, MacroIntf,
|
||||
HelpIntf, HelpHTML;
|
||||
|
||||
const
|
||||
lihcFPCMessages = 'FreePascal Compiler messages';
|
||||
lihFPCMessagesURL = 'http://wiki.lazarus.freepascal.org/index.php/';
|
||||
|
||||
type
|
||||
|
||||
{ TFPCMessagesHelpDatabase }
|
||||
|
||||
TFPCMessagesHelpDatabase = class(THTMLHelpDatabase)
|
||||
private
|
||||
FDefaultNode: THelpNode;
|
||||
FFoundComment: string;
|
||||
FLastMessage: string;
|
||||
procedure SetFoundComment(const AValue: string);
|
||||
procedure SetLastMessage(const AValue: string);
|
||||
public
|
||||
constructor Create(TheID: THelpDatabaseID); override;
|
||||
destructor Destroy; override;
|
||||
function GetNodesForMessage(const AMessage: string; MessageParts: TStrings;
|
||||
var ListOfNodes: THelpNodeQueryList;
|
||||
var ErrMsg: string): TShowHelpResult; override;
|
||||
function ShowHelp(Query: THelpQuery; BaseNode, NewNode: THelpNode;
|
||||
QueryItem: THelpQueryItem;
|
||||
var ErrMsg: string): TShowHelpResult; override;
|
||||
property DefaultNode: THelpNode read FDefaultNode;
|
||||
property LastMessage: string read FLastMessage write SetLastMessage;
|
||||
property FoundComment: string read FFoundComment write SetFoundComment;
|
||||
end;
|
||||
|
||||
var
|
||||
FPCMessagesHelpDB: THelpDatabase;
|
||||
|
||||
procedure CreateFPCMessagesHelpDB;
|
||||
function AddFPCMessageHelpItem(const Title, URL, RegularExpression: string
|
||||
): THelpDBIRegExprMessage;
|
||||
|
||||
function FindFPCMessageComment(const CommentFile, Msg: string): string;
|
||||
procedure ParseFPCMessagesFile(Lines: TStrings;
|
||||
const SearchMessage: string; var FoundComment: string);
|
||||
|
||||
implementation
|
||||
|
||||
procedure CreateFPCMessagesHelpDB;
|
||||
var
|
||||
HTMLHelp: THTMLHelpDatabase;
|
||||
FPCHelp: TFPCMessagesHelpDatabase;
|
||||
StartNode: THelpNode;
|
||||
begin
|
||||
FPCMessagesHelpDB:=HelpDatabases.CreateHelpDatabase(lihcFPCMessages,
|
||||
THTMLHelpDatabase,true);
|
||||
HTMLHelp:=FPCMessagesHelpDB as THTMLHelpDatabase;
|
||||
|
||||
HTMLHelp.BasePathObject:=
|
||||
THelpBasePathObject.Create('http://wiki.lazarus.freepascal.org/index.php/');
|
||||
TFPCMessagesHelpDatabase,true);
|
||||
FPCHelp:=FPCMessagesHelpDB as TFPCMessagesHelpDatabase;
|
||||
FPCHelp.DefaultBaseURL:=lihFPCMessagesURL;
|
||||
|
||||
// HTML nodes
|
||||
StartNode:=THelpNode.CreateURLID(HTMLHelp,'FreePascal Compiler messages',
|
||||
StartNode:=THelpNode.CreateURLID(FPCHelp,'FreePascal Compiler messages',
|
||||
'file://Build_messages#FreePascal_Compiler_messages',lihcFPCMessages);
|
||||
HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,StartNode);
|
||||
HTMLHelp.RegisterItemWithNode(StartNode);
|
||||
|
||||
|
||||
FPCHelp.TOCNode:=THelpNode.Create(FPCHelp,StartNode);// once as TOC
|
||||
FPCHelp.RegisterItemWithNode(StartNode);// and once as normal page
|
||||
|
||||
// register messages
|
||||
AddFPCMessageHelpItem('Can''t find unit',
|
||||
'FPC_message:_Can%27t_find_unit',': Can''t find unit ');
|
||||
end;
|
||||
|
||||
function AddFPCMessageHelpItem(const Title, URL, RegularExpression: string
|
||||
): THelpDBIRegExprMessage;
|
||||
begin
|
||||
Result:=THelpDBIRegExprMessage.Create(
|
||||
THelpNode.CreateURL(FPCMessagesHelpDB,Title,'file://'+URL),
|
||||
RegularExpression,'I');
|
||||
FPCMessagesHelpDB.RegisterItem(Result);
|
||||
end;
|
||||
|
||||
function FindFPCMessageComment(const CommentFile, Msg: string): string;
|
||||
var
|
||||
sl: TStringList;
|
||||
begin
|
||||
Result:='';
|
||||
sl:=TStringList.Create;
|
||||
try
|
||||
sl.LoadFromFile(CommentFile);
|
||||
ParseFPCMessagesFile(sl,Msg,Result);
|
||||
finally
|
||||
sl.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure ParseFPCMessagesFile(Lines: TStrings;
|
||||
const SearchMessage: string; var FoundComment: string);
|
||||
var
|
||||
i: integer;
|
||||
Line: string;
|
||||
|
||||
procedure Error(const ErrMsg: string);
|
||||
begin
|
||||
raise Exception.Create('Line='+IntToStr(i+1)+': '+ErrMsg+' in "'+Line+'"');
|
||||
end;
|
||||
|
||||
function CompareTextWithSearchMessage(const Command: string;
|
||||
TypeStart, TxtStart: integer): boolean;
|
||||
var
|
||||
RegularExpression: String;
|
||||
p: Integer;
|
||||
begin
|
||||
Result:=false;
|
||||
RegularExpression:=copy(Command,TxtStart,length(Command));
|
||||
// replace all $d variables with (.*)
|
||||
p:=length(RegularExpression);
|
||||
while (p>0) do begin
|
||||
if (RegularExpression[p]='$') then begin
|
||||
if (p<length(RegularExpression))
|
||||
and (RegularExpression[p+1] in ['1'..'9']) then begin
|
||||
RegularExpression:=copy(RegularExpression,1,p-1)+'(.*)'
|
||||
+copy(RegularExpression,p+2,length(RegularExpression));
|
||||
end else begin
|
||||
RegularExpression:=copy(RegularExpression,1,p-1)+'\'
|
||||
+copy(RegularExpression,p,length(RegularExpression));
|
||||
end;
|
||||
end;
|
||||
dec(p);
|
||||
end;
|
||||
case Command[TypeStart] of
|
||||
'F': RegularExpression:='Fatal: '+RegularExpression;
|
||||
'E': RegularExpression:='Error: '+RegularExpression;
|
||||
'N': RegularExpression:='Note: '+RegularExpression;
|
||||
'I': RegularExpression:='Info: '+RegularExpression;
|
||||
'H': RegularExpression:='Hint: '+RegularExpression;
|
||||
end;
|
||||
|
||||
try
|
||||
Result:=REMatches(SearchMessage,RegularExpression);
|
||||
except
|
||||
on E: Exception do begin
|
||||
WriteLn('CompareTextWithSearchMessage RegExpr Error ',E.Message,' RegularExpression="'+RegularExpression+'"');
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
// debugging:
|
||||
//if System.Pos('is assigned but never used',Command)>0 then WriteLn('CompareTextWithSearchMessage "',RegularExpression,'" Result=',Result);
|
||||
end;
|
||||
|
||||
var
|
||||
EqualPos: LongInt;
|
||||
Comment: String;
|
||||
BracketLevel: Integer;
|
||||
Command: String;
|
||||
x: Integer;
|
||||
PartStart: Integer;
|
||||
TypeStart: LongInt;
|
||||
TxtStart: LongInt;
|
||||
begin
|
||||
FoundComment:='';
|
||||
Comment:='';
|
||||
Command:='';
|
||||
BracketLevel:=0;
|
||||
for i:=0 to Lines.Count-1 do begin
|
||||
Line:=Lines[i];
|
||||
if (Trim(Line)='') or (Line[1]='#') then continue;
|
||||
|
||||
// example:
|
||||
// general_t_compilername=01000_T_Compiler: $1
|
||||
// % When the \var{-vt} switch is used, this line tells you what compiler
|
||||
// % is used.
|
||||
if Line[1]='%' then begin
|
||||
if BracketLevel>0 then
|
||||
Error('unclosed bracket in lines before');
|
||||
Comment:=Comment+copy(Line,2,length(Line));
|
||||
end else begin
|
||||
if BracketLevel=0 then begin
|
||||
// end old message
|
||||
if Command<>'' then begin
|
||||
if CompareByte(Command[1],'option_',7)=0 then begin
|
||||
// option
|
||||
end else begin
|
||||
EqualPos:=System.Pos('=',Command);
|
||||
if EqualPos<1 then Error('missing =');
|
||||
PartStart:=EqualPos+1;
|
||||
TypeStart:=PartStart;
|
||||
while (TypeStart<=length(Command)) and (Command[TypeStart]<>'_') do
|
||||
inc(TypeStart);
|
||||
if TypeStart=PartStart then Error('missing message type');
|
||||
inc(TypeStart);
|
||||
TxtStart:=TypeStart;
|
||||
while (TxtStart<=length(Command)) and (Command[TxtStart]<>'_') do
|
||||
inc(TxtStart);
|
||||
if TxtStart=TypeStart then Error('missing message text');
|
||||
inc(TxtStart);
|
||||
if SearchMessage<>'' then begin
|
||||
if CompareTextWithSearchMessage(Command,TypeStart,TxtStart) then
|
||||
begin
|
||||
FoundComment:=Trim(Comment);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
// start a new message
|
||||
Comment:='';
|
||||
Command:=Line;
|
||||
end else begin
|
||||
// continue command
|
||||
Command:=Command+Line;
|
||||
end;
|
||||
// update BracketLevel
|
||||
for x:=1 to length(Line) do begin
|
||||
case Line[x] of
|
||||
'[': inc(BracketLevel);
|
||||
']':
|
||||
if BracketLevel>0 then
|
||||
dec(BracketLevel)
|
||||
else
|
||||
Error('closing a bracket, which was not opened.');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TFPCMessagesHelpDatabase }
|
||||
|
||||
procedure TFPCMessagesHelpDatabase.SetFoundComment(const AValue: string);
|
||||
begin
|
||||
if FFoundComment=AValue then exit;
|
||||
FFoundComment:=AValue;
|
||||
end;
|
||||
|
||||
procedure TFPCMessagesHelpDatabase.SetLastMessage(const AValue: string);
|
||||
begin
|
||||
if FLastMessage=AValue then exit;
|
||||
FLastMessage:=AValue;
|
||||
end;
|
||||
|
||||
constructor TFPCMessagesHelpDatabase.Create(TheID: THelpDatabaseID);
|
||||
begin
|
||||
inherited Create(TheID);
|
||||
FDefaultNode:=THelpNode.CreateURL(Self,'FPC messages: Appendix',
|
||||
'http://lazarus-ccr.sourceforge.net/fpcdoc/user/userap3.html#x81-168000C');
|
||||
end;
|
||||
|
||||
destructor TFPCMessagesHelpDatabase.Destroy;
|
||||
begin
|
||||
FreeAndNil(FDefaultNode);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TFPCMessagesHelpDatabase.GetNodesForMessage(const AMessage: string;
|
||||
MessageParts: TStrings; var ListOfNodes: THelpNodeQueryList;
|
||||
var ErrMsg: string): TShowHelpResult;
|
||||
var
|
||||
Filename: String;
|
||||
begin
|
||||
Result:=inherited GetNodesForMessage(AMessage, MessageParts, ListOfNodes,
|
||||
ErrMsg);
|
||||
if (ListOfNodes<>nil) and (ListOfNodes.Count>0) then exit;
|
||||
|
||||
// no node found -> add default node
|
||||
LastMessage:=AMessage;
|
||||
Filename:='$(FPCSrcDir)';
|
||||
IDEMacros.SubstituteMacros(Filename);
|
||||
//DebugLn('TFPCMessagesHelpDatabase.GetNodesForMessage Filename="',Filename,'"');
|
||||
if (Filename<>'') then begin
|
||||
// TODO: use the same language as the compiler
|
||||
Filename:=AppendPathDelim(Filename)
|
||||
+SetDirSeparators('compiler/msg/errore.msg');
|
||||
if FileExists(Filename) then begin
|
||||
FoundComment:=FindFPCMessageComment(Filename,AMessage);
|
||||
if FoundComment<>'' then begin
|
||||
Result:=shrSuccess;
|
||||
CreateNodeQueryListAndAdd(DefaultNode,nil,ListOfNodes,true);
|
||||
//DebugLn('TFPCMessagesHelpDatabase.GetNodesForMessage ',FoundComment);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFPCMessagesHelpDatabase.ShowHelp(Query: THelpQuery; BaseNode,
|
||||
NewNode: THelpNode; QueryItem: THelpQueryItem; var ErrMsg: string
|
||||
): TShowHelpResult;
|
||||
begin
|
||||
if NewNode=DefaultNode then begin
|
||||
if FoundComment<>'' then begin
|
||||
Result:=shrSuccess;
|
||||
MessageDlg('Help',FoundComment,mtInformation,[mbOk],0);
|
||||
end else begin
|
||||
Result:=shrHelpNotFound;
|
||||
end;
|
||||
end else begin
|
||||
Result:=inherited ShowHelp(Query, BaseNode, NewNode, QueryItem, ErrMsg);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -34,7 +34,7 @@ interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LCLProc, Forms, Controls, Buttons, StdCtrls, Dialogs,
|
||||
ExtCtrls, LResources,
|
||||
ExtCtrls, LResources, FileUtil,
|
||||
CodeToolManager, CodeAtom, CodeCache, CustomCodeTool, CodeTree,
|
||||
PascalParserTool, FindDeclarationTool,
|
||||
PropEdits, ObjectInspector, FormEditingIntf, ProjectIntf,
|
||||
@ -243,6 +243,7 @@ begin
|
||||
Result:=TLazPackage(BasePathObject).Directory;
|
||||
if Result<>'' then
|
||||
IDEMacros.SubstituteMacros(Result);
|
||||
Result:=AppendPathDelim(Result);
|
||||
end;
|
||||
|
||||
function TIDEHelpDatabases.ShowHelpForSourcePosition(
|
||||
@ -286,8 +287,8 @@ procedure THelpManager.RegisterIDEHelpDatabases;
|
||||
// HTML nodes for the IDE
|
||||
StartNode:=THelpNode.CreateURLID(HTMLHelp,'Lazarus',
|
||||
'file://docs/index.html',lihcStartPage);
|
||||
HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,StartNode);
|
||||
HTMLHelp.RegisterItemWithNode(StartNode);
|
||||
HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,StartNode);// once as TOC
|
||||
HTMLHelp.RegisterItemWithNode(StartNode);// and once as normal page
|
||||
end;
|
||||
|
||||
procedure CreateRTLHelpDB;
|
||||
@ -307,9 +308,9 @@ procedure THelpManager.RegisterIDEHelpDatabases;
|
||||
FPDocNode:=THelpNode.CreateURL(HTMLHelp,
|
||||
'RTL - Free Pascal Run Time Library Units',
|
||||
'file://index.html');
|
||||
HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,FPDocNode);
|
||||
HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,FPDocNode);// once as TOC
|
||||
DirItem:=THelpDBISourceDirectory.Create(FPDocNode,'$(FPCSrcDir)/rtl',
|
||||
'*.pp;*.pas',true);
|
||||
'*.pp;*.pas',true);// and once as normal page
|
||||
HTMLHelp.RegisterItem(DirItem);
|
||||
end;
|
||||
|
||||
@ -330,9 +331,9 @@ procedure THelpManager.RegisterIDEHelpDatabases;
|
||||
FPDocNode:=THelpNode.CreateURL(HTMLHelp,
|
||||
'FCL - Free Pascal Component Library Units',
|
||||
'file://index.html');
|
||||
HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,FPDocNode);
|
||||
HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,FPDocNode);// once as TOC
|
||||
DirItem:=THelpDBISourceDirectory.Create(FPDocNode,'$(FPCSrcDir)/fcl',
|
||||
'*.pp;*.pas',true);
|
||||
'*.pp;*.pas',true);// and once as normal page
|
||||
HTMLHelp.RegisterItem(DirItem);
|
||||
end;
|
||||
|
||||
@ -353,9 +354,9 @@ procedure THelpManager.RegisterIDEHelpDatabases;
|
||||
FPDocNode:=THelpNode.CreateURL(HTMLHelp,
|
||||
'LCL - Lazarus Component Library Units',
|
||||
'file://index.html');
|
||||
HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,FPDocNode);
|
||||
HTMLHelp.TOCNode:=THelpNode.Create(HTMLHelp,FPDocNode);// once as TOC
|
||||
DirItem:=THelpDBISourceDirectory.Create(FPDocNode,'$(LazarusDir)/lcl',
|
||||
'*.pp;*.pas',false);
|
||||
'*.pp;*.pas',false);// and once as normal page
|
||||
HTMLHelp.RegisterItem(DirItem);
|
||||
end;
|
||||
|
||||
|
||||
@ -45,7 +45,7 @@ type
|
||||
function GetEffectiveBaseURL: string;
|
||||
procedure Load(Storage: TConfigStorage); override;
|
||||
procedure Save(Storage: TConfigStorage); override;
|
||||
property DefaultBaseURL: string read FDefaultBaseURL write SetDefaultBaseURL;
|
||||
property DefaultBaseURL: string read FDefaultBaseURL write SetDefaultBaseURL;// used, if BaseURL is empty
|
||||
published
|
||||
property BaseURL: string read FBaseURL write SetBaseURL stored IsBaseURLStored;
|
||||
end;
|
||||
@ -53,7 +53,7 @@ type
|
||||
|
||||
{ THTMLBrowserHelpViewer }
|
||||
|
||||
//TOnFindDefaultBrowser = procedure(var DefaultBrowser: string) of object;
|
||||
TOnFindDefaultBrowser = procedure(var DefaultBrowser, Params: string) of object;
|
||||
|
||||
THTMLBrowserHelpViewer = class(THelpViewer)
|
||||
private
|
||||
@ -88,10 +88,10 @@ procedure THTMLHelpDatabase.SetBaseURL(const AValue: string);
|
||||
begin
|
||||
if FBaseURL=AValue then exit;
|
||||
//debugln('THTMLHelpDatabase.SetBaseURL ',dbgsName(Self),' ',AValue);
|
||||
if AValue<>'' then
|
||||
FBaseURL:=AValue
|
||||
if AValue=DefaultBaseURL then
|
||||
FBaseURL:=''
|
||||
else
|
||||
FBaseURL:=DefaultBaseURL;
|
||||
FBaseURL:=AValue;
|
||||
end;
|
||||
|
||||
procedure THTMLHelpDatabase.SetDefaultBaseURL(const AValue: string);
|
||||
@ -131,16 +131,20 @@ begin
|
||||
|
||||
// make URL absolute
|
||||
SplitURL(URL,URLType,URLPath,URLParams);
|
||||
debugln('THTMLHelpDatabase.ShowHelp A NewNode.URL=',URL,' URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams);
|
||||
debugln('THTMLHelpDatabase.ShowURL A NewNode.URL=',URL,' URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams);
|
||||
|
||||
if URLType='file' then begin
|
||||
if not URLFilenameIsAbsolute(URLPath) then begin
|
||||
EffBaseURL:=GetEffectiveBaseURL;
|
||||
SplitURL(EffBaseURL,BaseURLType,BaseURLPath,BaseURLParams);
|
||||
if (BaseURLType='file') and (BaseURLPath<>'') then
|
||||
URLPath:=BaseURLPath+URLPath;
|
||||
//DebugLn('THTMLHelpDatabase.ShowURL file relative, making absolute ... EffBaseURL="',EffBaseURL,'"');
|
||||
if EffBaseURL<>'' then begin
|
||||
SplitURL(EffBaseURL,BaseURLType,BaseURLPath,BaseURLParams);
|
||||
if (BaseURLPath<>'') then
|
||||
URLPath:=BaseURLPath+URLPath;
|
||||
URLType:=BaseURLType;
|
||||
end;
|
||||
end;
|
||||
if (not FileExists(URLPath)) then begin
|
||||
if (URLType='file') and (not FileExists(URLPath)) then begin
|
||||
Result:=shrContextNotFound;
|
||||
ErrMsg:=Format(oisHelpTheHelpDatabaseWasUnableToFindFile, ['"', ID,
|
||||
'"', '"', URLPath, '"']);
|
||||
@ -148,7 +152,7 @@ begin
|
||||
end;
|
||||
end;
|
||||
FullURL:=CombineURL(URLType,URLPath,URLParams);
|
||||
debugln('THTMLHelpDatabase.ShowHelp B URL=',URL,' URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams);
|
||||
debugln('THTMLHelpDatabase.ShowURL B URL=',URL,' URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams);
|
||||
|
||||
// call viewer
|
||||
Node:=nil;
|
||||
@ -179,12 +183,17 @@ begin
|
||||
Result:='';
|
||||
if BaseURL<>'' then begin
|
||||
Result:=BaseURL;
|
||||
if (HelpDatabases<>nil) then
|
||||
if (IDEMacros<>nil) then
|
||||
IDEMacros.SubstituteMacros(Result);
|
||||
//debugln('THTMLHelpDatabase.GetEffectiveBaseURL BaseURL="',Result,'"');
|
||||
//debugln('THTMLHelpDatabase.GetEffectiveBaseURL using BaseURL="',Result,'"');
|
||||
end else if (BasePathObject<>nil) and (Databases<>nil) then begin
|
||||
Result:=Databases.GetBaseURLForBasePathObject(BasePathObject);
|
||||
//debugln('THTMLHelpDatabase.GetEffectiveBaseURL BasePathObject="',Result,'"');
|
||||
//debugln('THTMLHelpDatabase.GetEffectiveBaseURL using BasePathObject="',Result,'"');
|
||||
end else if DefaultBaseURL<>'' then begin
|
||||
Result:=DefaultBaseURL;
|
||||
if (IDEMacros<>nil) then
|
||||
IDEMacros.SubstituteMacros(Result);
|
||||
//debugln('THTMLHelpDatabase.GetEffectiveBaseURL using DefaultBaseURL="',Result,'"');
|
||||
end;
|
||||
if (Result<>'') and (Result[length(Result)]<>'/') then
|
||||
Result:=Result+'/';
|
||||
|
||||
@ -659,7 +659,8 @@ type
|
||||
end;
|
||||
|
||||
|
||||
{ THelpBasePathObject }
|
||||
{ THelpBasePathObject
|
||||
Simple class to store a base file path for help databases. }
|
||||
|
||||
THelpBasePathObject = class(TPersistent)
|
||||
private
|
||||
@ -672,8 +673,19 @@ type
|
||||
property BasePath: string read FBasePath write SetBasePath;
|
||||
end;
|
||||
|
||||
TOnFindDefaultBrowser = procedure(var DefaultBrowser, Params: string) of object;
|
||||
|
||||
{ THelpBaseURLObject
|
||||
Simple class to store a base URL path for help databases. }
|
||||
|
||||
THelpBaseURLObject = class(TPersistent)
|
||||
private
|
||||
FBaseURL: string;
|
||||
protected
|
||||
procedure SetBaseURL(const AValue: string);
|
||||
public
|
||||
constructor Create;
|
||||
constructor Create(const TheBaseURL: string);
|
||||
property BaseURL: string read FBaseURL write SetBaseURL;
|
||||
end;
|
||||
|
||||
{ TBaseHelpManager }
|
||||
|
||||
@ -746,9 +758,16 @@ 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 ExtractURLPath(const URL: string): string;
|
||||
function ExtractURLDirectory(const URL: string): string;
|
||||
function TrimUrl(const URL: string): string;
|
||||
function IsFileURL(const URL: string): boolean;
|
||||
|
||||
procedure CreateListAndAdd(const AnObject: TObject; var List: TList;
|
||||
OnlyIfNotExists: boolean);
|
||||
procedure CreateNodeQueryListAndAdd(const ANode: THelpNode;
|
||||
const QueryItem: THelpQueryItem;
|
||||
var List: THelpNodeQueryList; OnlyIfNotExists: boolean);
|
||||
|
||||
implementation
|
||||
|
||||
@ -911,12 +930,7 @@ end;
|
||||
|
||||
function URLFilenameIsAbsolute(const Filename: string): boolean;
|
||||
begin
|
||||
{$warnings off}
|
||||
if PathDelim='/' then
|
||||
Result:=FilenameIsAbsolute(Filename)
|
||||
else
|
||||
Result:=FilenameIsAbsolute(SetDirSeparators(Filename));
|
||||
{$warnings on}
|
||||
Result:=FilenameIsUnixAbsolute(Filename);
|
||||
end;
|
||||
|
||||
function FindURLPathStart(const URL: string): integer;
|
||||
@ -975,6 +989,20 @@ begin
|
||||
Result:=CombineURL(URLType,TrimFilename(URLPath),URLParams);
|
||||
end;
|
||||
|
||||
function IsFileURL(const URL: string): boolean;
|
||||
begin
|
||||
Result:=(length(URL)>=7)
|
||||
and (CompareByte(URL[1],'file://',7)=0);
|
||||
end;
|
||||
|
||||
function ExtractURLPath(const URL: string): string;
|
||||
var
|
||||
URLType, URLPath, URLParams: string;
|
||||
begin
|
||||
SplitURL(URL,URLType,URLPath,URLParams);
|
||||
Result:=URLPath;
|
||||
end;
|
||||
|
||||
procedure CreateListAndAdd(const AnObject: TObject; var List: TList;
|
||||
OnlyIfNotExists: boolean);
|
||||
begin
|
||||
@ -1463,15 +1491,36 @@ end;
|
||||
function THelpDatabases.GetBaseURLForBasePathObject(BasePathObject: TObject
|
||||
): string;
|
||||
begin
|
||||
Result:=GetBaseDirectoryForBasePathObject(BasePathObject);
|
||||
if Result='' then exit;
|
||||
Result:=FilenameToURL(Result);
|
||||
// this method will be overriden by the IDE
|
||||
// provide some useful defaults:
|
||||
if (BasePathObject is THelpBaseURLObject) then
|
||||
Result:=THelpBaseURLObject(BasePathObject).BaseURL
|
||||
else begin
|
||||
// otherwise fetch a filename
|
||||
Result:=GetBaseDirectoryForBasePathObject(BasePathObject);
|
||||
if Result='' then exit;
|
||||
Result:=FilenameToURL(Result);
|
||||
end;
|
||||
Result:=AppendPathDelim(Result);
|
||||
end;
|
||||
|
||||
function THelpDatabases.GetBaseDirectoryForBasePathObject(BasePathObject: TObject
|
||||
): string;
|
||||
function THelpDatabases.GetBaseDirectoryForBasePathObject(
|
||||
BasePathObject: TObject): string;
|
||||
// returns the base file directory of the BasePathObject
|
||||
begin
|
||||
Result:='';
|
||||
if (BasePathObject is THelpBaseURLObject) then begin
|
||||
Result:=THelpBaseURLObject(BasePathObject).BaseURL;
|
||||
if Result='' then exit;
|
||||
if not IsFileURL(Result) then begin
|
||||
Result:='';
|
||||
exit;
|
||||
end;
|
||||
Result:=ExtractURLPath(Result);
|
||||
end else if (BasePathObject is THelpBasePathObject) then
|
||||
Result:=THelpBasePathObject(BasePathObject).BasePath
|
||||
else
|
||||
Result:='';
|
||||
Result:=AppendPathDelim(Result);
|
||||
end;
|
||||
|
||||
function THelpDatabases.ShowHelpForNodes(Query: THelpQuery;
|
||||
@ -2539,6 +2588,24 @@ begin
|
||||
Result:=AsString=QueryItem.AsString;
|
||||
end;
|
||||
|
||||
{ THelpBaseURLObject }
|
||||
|
||||
procedure THelpBaseURLObject.SetBaseURL(const AValue: string);
|
||||
begin
|
||||
if FBaseURL=AValue then exit;
|
||||
FBaseURL:=AValue;
|
||||
end;
|
||||
|
||||
constructor THelpBaseURLObject.Create;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
constructor THelpBaseURLObject.Create(const TheBaseURL: string);
|
||||
begin
|
||||
BaseURL:=TheBaseURL;
|
||||
end;
|
||||
|
||||
initialization
|
||||
HelpDatabases:=nil;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user