paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-10-31 06:21:38 +01:00
Code Issues Packages Projects Releases Wiki Activity

* Added two way comunication to LHelpControl

Browse Source 
* Made using lhelp easier so that it's only needed to install ChmHelpPkg and copy chms to docs/html
* lhelp will be built by ChmHelpPkg if it doesn't exist
* added helpful msg when F1 is pushed and no chms can be found

git-svn-id: trunk@21688 -
This commit is contained in:
andrew 2009-09-13 18:34:50 +00:00
parent efdffe51ba
commit 08ed127d0f
13 changed files with 797 additions and 555 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitattributes vendored
View File

@ -57,9 +57,9 @@ components/chmhelp/lhelp/images/table_open.png -text
components/chmhelp/lhelp/lhelp.ico -text svneol=unset#image/icon
components/chmhelp/lhelp/lhelp.lpi svneol=native#text/plain
components/chmhelp/lhelp/lhelp.lpr svneol=native#text/plain
components/chmhelp/lhelp/lhelp.manifest -text svneol=native#text/plain
components/chmhelp/lhelp/lhelp.rc -text svneol=native#text/plain
components/chmhelp/lhelp/lhelpcore.lfm -text svneol=native#text/plain
components/chmhelp/lhelp/lhelp.manifest svneol=native#text/plain
components/chmhelp/lhelp/lhelp.rc svneol=native#text/plain
components/chmhelp/lhelp/lhelpcore.lfm svneol=native#text/plain
components/chmhelp/lhelp/lhelpcore.lrs svneol=native#text/pascal
components/chmhelp/lhelp/lhelpcore.pas svneol=native#text/plain
components/chmhelp/lhelp/lnethttpdataprovider.pas svneol=native#text/plain

12
components/chmhelp/democontrol/project1.lpi
View File

@ -2,15 +2,17 @@
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="6"/>
<Version Value="7"/>
<General>
<Flags>
<LRSInOutputDirectory Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<TargetFileExt Value=""/>
</General>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="$(TestDir)\publishedproject\"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
@ -19,7 +21,7 @@
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
<Display Use="True" Value="192.168.0.250:0"/>
<Display Value="192.168.0.250:0"/>
</local>
</RunParams>
<RequiredPackages Count="2">
@ -38,9 +40,9 @@
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<ComponentName Value="Form1"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="unit1.lrs"/>
<ComponentName Value="Form1"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
</Units>

30
components/chmhelp/democontrol/unit1.lfm
View File

@ -1,30 +1,34 @@
object Form1: TForm1
Left = 610
Height = 300
Top = 247
Width = 400
ActiveControl = Button1
Caption = 'Form1'
ClientHeight = 300
ClientWidth = 400
OnCreate = FormCreate
PixelsPerInch = 90
HorzScrollBar.Page = 399
VertScrollBar.Page = 299
Left = 610
Height = 300
Top = 247
Width = 400
OnDestroy = FormDestroy
LCLVersion = '0.9.27'
object Label1: TLabel
Left = 93
Height = 18
Top = 73
Width = 110
Caption = 'Response is here'
ParentColor = False
end
object Button1: TButton
Caption = 'Click to load a chm'
OnClick = Button1Click
TabOrder = 0
Left = 36
Height = 25
Top = 20
Width = 284
Caption = 'Click to load a chm'
OnClick = Button1Click
TabOrder = 0
end
object OpenDialog1: TOpenDialog
Title = 'Open existing file'
FilterIndex = 0
Title = 'Open existing file'
left = 28
top = 127
end

20
components/chmhelp/democontrol/unit1.lrs
View File

