paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-07 10:16:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

ChmHelp: close lhelp that laz started when laz is closed. Fix a stream read related error. Issue #24743, patch from Reinier Olislagers

Browse Source 
git-svn-id: trunk@45857 -
This commit is contained in:
juha 2014-07-13 19:11:31 +00:00
parent 12e13eb2ed
commit c2a0094609
7 changed files with 124 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
components/chmhelp/lhelp/chmcontentprovider.pas
View File

@ -5,7 +5,7 @@ unit chmcontentprovider;
{$Note Compiling lhelp with search support}
{$DEFINE CHM_SEARCH}
{$if (fpc_version=2) and (fpc_release>4)}
{$IF FPC_FULLVERSION>=20400}
{$Note Compiling lhelp *with* binary index and toc support}
{$DEFINE CHM_BINARY_INDEX_TOC}
{$endif}

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

@ -47,12 +47,6 @@
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</Item2>
</BuildModes>
@ -84,7 +78,6 @@
<Unit0>
<Filename Value="lhelp.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="lhelp"/>
</Unit0>
<Unit1>
<Filename Value="chmdataprovider.pas"/>
@ -94,14 +87,12 @@
<Unit2>
<Filename Value="chmspecialparser.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ChmSpecialParser"/>
</Unit2>
<Unit3>
<Filename Value="chmpopup.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="HelpPopupForm"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ChmPopup"/>
</Unit3>
<Unit4>
<Filename Value="lhelpcore.pas"/>
@ -114,12 +105,10 @@
<Unit5>
<Filename Value="lnethttpdataprovider.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="LNetHTTPDataProvider"/>
</Unit5>
<Unit6>
<Filename Value="basecontentprovider.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="BaseContentProvider"/>
</Unit6>
<Unit7>
<Filename Value="chmcontentprovider.pas"/>
@ -129,7 +118,6 @@
<Unit8>
<Filename Value="httpcontentprovider.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="HTTPContentProvider"/>
</Unit8>
</Units>
</ProjectOptions>
@ -159,11 +147,5 @@
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

2
components/chmhelp/lhelp/lhelp.lpr
View File

