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

Merged revision(s) 47959 #a57530c071, 47975 #778078e958, 47987 #e62738c753 from trunk:

Browse Source 
Speedup lhelp starting. 
New LHelp messages are added and the ide will try to rebuild lhelp if lhelp doesn't understand the new messages
........
Added check to try to save original lhelp when recompiling in case it fails. Fixed bug where ContentProvider.EndUpdate was called too soon. LHelp starts speedily now :) 
........
Lazarus chm search to send to lhelp now doesn't search paths recursively
........

git-svn-id: branches/fixes_1_4@48003 -
This commit is contained in:
maxim 2015-02-25 23:02:07 +00:00
parent 2a266c29e1
commit a391c23b4c
8 changed files with 205 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
components/chmhelp/lhelp/basecontentprovider.pas
View File

@ -18,10 +18,12 @@ type
fParent: TWinControl;
FTitle: String;
FConfig: TXMLConfig;
FUpdateCount: Integer;
protected
fImageList: TImageList;
function GetTitle: String; virtual;
procedure SetTitle(const AValue: String); virtual;
function IsUpdating: Boolean;
public
function CanGoBack: Boolean; virtual; abstract;
function CanGoForward: Boolean; virtual; abstract;
@ -30,6 +32,8 @@ type
procedure GoHome; virtual; abstract;
procedure GoBack; virtual; abstract;
procedure GoForward; virtual; abstract;
procedure BeginUpdate; virtual;
procedure EndUpdate; virtual;
procedure LoadPreferences(ACfg: TXMLConfig); virtual;
procedure SavePreferences({%H-}ACfg: TXMLConfig); virtual;
class function GetProperContentProvider(const AURL: String): TBaseContentProviderClass; virtual; abstract;
@ -98,6 +102,23 @@ begin
FOnTitleChange(Self);
end;
function TBaseContentProvider.IsUpdating: Boolean;
begin
Result := FUpdateCount <> 0;
end;
procedure TBaseContentProvider.BeginUpdate;
begin
Inc(FUpdateCount);
end;
procedure TBaseContentProvider.EndUpdate;
begin
Dec(FUpdateCount);
if FUpdateCount < 0 then
FUpdateCount:=0;
end;
procedure TBaseContentProvider.LoadPreferences(ACfg: TXMLConfig);
begin
FConfig := ACfg;

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

@ -33,6 +33,7 @@ type
TChmContentProvider = class(TFileContentProvider)
private
fUpdateURI: String;
fTabsControl: TPageControl;
fContentsTab: TTabSheet;
fContentsPanel: TPanel;
@ -64,6 +65,8 @@ type
function MakeURI(AUrl: String; AChm: TChmReader): String;
procedure BeginUpdate; override;
procedure EndUpdate; override;
procedure AddHistory(URL: String);
procedure DoOpenChm(AFile: String; ACloseCurrent: Boolean = True);
procedure DoCloseChm;
@ -247,6 +250,26 @@ begin
Result := ChmURI(AUrl, fChms.FileName[ChmIndex]);
end;
procedure TChmContentProvider.BeginUpdate;
begin
inherited BeginUpdate;
fContentsTree.BeginUpdate;
fIndexView.BeginUpdate;
end;
procedure TChmContentProvider.EndUpdate;
begin
inherited EndUpdate;
fContentsTree.EndUpdate;
fIndexView.EndUpdate;
if not IsUpdating then
begin
if fUpdateURI <> '' then
DoLoadUri(fUpdateURI);
fUpdateURI:='';
end;
end;
procedure TChmContentProvider.AddHistory(URL: String);
begin
if fHistoryIndex < fHistory.Count then
@ -361,15 +384,25 @@ begin
Uri := NewUrl;
end;
fIsUsingHistory := True;
fHtml.OpenURL(Uri);
TIpChmDataProvider(fHtml.DataProvider).CurrentPath := ExtractFileDir(URI)+'/';
if not IsUpdating then
begin
AddHistory(Uri);
EndTime := Now;
fIsUsingHistory := True;
fHtml.OpenURL(Uri);
TIpChmDataProvider(fHtml.DataProvider).CurrentPath := ExtractFileDir(URI)+'/';
Time := INtToStr(DateTimeToTimeStamp(EndTime).Time - DateTimeToTimeStamp(StartTime).Time);
fStatusBar.SimpleText :='Loaded: '+Uri+' in '+ Time+'ms';
AddHistory(Uri);
EndTime := Now;
Time := INtToStr(DateTimeToTimeStamp(EndTime).Time - DateTimeToTimeStamp(StartTime).Time);
fStatusBar.SimpleText :='Loaded: '+Uri+' in '+ Time+'ms';
end
else
begin
// We are updating. Save this to load at end of update. or if there is already a request overwrite it so only the last is loaded
fUpdateURI:= Uri;
end;
end;

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