@ -1,11 +1,13 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TForm1','FORMDATA',[
'TPF0'#6'TForm1'#5'Form1'#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'
+#12'ClientHeight'#3','#1#11'ClientWidth'#3#144#1#8'OnCreate'#7#10'FormCreate'
+#13'PixelsPerInch'#2'Z'#18'HorzScrollBar.Page'#3#143#1#18'VertScrollBar.Page'
+#3'+'#1#4'Left'#3'b'#2#6'Height'#3','#1#3'Top'#3#247#0#5'Width'#3#144#1#0#7
+'TButton'#7'Button1'#7'Caption'#6#19'Click to load a chm'#7'OnClick'#7#12'Bu'
+'tton1Click'#8'TabOrder'#2#0#4'Left'#2'$'#6'Height'#2#25#3'Top'#2#20#5'Width'
+#3#28#1#0#0#11'TOpenDialog'#11'OpenDialog1'#5'Title'#6#18'Open existing file'
+#11'FilterIndex'#2#0#5'Title'#6#18'Open existing file'#4'left'#2#28#3'top'#2
+''#0#0#0
'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'b'#2#6'Height'#3','#1#3'Top'#3#247#0#5'Wi'
+'dth'#3#144#1#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'#12'Client'
+'Height'#3','#1#11'ClientWidth'#3#144#1#8'OnCreate'#7#10'FormCreate'#9'OnDes'
+'troy'#7#11'FormDestroy'#10'LCLVersion'#6#6'0.9.27'#0#6'TLabel'#6'Label1'#4
+'Left'#2']'#6'Height'#2#18#3'Top'#2'I'#5'Width'#2'n'#7'Caption'#6#16'Respons'
+'e is here'#11'ParentColor'#8#0#0#7'TButton'#7'Button1'#4'Left'#2'$'#6'Heigh'
+'t'#2#25#3'Top'#2#20#5'Width'#3#28#1#7'Caption'#6#19'Click to load a chm'#7
+'OnClick'#7#12'Button1Click'#8'TabOrder'#2#0#0#0#11'TOpenDialog'#11'OpenDial'
+'og1'#11'FilterIndex'#2#0#4'left'#2#28#3'top'#2''#0#0#0
]);

30
components/chmhelp/democontrol/unit1.pas
View File

@ -6,7 +6,7 @@ interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, LHelpControl,
Buttons;
Buttons, StdCtrls;
type
@ -14,9 +14,11 @@ type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ private declarations }
public
@ -31,16 +33,38 @@ implementation
{ TForm1 }
function ResponseToString(Ares: TLHelpResponse): String;
begin
case Ares of
srNoAnswer: Result := 'NoAnswer';
srSuccess: Result := 'Success';
srInvalidFile:Result := 'InvalidFileName';
srInvalidURL:Result := 'InvalidURL';
srInvalidContext:Result := 'InvalidContext';
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Res: TLHelpResponse;
begin
if not OpenDialog1.Execute then exit;
Help.StartHelpServer('letstestagain', '../lhelp/lhelp --display=192.168.0.250:0');
Help.OpenFile(OpenDialog1.FileName);
if Help.ServerRunning = false then
Help.StartHelpServer('letstestagain', '../lhelp/lhelp');
Res :=Help.OpenFile(OpenDialog1.FileName);
Label1.Caption := ResponseToString(Res);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Help := TLHelpConnection.Create;
Help.ProcessWhileWaiting := @Application.ProcessMessages;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Help.Free;
end;
initialization

4
components/chmhelp/lhelp/lhelp.lpi
View File

@ -55,15 +55,15 @@
</Unit2>
<Unit3>
<Filename Value="chmpopup.pas"/>
<ComponentName Value="HelpPopupForm"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="HelpPopupForm"/>
<UnitName Value="ChmPopup"/>
</Unit3>
<Unit4>
<Filename Value="lhelpcore.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="HelpForm"/>
<HasResources Value="True"/>
<IsPartOfProject Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="lhelpcore"/>
</Unit4>

80
components/chmhelp/lhelp/lhelpcore.pas
View File

