From a9580c0b0d92c92cefab8c8964d34add480257c8 Mon Sep 17 00:00:00 2001 From: joost Date: Tue, 11 Apr 2017 17:36:07 +0000 Subject: [PATCH] * Handle fppkg-commands in separate worker-thread git-svn-id: trunk@54605 - --- .gitattributes | 1 + components/fppkg/languages/lazarusfppkg.po | 4 + components/fppkg/src/fppkg_mainfrm.pas | 210 +++++++++++++------ components/fppkg/src/fppkgpackagemanager.lpk | 6 +- components/fppkg/src/fppkgpackagemanager.pas | 2 +- components/fppkg/src/fppkgworkerthread.pas | 106 ++++++++++ components/fppkg/src/laz_pkgrepos.pas | 8 + 7 files changed, 268 insertions(+), 69 deletions(-) create mode 100644 components/fppkg/src/fppkgworkerthread.pas diff --git a/.gitattributes b/.gitattributes index 5d227b0e2f..45f8283ab5 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1448,6 +1448,7 @@ components/fppkg/src/fppkg_optionsfrm.lfm svneol=native#text/plain components/fppkg/src/fppkg_optionsfrm.pas svneol=native#text/plain components/fppkg/src/fppkgpackagemanager.lpk svneol=native#text/plain components/fppkg/src/fppkgpackagemanager.pas svneol=native#text/plain +components/fppkg/src/fppkgworkerthread.pas svneol=native#text/plain components/fppkg/src/laz_pkgcommands.pas svneol=native#text/plain components/fppkg/src/laz_pkgrepos.pas svneol=native#text/plain components/fppkg/src/lazfppkgmanagerintf.pas svneol=native#text/plain diff --git a/components/fppkg/languages/lazarusfppkg.po b/components/fppkg/languages/lazarusfppkg.po index 6acbbe19a3..a121c8de10 100644 --- a/components/fppkg/languages/lazarusfppkg.po +++ b/components/fppkg/languages/lazarusfppkg.po @@ -48,6 +48,10 @@ msgstr "" msgid "%s succeeded." msgstr "" +#: fppkg_mainfrm.smsgfppkgrunning +msgid "A prior command is still in progress." +msgstr "" + #: tfppkgform.archivebutton.caption msgid "Archive" msgstr "" diff --git a/components/fppkg/src/fppkg_mainfrm.pas b/components/fppkg/src/fppkg_mainfrm.pas index c0ed7837af..845a97f0fc 100644 --- a/components/fppkg/src/fppkg_mainfrm.pas +++ b/components/fppkg/src/fppkg_mainfrm.pas @@ -38,8 +38,10 @@ unit fppkg_mainfrm; interface uses - Classes, SysUtils, Forms, Controls, StdCtrls, ComCtrls, ExtCtrls, Buttons, - Menus, CheckLst, Dialogs, fppkg_const, + Classes, SysUtils, + lazCollections, + Forms, Controls, StdCtrls, ComCtrls, ExtCtrls, Buttons, + Menus, CheckLst, Dialogs, fppkg_const, LCLIntf, LMessages, fppkg_optionsfrm, fppkg_details, pkgFppkg, //IDE interface @@ -52,12 +54,10 @@ uses // Package Handler components pkghandler, pkgcommands, //downloader - pkgfphttp; + pkgfphttp, + FppkgWorkerThread; type - TFppkgConfigOptions = record - ConfigFile: string; - end; { TFppkgForm } @@ -108,6 +108,7 @@ type procedure CompileButtonClick(Sender: TObject); procedure DownloadButtonClick(Sender: TObject); procedure FixBrokenButtonClick(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: boolean); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure InstallButtonClick(Sender: TObject); @@ -124,12 +125,21 @@ type procedure SearchEditKeyUp(Sender: TObject; var Key: word; Shift: TShiftState); procedure SupportCheckGroupItemClick(Sender: TObject; Index: integer); procedure UpdateButtonClick(Sender: TObject); + procedure HandleLog(var Msg: TLMessage); message WM_LogMessageWaiting; + procedure HandleWorkerThreadDone(var Msg: TLMessage); message WM_WorkerThreadDone; private SearchPhrases: TStrings; - FErrors: TStrings; + FBufferLogLines: TStrings; + FLogMonitor: TLazMonitor; + FMainThreadTriggered: Boolean; + FFPpkg: TpkgFPpkg; FLazPackages: TLazPackages; + FErrors: TStringList; + FCurrentlyRunningTaskDescription: string; + + FWorkerThread: TFppkgWorkerThread; function PkgColumnValue(AName: string; pkg: TLazPackage): string; @@ -149,7 +159,8 @@ type procedure ShowError(const Description, Error: String); public - procedure OnError(const Msg: String); + procedure OnErrorThreadSafe(const Msg: String); + procedure OnLogThreadSafe(const Msg: String); end; var @@ -166,6 +177,7 @@ uses resourcestring SErrActionFailed = 'Failed to %s: ' + sLineBreak + sLineBreak + '%s'; SMsgActionSucceeded = '%s succeeded.'; + SMsgFppkgRunning = 'A prior command is still in progress.'; SActFixBroken = 'fix broken packages'; SActCleanPackages = 'clean package(s)'; SActCompilePackages = 'compile packages'; @@ -183,35 +195,31 @@ var begin if not(Level in LogLevels) then exit; - Prefix:=''; case Level of - {$IF FPC_FULLVERSION > 20602} llWarning : Prefix:=SWarning; llError : Prefix:=SError; - {$ELSE} - vlWarning : - Prefix:=SWarning; - vlError : - Prefix:=SError; - {$ENDIF} -{ vlInfo : - Prefix:='I: '; - vlCommands : - Prefix:='C: '; - vlDebug : - Prefix:='D: '; } + llInfo : + Prefix:=SInfo; + llCommands : + Prefix:=SCommand; + llDebug : + Prefix:=SDebug; + llProgres : + Prefix:=SProgres + else + Prefix := ''; end; if Assigned(FppkgForm) then - FppkgForm.OutputMemo.Lines.Add(DateTimeToStr(Now) + ' ' + Prefix + ' ' + Msg); + FppkgForm.OnLogThreadSafe(DateTimeToStr(Now) + ' ' + Prefix + ' ' + Msg); end; procedure LazError(const Msg: String); begin if Assigned(FppkgForm) then - FppkgForm.OnError(Msg) + FppkgForm.OnErrorThreadSafe(Msg) else ShowMessage(Msg); end; @@ -229,6 +237,15 @@ begin s.Free; end; +procedure TFppkgForm.FormCloseQuery(Sender: TObject; var CanClose: boolean); +begin + if Assigned(FWorkerThread) and not FWorkerThread.Finished then + begin + ShowMessage(SMsgFppkgRunning); + CanClose := False; + end; +end; + procedure TFppkgForm.CleanButtonClick(Sender: TObject); var s: TStrings; @@ -317,10 +334,16 @@ end; procedure TFppkgForm.FormCreate(Sender: TObject); var i: Integer; - StoredGetVendorName: TGetVendorNameEvent; - StoredGetApplicationName: TGetAppNameEvent; begin //setup log callback function + + // This is a strange hack. When a message is send to this form while it + // is being created, the checkboxes in the PackageListView are not visible + // afterwards. + FMainThreadTriggered := True; + + FLogMonitor := TLazMonitor.Create; + FBufferLogLines := TStringList.Create; LogLevels := AllLogLevels; LogHandler := @LazLog; @@ -362,12 +385,25 @@ begin RescanPackages; + FLogMonitor.Enter; + // Hack, see the earlier comment. + FMainThreadTriggered := false; FErrors := TStringList.Create; + FLogMonitor.Release; end; procedure TFppkgForm.FormDestroy(Sender: TObject); begin + if Assigned(FWorkerThread) then + begin + FWorkerThread.Terminate; + FWorkerThread.WaitFor; + FWorkerThread.Free; + end; + + FLogMonitor.Free; FreeAndNil(FErrors); + FBufferLogLines.Free; SearchPhrases.Free; end; @@ -553,6 +589,44 @@ begin s.Free; end; +procedure TFppkgForm.HandleLog(var Msg: TLMessage); +var + SB: TMemoScrollbar; +begin + FLogMonitor.Enter; + try + OutputMemo.Lines.AddStrings(FBufferLogLines); + FBufferLogLines.Clear; + FMainThreadTriggered := false; + SB := OutputMemo.VertScrollBar; + SB.Position := SB.Range - SB.Page; + finally + FLogMonitor.Leave; + end; +end; + +procedure TFppkgForm.HandleWorkerThreadDone(var Msg: TLMessage); +var + s: String; + SB: TMemoScrollbar; +begin + FLogMonitor.Enter; + try + if FErrors.Count>0 then + ShowError(FCurrentlyRunningTaskDescription, FErrors[0]) + else + begin + s := Format(SMsgActionSucceeded, [FCurrentlyRunningTaskDescription]); + s[1] := upCase(s[1]); + ShowMessage(s); + end; + finally + FLogMonitor.Leave; + end; + FreeAndNil(FWorkerThread); + RescanPackages; +end; + procedure TFppkgForm.MaybeCreateLocalDirs; begin ForceDirectories(FFPpkg.Options.GlobalSection.BuildDir); @@ -640,44 +714,20 @@ end; procedure TFppkgForm.DoRun(cfg: TFppkgConfigOptions; ParaAction: string; ParaPackages: TStrings; Description: string); -var - OldCurrDir: string; - i: integer; - s: string; begin - pkghandler.ClearExecutedAction; + if Assigned(FWorkerThread) then + begin + if not FWorkerThread.Finished then + begin + ShowMessage(SMsgFppkgRunning); + Exit; + end; + FWorkerThread.WaitFor; + FWorkerThread.Free; + end; FErrors.Clear; - - OldCurrDir := GetCurrentDir; - try - if ParaPackages.Count = 0 then - begin - pkghandler.ExecuteAction(CurrentDirPackageName, ParaAction, FFPpkg); - end - else - begin - // Process packages - for i := 0 to ParaPackages.Count - 1 do - begin - pkgglobals.Log({$IF FPC_FULLVERSION > 20602}llDebug{$ELSE}vlDebug{$ENDIF}, SLogCommandLineAction,['[' + ParaPackages[i] + ']', ParaAction]); - pkghandler.ExecuteAction(ParaPackages[i], ParaAction, FFPpkg); - end; - end; - - s := Format(SMsgActionSucceeded, [Description]); - s[1] := upCase(s[1]); - if FErrors.Count=0 then - ShowMessage(s); - except - On E: Exception do - begin - Error(SErrException + LineEnding + E.Message); - end; - end; - SetCurrentDir(OldCurrDir); - if FErrors.Count>0 then - ShowError(Description, FErrors[0]); - RescanPackages; + FCurrentlyRunningTaskDescription := Description; + FWorkerThread := TFppkgWorkerThread.Create(ParaAction, ParaPackages, Description, Handle); end; function TFppkgForm.PkgColumnValue(AName: string; pkg: TLazPackage): string; @@ -816,15 +866,41 @@ begin ShowMessage(Format(SErrActionFailed, [Description, Error])) end; -procedure TFppkgForm.OnError(const Msg: String); +procedure TFppkgForm.OnErrorThreadSafe(const Msg: String); begin // Cache all errors and show the them after a command has been finished // completely. This because most problems lead to multiple errors, which is // annoying in a GUI-environment - if Assigned(FErrors) then - FErrors.Add(Msg) - else - ShowError(SActInitializeFppkg, Msg); + FLogMonitor.Enter; + try + if Assigned(FErrors) then + begin + FErrors.Add(Msg); + Exit; + end; + finally + FLogMonitor.Leave; + end; + ShowError(SActInitializeFppkg, Msg); +end; + +procedure TFppkgForm.OnLogThreadSafe(const Msg: String); +begin + FLogMonitor.Enter; + try + FBufferLogLines.Add(Msg); + if not FMainThreadTriggered then + begin + FMainThreadTriggered := true; + PostMessage(Handle, WM_LogMessageWaiting, 0, 0); + end + else + begin + FMainThreadTriggered := True; + end; + finally + FLogMonitor.Leave; + end; end; end. diff --git a/components/fppkg/src/fppkgpackagemanager.lpk b/components/fppkg/src/fppkgpackagemanager.lpk index 4430bce1b8..586fa6a955 100644 --- a/components/fppkg/src/fppkgpackagemanager.lpk +++ b/components/fppkg/src/fppkgpackagemanager.lpk @@ -19,7 +19,7 @@ - + @@ -57,6 +57,10 @@ + + + + diff --git a/components/fppkg/src/fppkgpackagemanager.pas b/components/fppkg/src/fppkgpackagemanager.pas index 5fc25f513d..7a36badf38 100644 --- a/components/fppkg/src/fppkgpackagemanager.pas +++ b/components/fppkg/src/fppkgpackagemanager.pas @@ -9,7 +9,7 @@ interface uses lazfppkgmanagerintf, fppkg_const, fppkg_details, fppkg_mainfrm, fppkg_optionsfrm, laz_pkgrepos, - LazarusPackageIntf; + FppkgWorkerThread, LazarusPackageIntf; implementation diff --git a/components/fppkg/src/fppkgworkerthread.pas b/components/fppkg/src/fppkgworkerthread.pas new file mode 100644 index 0000000000..4ec2c24d4f --- /dev/null +++ b/components/fppkg/src/fppkgworkerthread.pas @@ -0,0 +1,106 @@ +unit FppkgWorkerThread; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + LCLIntf, + pkghandler, + pkgoptions, + pkgglobals, + pkgFppkg, + pkgmessages, + laz_pkgrepos; + +type + + { TFppkgWorkerThread } + + TFppkgWorkerThread = class(TThread) + private + FParaPackages: TStrings; + FParaAction: string; + FReturnHandle: THandle; + + FFPpkg: TpkgFPpkg; + protected + procedure Execute; override; + public + constructor Create(ParaAction: string; ParaPackages: TStrings; Description: string; ReturnHandle: THandle); + destructor Destroy; override; + end; + + +implementation + +{ TFppkgWorkerThread } + +procedure TFppkgWorkerThread.Execute; +var + OldCurrDir: string; + i: integer; + s: string; +begin + pkghandler.ClearExecutedAction; + + FFPpkg := TpkgFPpkg.Create(Nil); + FFPpkg.InitializeGlobalOptions(''); + FFPpkg.Options.GlobalSection.Downloader := 'FPC'; + FFPpkg.InitializeCompilerOptions; + + FFPpkg.CompilerOptions.InitCompilerDefaults; + FFPpkg.FpmakeCompilerOptions.InitCompilerDefaults; + FFPpkg.CompilerOptions.CheckCompilerValues; + FFPpkg.FpmakeCompilerOptions.CheckCompilerValues; + FFPpkg.LoadLocalAvailableMirrors; + + FFPpkg.ScanAvailablePackages; + FFPpkg.ScanPackages; + + OldCurrDir := GetCurrentDir; + try + if FParaPackages.Count = 0 then + begin + pkghandler.ExecuteAction(CurrentDirPackageName, FParaAction, FFPpkg); + end + else + begin + // Process packages + for i := 0 to FParaPackages.Count - 1 do + begin + pkgglobals.Log(llDebug, SLogCommandLineAction,['[' + FParaPackages[i] + ']', FParaAction]); + pkghandler.ExecuteAction(FParaPackages[i], FParaAction, FFPpkg); + end; + end; + except + On E: Exception do + begin + Error(SErrException + LineEnding + E.Message); + end; + end; + SetCurrentDir(OldCurrDir); + PostMessage(FReturnHandle, WM_WorkerThreadDone, 0, 0); +end; + +constructor TFppkgWorkerThread.Create(ParaAction: string; ParaPackages: TStrings; + Description: string; ReturnHandle: THandle); +begin + FParaPackages := TStringList.Create; + FParaPackages.Assign(ParaPackages); + FParaAction := ParaAction; + FReturnHandle := ReturnHandle; + inherited Create(False); +end; + +destructor TFppkgWorkerThread.Destroy; +begin + FParaPackages.Free; + FFPpkg.Free; + inherited Destroy; +end; + +end. + diff --git a/components/fppkg/src/laz_pkgrepos.pas b/components/fppkg/src/laz_pkgrepos.pas index 6514fc851c..8e857a7073 100644 --- a/components/fppkg/src/laz_pkgrepos.pas +++ b/components/fppkg/src/laz_pkgrepos.pas @@ -6,11 +6,19 @@ interface uses SysUtils, Classes, + LMessages, fgl, pkgFppkg, fprepos{$IF FPC_FULLVERSION > 20602}, fpmkunit{$ENDIF}; +const + WM_LogMessageWaiting = LM_USER + 1; + WM_WorkerThreadDone = LM_USER + 2; + type + TFppkgConfigOptions = record + ConfigFile: string; + end; { TLazFPPackage }