@ -10,7 +10,6 @@
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<BuildModes Count="2">
<Item1 Name="default" Default="True"/>
@ -82,10 +81,12 @@
<Unit1>
<Filename Value="chmdataprovider.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ChmDataProvider"/>
</Unit1>
<Unit2>
<Filename Value="chmspecialparser.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ChmSpecialParser"/>
</Unit2>
<Unit3>
<Filename Value="chmpopup.pas"/>
@ -108,6 +109,7 @@
<Unit6>
<Filename Value="basecontentprovider.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="BaseContentProvider"/>
</Unit6>
<Unit7>
<Filename Value="chmcontentprovider.pas"/>

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

@ -22,6 +22,9 @@ program lhelp;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}
cthreads,
{$ENDIF}
Interfaces, // this includes the LCL widgetset
SysUtils, Classes, Controls, Dialogs, Forms,
SimpleIPC, TurboPowerIPro, chmpopup, lhelpcontrolpkg, lhelpcore;

BIN
components/chmhelp/lhelp/lhelp.res
View File

Binary file not shown.

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

@ -109,6 +109,7 @@ type
fConfig: TXMLConfig;
fHasShowed: Boolean;
fHide: boolean; //If yes, start with content hidden. Otherwise start normally
fUpdateCount: Integer;
// Keep track of whether size/position preferences were loaded and applied to form
fLayoutApplied: boolean;
// Applies layout (size/position/fullscreen) preferences once in lhelp lifetime
@ -145,6 +146,10 @@ type
procedure ShowError(AError: String);
// Set keyup handler for control (and any child controls)
procedure SetKeyUp(AControl: TControl);
// BeginUpdate tells each content provider to possibly stop some events
procedure BeginUpdate;
// EndUpdate tells each content provider to resume normal behavior
procedure EndUpdate;
public
{ public declarations }
end;
@ -534,7 +539,7 @@ var
Res: LongWord;
Url: String='';
begin
if fInputIPC.PeekMessage(5, True) then
while fInputIPC.PeekMessage(5, True) do
begin
Stream := fInputIPC.MsgData;
Stream.Position := 0;
@ -604,6 +609,16 @@ begin
else
Res := ord(srError); //version not supported
debugln('got rtmisc/');
end;
mrBeginUpdate:
begin
BeginUpdate;
Res := ord(srSuccess);
end;
mrEndUpdate:
begin
EndUpdate;
Res := ord(srSuccess);
end
else {Unknown request}
Res := ord(srUnknown);
@ -834,6 +849,9 @@ begin
fPage.ContentProvider.LoadPreferences(fConfig);
end;
if fUpdateCount > 0 then
fPage.ContentProvider.BeginUpdate;
if fPage.ContentProvider.LoadURL(AURL, AContext) then
begin
PageControl.ActivePage := fPage;
@ -929,6 +947,42 @@ begin
WCont.OnKeyUp:=@FormKeyUp;
end;
procedure THelpForm.BeginUpdate;
var
Tab: TContentTab;
i: Integer;
begin
Inc(fUpdateCount);
if fUpdateCount = 1 then
begin
for i := 0 to PageControl.PageCount-1 do
begin
Tab := TContentTab(PageControl.Pages[I]);
Tab.ContentProvider.BeginUpdate;
end;
end;
end;
procedure THelpForm.EndUpdate;
var
Tab: TContentTab;
i: Integer;
begin
Dec(fUpdateCount);
if fUpdateCount < 0 then
fUpdateCount:=0;
if fUpdateCount = 0 then
begin
for i := 0 to PageControl.PageCount-1 do
begin
Tab := TContentTab(PageControl.Pages[I]);
Tab.ContentProvider.EndUpdate;
end;
end;
end;
{ TContentTab }
constructor TContentTab.Create(AOwner: TComponent);

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