@ -86,14 +86,16 @@ type
private
{ private declarations }
fServerName: String;
fServer: TSimpleIPCServer;
fInputIPC: TSimpleIPCServer;
fOutputIPC: TSimpleIPCClient;
fServerTimer: TTimer;
fContext: LongInt; // used once when we are started on the command line with --context
procedure SendResponse(Response: DWord);
procedure ServerMessage(Sender: TObject);
procedure ReadCommandLineOptions;
procedure StartServer(ServerName: String);
procedure StopServer;
procedure OpenURL(const AURL: String; AContext: THelpContext=-1);
function OpenURL(const AURL: String; AContext: THelpContext=-1): DWord;
procedure LateOpenURL(Url: PStringItem);
function ActivePage: TContentTab;
procedure RefreshState;
@ -231,6 +233,23 @@ begin
end;
end;
procedure THelpForm.SendResponse(Response: DWord);
var
Stream: TMemoryStream;
begin
fOutputIPC := TSimpleIPCClient.Create(nil);
fOutputIPC.ServerID := fServerName+'client';
fOutputIPC.Active := True;
Stream := TMemoryStream.Create;
Stream.WriteDWord(Response);
fOutputIPC.SendMessage(mtUnknown, Stream);
if fOutputIPC.Active then
fOutputIPC.Active := False;
FreeAndNil(fOutputIPC);
end;
procedure THelpForm.ServerMessage(Sender: TObject);
@ -239,30 +258,32 @@ var
FileReq:TFileRequest;
ConReq: TContextRequest;
Stream: TStream;
Res: LongWord;
begin
if fServer.PeekMessage(5, True) then begin
Stream := fServer.MsgData;
if fInputIPC.PeekMessage(5, True) then begin
Stream := fInputIPC.MsgData;
Stream.Position := 0;
Stream.Read(FileReq, SizeOf(FileReq));
case FileReq.RequestType of
rtFile : begin
OpenURL('file://'+FileReq.FileName);
Res := OpenURL('file://'+FileReq.FileName);
end;
rtUrl : begin
Stream.Position := 0;
Stream.Read(UrlReq, SizeOf(UrlReq));
if UrlReq.FileRequest.FileName <> '' then
OpenUrl('file://'+UrlReq.FileRequest.FileName+'://'+UrlReq.Url)
Res := OpenUrl('file://'+UrlReq.FileRequest.FileName+'://'+UrlReq.Url)
else
OpenURL(UrlReq.Url);
Res := OpenURL(UrlReq.Url);
end;
rtContext : begin
Stream.Position := 0;
Stream.Read(ConReq, SizeOf(ConReq));
OpenURL('file://'+FileReq.FileName, ConReq.HelpContext);
Res := OpenURL('file://'+FileReq.FileName, ConReq.HelpContext);
end;
end;
SendResponse(Res);
Self.SendToBack;
Self.BringToFront;
end;
end;
@ -314,27 +335,32 @@ end;
procedure THelpForm.StartServer(ServerName: String);
begin
fServer := TSimpleIPCServer.Create(nil);
fServer.ServerID := ServerName;
fServer.Global := True;
fServer.Active := True;
fInputIPC := TSimpleIPCServer.Create(nil);
fInputIPC.ServerID := ServerName;
fInputIPC.Global := True;
fInputIPC.Active := True;
fServerTimer := TTimer.Create(nil);
fServerTimer.OnTimer := @ServerMessage;
fServerTimer.Interval := 200;
fServerTimer.Enabled := True;
ServerMessage(nil);
end;
procedure THelpForm.StopServer;
begin
if fServer = nil then exit;
FreeAndNil(fServerTimer);
if fServer.Active then fServer.Active := False;
FreeAndNil(fServer);
if fInputIPC = nil then
exit;
if fInputIPC.Active then
fInputIPC.Active := False;
FreeAndNil(fInputIPC);
FreeAndNil(fServerTimer);
end;
procedure THelpForm.OpenURL(const AURL: String; AContext: THelpContext);
function THelpForm.OpenURL(const AURL: String; AContext: THelpContext): DWord;
function GetURLPrefix: String;
var
fPos: Integer;
@ -349,18 +375,20 @@ var
fNewPage: TContentTab;
I: Integer;
begin
Result := Ord(srUnknown);
fURLPrefix := GetURLPrefix;
fContentProvider := GetContentProvider(fURLPrefix);
if fContentProvider = nil then begin
ShowError('Cannot handle this type of content. "' + fURLPrefix + '"');
ShowError('Cannot handle this type of content. "' + fURLPrefix + '" for url:'+LineEnding+AURL);
Result := Ord(srInvalidFile);
Exit;
end;
fRealContentProvider := fContentProvider.GetProperContentProvider(AURL);
if fRealContentProvider = nil then begin
ShowError('Cannot handle this type of subcontent. "' + fURLPrefix + '"');
ShowError('Cannot handle this type of subcontent. "' + fURLPrefix + '" for url:'+LineEnding+AURL);
Result := Ord(srInvalidFile);
Exit;
end;
@ -368,7 +396,12 @@ begin
for I := 0 to PageControl.PageCount-1 do begin
if fRealContentProvider.ClassName = TContentTab(PageControl.Pages[I]).ContentProvider.ClassName then begin
if TContentTab(PageControl.Pages[I]).ContentProvider.LoadURL(AURL, AContext) then
begin
PageControl.ActivePage := PageControl.Pages[I];
Result := Ord(srSuccess);
end
else
Result := Ord(srInvalidFile);
Exit;
end;
end;
@ -381,7 +414,12 @@ begin
ShowOnTop;
if fNewPage.ContentProvider.LoadURL(AURL, AContext) then
begin
PageControl.ActivePage := fNewPage;
Result := Ord(srSuccess);
end
else
Result := Ord(srInvalidFile);
end;
procedure THelpForm.LateOpenURL ( Url: PStringItem ) ;