@ -1,4 +1,4 @@
{ Copyright (C) <2005> <Andrew Haines> lhelp.lpr
{ Copyright (C) <2005-2014> <Andrew Haines>, Lazarus contributors lhelp.lpr
Lhelp CHM help viewer application

4
components/chmhelp/lhelp/lhelpcore.lfm
View File

@ -5,7 +5,7 @@ object HelpForm: THelpForm
Width = 758
ActiveControl = Panel1
Caption = 'LHelp'
ClientHeight = 510
ClientHeight = 516
ClientWidth = 758
Icon.Data = {
7E04000000000100010010100000010020006804000016000000280000001000
@ -238,7 +238,7 @@ object HelpForm: THelpForm
end
object PageControl: TPageControl
Left = 0
Height = 478
Height = 484
Top = 32
Width = 758
Align = alClient

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

@ -1,4 +1,4 @@
{ Copyright (C) 2005-2013 Andrew Haines, Lazarus contributors
{ Copyright (C) 2005-2014 Andrew Haines, Lazarus contributors
Main form for lhelp. Includes processing/data communication.
@ -27,7 +27,7 @@ unit lhelpcore;
{$IFDEF UNIX}
{$if FPC_FULLVERSION <= 20700}
{$DEFINE STALE_PIPE_WORKAROUND}
{$DEFINE STALE_PIPE_WORKAROUND}
{$ENDIF}
{$ENDIF}
@ -150,7 +150,7 @@ var
const
INVALID_FILE_TYPE = 1;
VERSION_STAMP = '2013-07-31'; //used in displaying about form etc
VERSION_STAMP = '2013-07-31'; //used in displaying version in about form etc
implementation
@ -244,20 +244,22 @@ procedure THelpForm.FileMenuOpenURLItemClick(Sender: TObject);
var
fRes: String;
URLSAllowed: String;
Protocall: TStrings;
Protocol: TStrings;
i: Integer;
begin
Protocall := GetContentProviderList;
URLSAllowed:='';
for i := 0 to Protocall.Count-1 do
begin
if i < 1 then
URLSAllowed := URLSAllowed + Protocall[i]
else
URLSAllowed := URLSAllowed + ', ' +Protocall[i]
Protocol := GetContentProviderList;
try
URLSAllowed:='';
for i := 0 to Protocol.Count-1 do
begin
if i < 1 then
URLSAllowed := URLSAllowed + Protocol[i]
else
URLSAllowed := URLSAllowed + ', ' +Protocol[i]
end;
finally
Protocol.Free;
end;
Protocall.Free;
URLSAllowed := Trim(URLSALLowed);
@ -331,7 +333,7 @@ end;
procedure THelpForm.ViewMenuContentsClick(Sender: TObject);
begin
//TabsControl property in TChmContentProvider
// TabsControl property in TChmContentProvider
if Assigned(ActivePage) then
with TChmContentProvider(ActivePage.ContentProvider) do
begin
@ -352,7 +354,7 @@ begin
PrefFile := GetAppConfigDirUTF8(False);
ForceDirectoriesUTF8(PrefFile);
// --ipcname passes a server ID that consists of a
// a server-dependent constant together with a process ID.
// server-dependent constant together with a process ID.
// Strip out the process ID to get fixed config file names for one server
ServerPart := Copy(AIPCName, 1, length(AIPCName)-5); //strip out PID
PrefFile:=Format('%slhelp-%s.conf',[IncludeTrailingPathDelimiter(PrefFile), ServerPart]);
@ -475,6 +477,7 @@ begin
Stream.Position := 0;
FillByte(FileReq{%H-},SizeOf(FileReq),0);
Stream.Read(FileReq, SizeOf(FileReq));
Res := Ord(srError); //fail by default
case FileReq.RequestType of
rtFile : begin
Url := 'file://'+FileReq.FileName;
@ -520,7 +523,7 @@ begin
end;
mrVersion:
begin
//Protocol version encoded in the filename
// Protocol version encoded in the filename
// Verify what we support
if strtointdef(FileReq.FileName,0)=strtointdef(PROTOCOL_VERSION,0) then
Res := ord(srSuccess)
@ -536,8 +539,14 @@ begin
AddRecentFile(Url);
SendResponse(Res);
if MustClose then
begin
// Wait some time for the response message to go out before shutting down
Application.ProcessMessages;
Sleep(10);
Application.Terminate;
end;
// We received mrShow:
if (MustClose=false) and (fHide=false) then
begin
Self.SendToBack;
@ -675,20 +684,20 @@ var
fPage: TContentTab = nil;
I: Integer;
begin
Result := Ord(srUnknown);
Result := Ord(srInvalidURL);
fURLPrefix := GetURLPrefix;
fContentProvider := GetContentProvider(fURLPrefix);
if fContentProvider = nil then begin
ShowError('Cannot handle this type of content. "' + fURLPrefix + '" for url:'+LineEnding+AURL);
Result := Ord(srInvalidFile);
Result := Ord(srInvalidURL);
Exit;
end;
fRealContentProvider := fContentProvider.GetProperContentProvider(AURL);
if fRealContentProvider = nil then begin
ShowError('Cannot handle this type of subcontent. "' + fURLPrefix + '" for url:'+LineEnding+AURL);
Result := Ord(srInvalidFile);
Result := Ord(srInvalidURL);
Exit;
end;
@ -717,7 +726,6 @@ begin
fPage.ContentProvider.LoadPreferences(fConfig);
end;
if fPage.ContentProvider.LoadURL(AURL, AContext) then
begin
PageControl.ActivePage := fPage;
@ -725,7 +733,7 @@ begin
Result := Ord(srSuccess);
end
else
Result := Ord(srInvalidFile);
Result := Ord(srInvalidURL);
if not fHide then
ShowOnTop;

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

@ -12,7 +12,7 @@ Currently, the only help viewer that supports this protocol is the lhelp CHM hel
{$IFDEF UNIX}
{$if FPC_FULLVERSION <= 20700}
{$DEFINE STALE_PIPE_WORKAROUND}
{$DEFINE STALE_PIPE_WORKAROUND}
{$ENDIF}
{$ENDIF}
@ -25,7 +25,12 @@ uses
Classes, SysUtils, FileUtil, LazLogger, SimpleIPC, process, UTF8Process;
const
PROTOCOL_VERSION='1'; //IDE<>LHelp communication protocol version. Please update when breaking compatibility
PROTOCOL_VERSION='2'; //IDE<>LHelp communication protocol version. Please update when breaking compatibility
// Version 1: original version
// Version 2:
// - support for Proposed extensions in bug 24743:
// - openurl: if applicable return error instead of unknown
// - openurl: if applicable return invalid url instead of invalid file for openurl
type
TRequestType = (rtFile, rtUrl, rtContext, rtMisc {window handling etc});
TMiscRequests = (mrShow, mrVersion, mrClose);
@ -113,12 +118,9 @@ end;
function TLHelpConnection.SendMessage(Stream: TStream): TLHelpResponse;
begin
//try
fServerOut.SendMessage(mtUnknown, Stream);
Result := WaitForMsgResponse;
//except
// on EIPCError do Result := srNoAnswer;
//end;
Result := srNoAnswer;
fServerOut.SendMessage(mtUnknown, Stream);
Result := WaitForMsgResponse;
end;
constructor TLHelpConnection.Create;
@ -225,6 +227,9 @@ begin
if fServerOut.ServerRunning then begin
fServerOut.Active := True;
Result := True;
end
else begin
debugln('Could not get lhelp running with command '+Cmd);
end;
end;
@ -238,8 +243,17 @@ begin
UrlRequest.FileRequest.FileName := HelpFileName+#0;
UrlRequest.FileRequest.RequestType := rtURL;
UrlRequest.Url := Url+#0;
Stream.Write(UrlRequest,SizeOf(UrlRequest));
Result := SendMessage(Stream);
Result:=srNoAnswer;
try
Stream.Write(UrlRequest,SizeOf(UrlRequest));
Result := SendMessage(Stream);
except
// Catch stream read errors etc
on E: Exception do
begin
debugln('Help connection: error '+E.Message+' running UrlRequest command');
end;
end;
finally
Stream.Free;
end;
@ -252,12 +266,22 @@ var
Stream: TMemoryStream;
begin
Stream := TMemoryStream.Create;
Result := srNoAnswer;
try
ContextRequest.FileRequest.FileName := HelpFileName+#0;
ContextRequest.FileRequest.RequestType := rtContext;
ContextRequest.HelpContext := Context;
Stream.Write(ContextRequest, SizeOf(ContextRequest));
Result := SendMessage(Stream);
Result := srNoAnswer;
try
Stream.Write(ContextRequest, SizeOf(ContextRequest));
Result := SendMessage(Stream);
except
// Catch stream read errors etc
on E: Exception do
begin
debugln('Help connection: error '+E.Message+' running ContextRequest command');
end;
end;
finally
Stream.Free;
end;
@ -272,8 +296,17 @@ begin
try
FileRequest.RequestType := rtFile;
FileRequest.FileName := HelpFileName+#0;
Stream.Write(FileRequest, SizeOf(FileRequest));
Result := SendMessage(Stream);
Result := srNoAnswer;
try
Stream.Write(FileRequest, SizeOf(FileRequest));
Result := SendMessage(Stream);
except
// Catch stream read errors etc
on E: Exception do
begin
debugln('Help connection: error '+E.Message+' running FileRequest command');
end;
end;
finally
Stream.Free;
end;
@ -287,17 +320,27 @@ begin
Stream := TMemoryStream.Create;
try
MiscRequest.FileRequest.RequestType := rtMisc;
MiscRequest.FileRequest.FileName := ''+#0; //i
MiscRequest.FileRequest.FileName := ''+#0;
//CommandID is ord(TMiscRequests)
MiscRequest.RequestID:=CommandID;
case CommandID of
mrClose: ; //do nothing
mrShow: ; //do nothing
mrClose: ; //no arguments required
mrShow: ; //no arguments required
mrVersion:
MiscRequest.FileRequest.FileName := PROTOCOL_VERSION+#0;
end;
Stream.Write(MiscRequest, SizeOf(MiscRequest));
Result := SendMessage(Stream);
try
Stream.Write(MiscRequest, SizeOf(MiscRequest));
Result := SendMessage(Stream);
except
// Catch stream read errors etc
on E: Exception do
begin
// When closing, the viewer may not respond in time, which is expected.
if CommandID<>mrClose then
debugln('Help connection: error '+E.Message+' running MiscRequest command');
end;
end;
finally
Stream.Free;
end;

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

@ -1,4 +1,4 @@
{ Copyright (C) <2005-2013> <Andrew Haines>, Lazarus contributors
{ Copyright (C) <2005-2014> <Andrew Haines>, Lazarus contributors
lazchmhelp.pas
@ -437,6 +437,16 @@ end;
destructor TChmHelpViewer.Destroy;
begin
// Try to close lhelp if we had opened it before; ignore response
try
fHelpConnection.RunMiscCommand(LHelpControl.mrClose);
except
// ignore errors; let user close it himself
on E: Exception do begin
debugln('TChmHelpViewer.Destroy: exception '+E.Message+' when trying to send mrClose on viewer');
end;
end;
fHelpConnection.Free;
inherited Destroy;
end;
@ -481,9 +491,7 @@ begin
fHelpConnection.StartHelpServer(HelpLabel, HelpExeFileName, true);
Response:=fHelpConnection.RunMiscCommand(mrVersion);
if Response<>srSuccess then
begin
debugln('Help viewer does not support our protocol version.');
end
debugln('Help viewer does not support our protocol version ('+PROTOCOL_VERSION +'). Response was: ord: '+inttostr(ord(Response)))
else
begin
// Open all chm files after it has started, while still hidden
@ -491,9 +499,7 @@ begin
// Instruct viewer to show its GUI
Response:=fHelpConnection.RunMiscCommand(mrShow);
if Response<>srSuccess then
begin
debugln('Help viewer failed to respond to mrShow command.');
end;
debugln('Help viewer gave error response to mrShow command. Response was: ord: '+inttostr(ord(Response)));
end;
end;
end;
@ -534,7 +540,7 @@ begin
begin
Result := shrDatabaseNotFound;
ErrMsg := FileName +' not found. Please put the chm help files in '+ LineEnding
+SearchPath+ LineEnding
+SearchPath + LineEnding
+' or set the path to lcl.chm rtl.chm fcl.chm with "HelpFilesPath" in '
+' Environment Options -> Help -> Help Options ->'+LineEnding
+' under HelpViewers - CHMHelpViewer';
@ -556,7 +562,7 @@ begin
if Trim(fHelpExeParams) = '' then
begin
Result := shrViewerError;
ErrMsg := 'If you do not use "lhelp" as viewer you have to setup '
ErrMsg := 'If you do not use "lhelp" as viewer you have to set up '
+ 'HelpExeParams correctly in' + sLineBreak
+ 'Tools -> Options -> Help -> Help Options -> '
+ 'under HelpViewers - CHM Help Viewer' + sLineBreak
@ -600,7 +606,19 @@ begin
case Res of
srSuccess: Result := shrSuccess;
srNoAnswer: Result := shrSuccess;
else
srInvalidContext: begin
Result := shrNone;
ErrMsg := 'Invalid context showing '+URL;
end;
srInvalidFile: begin
Result := shrNone;
ErrMsg := 'Invalid file showing '+URL;
end;
srInvalidURL: begin
Result := shrNone;
ErrMsg := 'Invalid URL showing '+URL;
end;
else //srUnknown, srError
Result := shrNone;
ErrMsg := 'Unknown error showing '+URL;
end;