@ -34,7 +34,7 @@ const
// Version 2.1: ipcname string constant part may only contain A..Z, a..z, _
type
TRequestType = (rtFile, rtUrl, rtContext, rtMisc {window handling etc});
TMiscRequests = (mrShow, mrVersion, mrClose);
TMiscRequests = (mrShow, mrVersion, mrClose, mrBeginUpdate, mrEndUpdate);
TLHelpResponse = (srError, srNoAnswer, srUnknown, srSuccess, srInvalidFile, srInvalidURL, srInvalidContext);
@ -85,6 +85,10 @@ type
function OpenContext(HelpFileName: String; Context: THelpContext): TLHelpResponse;
// Opens HelpFileName by sending a TContextRequest
function OpenFile(HelpFileName: String): TLHelpResponse;
// Send BeginUpdate through miscCommand
function BeginUpdate: TLHelpResponse;
// Send EndUpdate through miscCommand
function EndUpdate: TLHelpResponse;
// Requests to run command on viewer by sending a TMiscrequest
function RunMiscCommand(CommandID: TMiscRequests): TLHelpResponse;
// Calling code can set this to process e.g. GUI handling while waiting for help to show
@ -240,7 +244,10 @@ begin
for X := 0 to 40 do
begin
// use fServerOut.ServerRunning here instead of Self.ServerRunning to avoid a race condition
if not fServerOut.ServerRunning then Sleep(200);
if not fServerOut.ServerRunning then
Sleep(200)
else
break;
end;
end;
if fServerOut.ServerRunning then
@ -333,6 +340,16 @@ begin
end;
end;
function TLHelpConnection.BeginUpdate: TLHelpResponse;
begin
Result := RunMiscCommand(mrBeginUpdate);
end;
function TLHelpConnection.EndUpdate: TLHelpResponse;
begin
Result := RunMiscCommand(mrEndUpdate);
end;
function TLHelpConnection.RunMiscCommand(CommandID: TMiscRequests): TLHelpResponse;
var
MiscRequest : TMiscRequest;

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