97
components/chmhelp/packages/help/lhelpcontrol.pas
View File

@ -10,6 +10,8 @@ uses
type
TRequestType = (rtFile, rtUrl, rtContext);
TLHelpResponse = (srNoAnswer, srUnknown, srSuccess, srInvalidFile, srInvalidURL, srInvalidContext);
TFileRequest = record
RequestType: TRequestType;
FileName: array[0..512] of char;
@ -23,18 +25,28 @@ type
HelpContext: THelpContext;
end;
TProcedureOfObject = procedure of object;
{ TLHelpConnection }
TLHelpConnection = class(TObject)
private
fClient: TSimpleIPCClient;
FProcessWhileWaiting: TProcedureOfObject;
fServerOut: TSimpleIPCClient; // sends messages to lhelp
fServerIn: TSimpleIPCServer; // recieves messages from lhelp
function WaitForMsgResponse: TLHelpResponse;
function SendMessage(Stream: TStream): TLHelpResponse;
public
constructor Create;
destructor Destroy; override;
function ServerRunning: Boolean;
function StartHelpServer(NameForServer: String; ServerEXE: String = ''): Boolean;
procedure OpenURL(HelpFileName: String; Url: String);
procedure OpenContext(HelpFileName: String; Context: THelpContext);
procedure OpenFile(HelpFileName: String);
function OpenURL(HelpFileName: String; Url: String): TLHelpResponse;
function OpenContext(HelpFileName: String; Context: THelpContext): TLHelpResponse;
function OpenFile(HelpFileName: String): TLHelpResponse;
property ProcessWhileWaiting: TProcedureOfObject read FProcessWhileWaiting write FProcessWhileWaiting;
end;
@ -42,45 +54,87 @@ implementation
{ TLHelpConnection }
function TLHelpConnection.WaitForMsgResponse: TLHelpResponse;
var
I: Integer;
Stream: TStream;
WaitTime: Integer = 5000;
begin
Result := srNoAnswer;
while WaitTime >= 0 do
begin
Dec(WaitTime, 50);
if fServerIn.PeekMessage(50, True) then
begin
Stream := fServerIn.MsgData;
Stream.Position:=0;
Result := TLHelpResponse(Stream.ReadDWord);
Exit;
end;
if Assigned(FProcessWhileWaiting) then FProcessWhileWaiting();
end;
end;
function TLHelpConnection.SendMessage(Stream: TStream): TLHelpResponse;
begin
fServerOut.SendMessage(mtUnknown, Stream);
Result := WaitForMsgResponse;
end;
constructor TLHelpConnection.Create;
begin
fClient := TSimpleIPCClient.Create(nil);
fServerOut := TSimpleIPCClient.Create(nil);
fServerIn := TSimpleIPCServer.Create(nil);
end;
destructor TLHelpConnection.Destroy;
begin
if fCLient.Active then fClient.Active:=False;
fClient.Free;
if fServerOut.Active then
fServerOut.Active:=False;
if fServerIn.Active then
fServerIn.Active:=False;
fServerOut.Free;
fServerIn.Free;
inherited Destroy;
end;
function TLHelpConnection.ServerRunning: Boolean;
begin
Result := (fServerOut<>nil) and (fServerOut.Active);
end;
function TLHelpConnection.StartHelpServer(NameForServer: String;
ServerEXE: String): Boolean;
var
X: Integer;
begin
Result := False;
fClient.Active := False;
fClient.ServerID := NameForServer;
if not fClient.ServerRunning then begin
fServerIn.Active := False;
fServerIn.ServerID := NameForServer+'client';
fServerIn.Global := True;
fServerIn.Active := True;
fServerOut.Active := False;
fServerOut.ServerID := NameForServer;
if not fServerOut.ServerRunning then begin
with TProcessUTF8.Create(nil) do begin
CommandLine := ServerExe + ' --ipcname ' + NameForServer;
Execute;
end;
// give the server some time to get started
for X := 0 to 40 do begin
if not fClient.ServerRunning then Sleep(200);
if not fServerOut.ServerRunning then Sleep(200);
end;
end;
if fClient.ServerRunning then begin
fClient.Active := True;
if fServerOut.ServerRunning then begin
fServerOut.Active := True;
Result := True;
end;
end;
procedure TLHelpConnection.OpenURL(HelpFileName: String; Url: String);
function TLHelpConnection.OpenURL(HelpFileName: String; Url: String): TLHelpResponse;
var
UrlRequest: TUrlRequest;
Stream: TMemoryStream;
@ -90,12 +144,15 @@ begin
UrlRequest.FileRequest.RequestType := rtURL;
UrlRequest.Url := Url+#0;
Stream.Write(UrlRequest,SizeOf(UrlRequest));
fClient.SendMessage(mtUnknown, Stream);
Result := SendMessage(Stream);
// Do I need to free the stream?? the example doesn't
end;
procedure TLHelpConnection.OpenContext(HelpFileName: String;
Context: THelpContext);
function TLHelpConnection.OpenContext(HelpFileName: String;
Context: THelpContext) : TLHelpResponse;
var
ContextRequest: TContextRequest;
Stream: TMemoryStream;
@ -105,11 +162,11 @@ begin
ContextRequest.FileRequest.RequestType := rtContext;
ContextRequest.HelpContext := Context;
Stream.Write(ContextRequest, SizeOf(ContextRequest));
fClient.SendMessage(mtUnknown, Stream);
Result := SendMessage(Stream);
// Do I need to free the stream?? the example doesn't
end;
procedure TLHelpConnection.OpenFile(HelpFileName: String);
function TLHelpConnection.OpenFile(HelpFileName: String): TLHelpResponse;
var
FileRequest : TFileRequest;
Stream: TMemoryStream;
@ -118,7 +175,7 @@ begin
FileRequest.RequestType := rtFile;
FileRequest.FileName := HelpFileName+#0;
Stream.Write(FileRequest, SizeOf(FileRequest));
fClient.SendMessage(mtUnknown, Stream);
Result := SendMessage(Stream);
// Do I need to free the stream?? the example doesn't
end;

20
components/chmhelp/packages/idehelp/chmhelppkg.lpk
View File

@ -1,15 +1,12 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="2">
<Package Version="3">
<Name Value="ChmHelpPkg"/>
<CompilerOptions>
<Version Value="5"/>
<Version Value="8"/>
<SearchPaths>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
@ -23,20 +20,23 @@
</Item1>
</Files>
<Type Value="DesignTime"/>
<RequiredPkgs Count="4">
<RequiredPkgs Count="5">
<Item1>
<PackageName Value="CodeTools"/>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="lhelpcontrolpkg"/>
<PackageName Value="CodeTools"/>
</Item2>
<Item3>
<PackageName Value="IDEIntf"/>
<PackageName Value="lhelpcontrolpkg"/>
</Item3>
<Item4>
<PackageName Value="IDEIntf"/>
</Item4>
<Item5>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item4>
</Item5>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)/"/>

131
components/chmhelp/packages/idehelp/lazchmhelp.pas
View File

@ -24,7 +24,7 @@ interface
uses
Classes, SysUtils, FileUtil, LazHelpIntf, HelpIntfs, LazConfigStorage,
PropEdits, LHelpControl;
PropEdits, LHelpControl, Controls;
type
@ -36,10 +36,13 @@ type
fHelpLabel: String;
fHelpConnection: TLHelpConnection;
fChmsFilePath: String;
function GetHelpEXE: String;
protected
function GetFileNameAndURL(RawUrl: String; out FileName: String; out URL: String): Boolean;
procedure SetHelpEXE(AValue: String);
procedure SetHelpLabel(AValue: String);
function CheckBuildLHelp: Integer; // modal result
function GetLazBuildEXE(out ALazBuild: String): Boolean;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
@ -53,7 +56,7 @@ type
procedure Save(Storage: TConfigStorage); override;
function GetLocalizedName: string; override;
published
property HelpEXE: String read fHelpEXE write SetHelpEXE;
property HelpEXE: String read GetHelpEXE write SetHelpEXE;
property HelpLabel: String read fHelpLabel write SetHelpLabel;
property HelpFilesPath: String read fChmsFilePath write fChmsFilePath;
@ -62,9 +65,18 @@ type
procedure Register;
implementation
uses Process, MacroIntf, InterfaceBase, Forms, Dialogs, HelpFPDoc;
{ TChmHelpViewer }
function TChmHelpViewer.GetHelpEXE: String;
begin
if fHelpExe <> '' then
Exit(fHelpExe);
Result := '$(LazarusDir)/components/chmhelp/lhelp/lhelp$(ExeExt)';
if not IDEMacros.SubstituteMacros(Result) then
Exit('');
end;
function TChmHelpViewer.GetFileNameAndURL(RawUrl:String; out FileName: String; out URL: String
): Boolean;
@ -90,11 +102,82 @@ begin
fHelpLabel := AValue;
end;
function TChmHelpViewer.CheckBuildLHelp: Integer;
var
Proc: TProcess;
Lazbuild: String;
LHelpProject: String;
WS: String;
begin
Result := mrCancel;
if FileExistsUTF8(HelpExe) = True then
Exit(mrOK);
if not GetLazBuildEXE(Lazbuild) then
Exit;
LHelpProject := '$(LazarusDir)/components/chmhelp/lhelp/lhelp.lpi';
if not (IDEMacros.SubstituteMacros(LHelpProject)
and FileExistsUTF8(LHelpProject))
then
Exit;
WS := ' --ws='+LCLPlatformDirNames[WidgetSet.LCLPlatform]+' ';
Result := MessageDlg('The help viewer is not compiled yet. Try to compile it now?', mtConfirmation, mbYesNo ,0);
if Result <> mrYes then
Exit;
Proc := TProcess.Create(nil);
Proc.CommandLine := Lazbuild + WS + LHelpProject;
Proc.Options := [];
Proc.Execute;
while Proc.Running do begin
Application.HandleMessage;
end;
if Proc.ExitStatus = 0 then
Result := mrOK;
Proc.Free;
if Result = mrOK then
end;
function TChmHelpViewer.GetLazBuildEXE(out ALazBuild: String): Boolean;
var
LazBuildMacro: String;
begin
Result := False;
LazBuildMacro:= '$(LazarusDir)/$MakeExe(lazbuild)';
Result := IDEMacros.SubstituteMacros(LazBuildMacro)
and FileExistsUTF8(LazBuildMacro);
if Result then
ALazBuild := LazBuildMacro;
end;
constructor TChmHelpViewer.Create(TheOwner: TComponent);
var
i: Integer;
DB: TFPDocHTMLHelpDatabase;
BaseURL: THelpBaseURLObject;
begin
inherited Create(TheOwner);
fHelpConnection := TLHelpConnection.Create;
fHelpConnection.ProcessWhileWaiting:=@Application.ProcessMessages;
AddSupportedMimeType('text/html');
for i := 0 to HelpDatabases.Count-1 do begin
DB := TFPDocHTMLHelpDatabase(HelpDatabases.Items[i]);
BaseURL := THelpBaseURLObject(DB.BasePathObject);
if (DB.ID = 'RTLUnits') and (BaseURL.BaseURL = '') then
BaseURL.BaseURL := 'rtl.chm://'
else if (DB.ID = 'FCLUnits') and (BaseURL.BaseURL = '') then
BaseURL.BaseURL := 'fcl.chm://'
else if (DB.ID = 'LCLUnits') and (BaseURL.BaseURL = '') then
BaseURL.BaseURL := 'lcl.chm://';
end;
end;
destructor TChmHelpViewer.Destroy;
@ -118,20 +201,52 @@ function TChmHelpViewer.ShowNode(Node: THelpNode; var ErrMsg: string
var
FileName: String;
Url: String;
Res: TLHelpResponse;
DocsDir: String;
begin
Result:=shrNone;
if not FileExistsUTF8(fHelpEXE) then begin
ErrMsg := 'The program "' + fHelpEXE + '" doesn''t seem to exist!';
if CheckBuildLHelp <> mrOK then begin
ErrMsg := 'The program "' + HelpEXE + '" doesn''t seem to exist'+LineEnding+
'or could not be built!';
Exit(shrViewerNotFound);
end;
if not GetFileNameAndURL(Node.Url, FileName, Url) then begin
ErrMsg := 'Couldn''t read the file/URL correctly';
Exit(shrDatabaseNotFound);
end;
FileName := fChmsFilePath+FileName;
fHelpConnection.StartHelpServer(fHelpLabel, fHelpExe);
fHelpConnection.OpenURL(FileName, Url);
Result := shrSuccess;
if HelpFilesPath = '' then
begin
DocsDir := '$(LazarusDir)/docs/html/';
IDEMacros.SubstituteMacros(DocsDir);
if not FileExistsUTF8(DocsDir+FileName) then
begin
Result := shrDatabaseNotFound;
ErrMsg := FileName +' not found. Please put the chm help files in '+ LineEnding
+DocsDir+ LineEnding
+' or set the path to lcl.chm rtl.chm fcl.chm with "HelpFilesPath" in '
+' Environment Options -> Help -> Help Options ->'+LineEnding
+' under HelpViewers - CHMHelpViewer';
Exit;
end;
end
else
DocsDir := fChmsFilePath;
FileName := DocsDir+FileName;
fHelpConnection.StartHelpServer(fHelpLabel, HelpExe);
Res := fHelpConnection.OpenURL(FileName, Url);
case Res of
srSuccess: Result := shrSuccess;
srNoAnswer: Result := shrSuccess;
else
Result := shrNone;
ErrMsg := 'Unknown error showing '+URL;
end;
//WriteLn('LOADING URL = ', Node.URL);
end;