@ -66,7 +66,7 @@ type
// Sets label/ID used for simpleipc communications
procedure SetHelpLabel(AValue: String);
// Check for lhelp executable, if not present, build if possible
function CheckBuildLHelp: Integer; // modal result
function CheckBuildLHelp(AForce: Boolean = False): Integer; // modal result
// Get full path of lazbuild executable
function GetLazBuildEXE(out ALazBuild: String): Boolean;
function PassTheBuck(Node: THelpNode; var ErrMsg: string): TShowHelpResult;
@ -200,10 +200,11 @@ begin
for i := 0 to SearchPaths.Count-1 do
begin
// Note: FindAllFiles has a SearchPath parameter that is a *single* directory,
SearchFiles := FindAllFiles(SearchPaths[i]);
SearchFiles := FindAllFiles(SearchPaths[i], '*.chm;*.CHM;*.Chm', False);
CHMFiles.AddStrings(SearchFiles);
SearchFiles.Free;
end;
fHelpConnection.BeginUpdate;
for i := 0 to CHMFiles.Count-1 do
begin
if UpperCase(ExtractFileExt(CHMFiles[i]))='.CHM' then
@ -215,7 +216,9 @@ begin
//Application.ProcessMessages;
end;
end;
finally
fHelpConnection.EndUpdate;
CHMFiles.Free;
SearchPaths.Free;
end;
@ -307,7 +310,7 @@ begin
end;
end;
function TChmHelpViewer.CheckBuildLHelp: Integer;
function TChmHelpViewer.CheckBuildLHelp(AForce: Boolean): Integer;
var
Lazbuild: String;
LHelpProject: String;
@ -315,12 +318,33 @@ var
WS: String;
PCP: String;
Tool: TIDEExternalToolOptions;
OrigFile: String;
TmpFile: String = '';
ExistingFile: Boolean;
begin
Result := mrCancel;
if FileExistsUTF8(GetHelpExe) then
ExistingFile := FileExistsUTF8(GetHelpExe);
if ExistingFile and not AForce then
Exit(mrOK);
if ExistingFile then
begin
OrigFile:=StringReplace(GetHelpEXE, PathDelim+PathDelim, PathDelim, [rfReplaceAll]);
TmpFile:=ChangeFileExt(OrigFile, '.tmp');
//debugln(['TChmHelpViewer.CheckBuildLHelp forced rebuilding of lhelp']);
if FileExistsUTF8(TmpFile) then
DeleteFileUTF8(TmpFile);
if not RenameFile(OrigFile, TmpFile) then
begin
debugln(['TChmHelpViewer.CheckBuildLHelp no permission to modify lhelp executable']);
// we don't have permission to move or rebuild lhelp so exit
// Exit with mrYes anyway since lhelp is still present, just an older version
Exit(mrYes);
end;
end;
if not GetLazBuildEXE(Lazbuild) then
begin
debugln(['TChmHelpViewer.CheckBuildLHelp failed because lazbuild not found']);
@ -353,7 +377,19 @@ begin
Tool.Scanners.Add(SubToolFPC);
Tool.Scanners.Add(SubToolMake);
if RunExternalTool(Tool) then
begin
Result:=mrOk;
if (TmpFile <> '') and FileExistsUTF8(TmpFile) then
DeleteFileUTF8(TmpFile);
end
else
begin
debugln(['TChmHelpViewer.CheckBuildLHelp failed building of lhelp. Trying to use old version']);
// compile failed
// try to copy back the old lhelp if it existed
if (TmpFile <> '') and FileExistsUTF8(TmpFile) and RenameFile(TmpFile, OrigFile) then
Result := mrOK;
end;
finally
Tool.Free;
end;
@ -549,13 +585,37 @@ begin
// This will allow cross-chm (LCL, FCL etc) searching and browsing in lhelp.
if not(WasRunning) then
begin
if fHelpConnection.BeginUpdate = srError then
begin
// existing lhelp doesn't understand mrBeginUpdate and needs to be rebuilt
//close lhelp
if fHelpConnection.RunMiscCommand(LHelpControl.mrClose) <> srError then
begin
// force rebuild of lhelp
// this may not succeed but the old lhelp will be restarted anyway and
// just return error codes for unknown messages.
if CheckBuildLHelp(True) = mrOK then
begin
// start it again
Debugln(['TChmHelpViewer.ShowNode restarting lhelp to use updated protocols']);
fHelpConnection.StartHelpServer(HelpLabel, GetHelpExe, true);
// now run begin update
fHelpConnection.BeginUpdate; // it inc's a value so calling it more than once doesn't hurt
end;
end;
end;
OpenAllCHMsInSearchPath(SearchPath);
// Instruct viewer to show its GUI
Response:=fHelpConnection.RunMiscCommand(mrShow);
if Response<>srSuccess then
debugln('Help viewer gave error response to mrShow command. Response was: ord: '+inttostr(ord(Response)));
end;
fHelpConnection.BeginUpdate;
Response := fHelpConnection.OpenURL(FileName, Url);
fHelpConnection.EndUpdate;
if not WasRunning then
fHelpConnection.EndUpdate;
end
else
begin