From 01a1baa804111ac31fac6f0ef2adc20af5767583 Mon Sep 17 00:00:00 2001 From: balazs Date: Wed, 31 Oct 2018 18:43:35 +0000 Subject: [PATCH] Opkman: Prevent memory leaks(step1) + other changes - remove threaded timer to prevent memory leaks - calculate download/extract speed with different method - restructure the update thread - prevent IDE freeze - change repository names to "Official repository" and "Third party repository" - make the unintuitive "Install" button intuitive again - make install process faster git-svn-id: trunk@59405 - --- .gitattributes | 1 - .../onlinepackagemanager.lpk | 76 ++++++----- .../onlinepackagemanager.pas | 19 ++- .../onlinepackagemanager/opkman_const.pas | 4 +- .../opkman_downloader.pas | 76 +++-------- .../onlinepackagemanager/opkman_installer.pas | 4 +- .../onlinepackagemanager/opkman_intf.pas | 121 ++++++++++-------- .../onlinepackagemanager/opkman_mainfrm.lfm | 2 + .../onlinepackagemanager/opkman_mainfrm.pas | 106 +++++---------- .../opkman_progressfrm.lfm | 2 +- .../opkman_progressfrm.pas | 15 ++- .../onlinepackagemanager/opkman_timer.pas | 105 --------------- .../onlinepackagemanager/opkman_updates.pas | 67 ++++++---- .../onlinepackagemanager/opkman_zipper.pas | 38 +++--- 14 files changed, 234 insertions(+), 402 deletions(-) delete mode 100644 components/onlinepackagemanager/opkman_timer.pas diff --git a/.gitattributes b/.gitattributes index 15a0cf75d1..9cf259ea88 100644 --- a/.gitattributes +++ b/.gitattributes @@ -3725,7 +3725,6 @@ components/onlinepackagemanager/opkman_showhint.lfm -text svneol=native#plain/te components/onlinepackagemanager/opkman_showhint.pas svneol=native#text/pascal components/onlinepackagemanager/opkman_showhintbase.lfm -text svneol=native#plain/text components/onlinepackagemanager/opkman_showhintbase.pas svneol=native#text/pascal -components/onlinepackagemanager/opkman_timer.pas svneol=native#text/pascal components/onlinepackagemanager/opkman_updates.pas svneol=native#text/pascal components/onlinepackagemanager/opkman_uploader.pas svneol=native#text/pascal components/onlinepackagemanager/opkman_visualtree.pas svneol=native#text/pascal diff --git a/components/onlinepackagemanager/onlinepackagemanager.lpk b/components/onlinepackagemanager/onlinepackagemanager.lpk index 6ac36f1f47..e55d0b6817 100644 --- a/components/onlinepackagemanager/onlinepackagemanager.lpk +++ b/components/onlinepackagemanager/onlinepackagemanager.lpk @@ -25,7 +25,7 @@ For more info please visit: http://wiki.freepascal.org/Online_Package_Manager"/> - + @@ -71,83 +71,79 @@ For more info please visit: http://wiki.freepascal.org/Online_Package_Manager"/> - - - - - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - + diff --git a/components/onlinepackagemanager/onlinepackagemanager.pas b/components/onlinepackagemanager/onlinepackagemanager.pas index eee5d74b1f..8b4c7e0521 100644 --- a/components/onlinepackagemanager/onlinepackagemanager.pas +++ b/components/onlinepackagemanager/onlinepackagemanager.pas @@ -10,22 +10,21 @@ interface uses onlinepackagemanagerintf, opkman_mainfrm, opkman_optionsfrm, opkman_const, opkman_visualtree, opkman_serializablepackages, opkman_downloader, - opkman_common, opkman_progressfrm, opkman_zipper, opkman_timer, - opkman_installer, opkman_packagelistfrm, opkman_options, - opkman_createrepositorypackagefrm, opkman_categoriesfrm, - opkman_packagedetailsfrm, opkman_updates, opkman_createjsonforupdatesfrm, - opkman_uploader, opkman_repositories, opkman_createrepositoryfrm, - opkman_repositorydetailsfrm, opkman_addrepositorypackagefrm, opkman_intf, - opkman_intf_packagelistfrm, opkman_showhint, opkman_showhintbase, - opkman_colorsfrm, LazarusPackageIntf; + opkman_common, opkman_progressfrm, opkman_zipper, opkman_installer, + opkman_packagelistfrm, opkman_options, opkman_createrepositorypackagefrm, + opkman_categoriesfrm, opkman_packagedetailsfrm, opkman_updates, + opkman_createjsonforupdatesfrm, opkman_uploader, opkman_repositories, + opkman_createrepositoryfrm, opkman_repositorydetailsfrm, + opkman_addrepositorypackagefrm, opkman_intf, opkman_intf_packagelistfrm, + opkman_showhint, opkman_showhintbase, opkman_colorsfrm, LazarusPackageIntf; implementation procedure Register; begin - RegisterUnit('onlinepackagemanagerintf', @onlinepackagemanagerintf.Register); + RegisterUnit('onlinepackagemanagerintf', @ onlinepackagemanagerintf.Register); end; initialization - RegisterPackage('OnlinePackageManager', @Register); + RegisterPackage('OnlinePackageManager', @ Register); end. diff --git a/components/onlinepackagemanager/opkman_const.pas b/components/onlinepackagemanager/opkman_const.pas index 6aea4d281a..65c7f9a45f 100644 --- a/components/onlinepackagemanager/opkman_const.pas +++ b/components/onlinepackagemanager/opkman_const.pas @@ -166,8 +166,8 @@ resourcestring rsMainFrm_TBOptions_Hint = 'Show options dialog'; rsMainFrm_TBHelp_Caption = 'Help'; rsMainFrm_TBHelp_Hint = 'Help (' + cHelpPage + ')'; - rsMainFrm_miFromRepository = 'From repository'; - rsMainFrm_miFromExternalSource = 'From external source'; + rsMainFrm_miFromRepository = 'From official repository'; + rsMainFrm_miFromExternalSource = 'From third party repository'; rsMainFrm_miCreateRepositoryPackage = 'Create repository package'; rsMainFrm_miCreateJSONForUpdates = 'Create JSON for updates'; rsMainFrm_miCreateRepository = 'Create private repository'; diff --git a/components/onlinepackagemanager/opkman_downloader.pas b/components/onlinepackagemanager/opkman_downloader.pas index 4c0277b9c7..957a7562ba 100644 --- a/components/onlinepackagemanager/opkman_downloader.pas +++ b/components/onlinepackagemanager/opkman_downloader.pas @@ -33,7 +33,7 @@ interface uses Classes, SysUtils, fpjson, LazIDEIntf, // OpkMan - opkman_timer, opkman_common, opkman_serializablepackages, opkman_const, opkman_options, + opkman_common, opkman_serializablepackages, opkman_const, opkman_options, {$IFDEF FPC311}fphttpclient{$ELSE}opkman_httpclient{$ENDIF}; type @@ -88,10 +88,10 @@ type FTotPos: Int64; FTotPosTmp: Int64; FTotSize: Int64; - FElapsed: Integer; FRemaining: Integer; FSpeed: Integer; - FTimer: TThreadTimer; + FStartTime: QWord; + FElapsed: QWord; FNeedToBreak: Boolean; FDownloadTo: String; FUPackageName: String; @@ -107,7 +107,6 @@ type FOnPackageUpdateCompleted: TOnPackageUpdateCompleted; function GetUpdateSize(const AURL: String; var AErrMsg: String): Int64; procedure DoReceivedUpdateSize(Sender: TObject; const ContentLength, {%H-}CurrentPos: int64); - procedure DoOnTimer(Sender: TObject); procedure DoOnJSONProgress; procedure DoOnJSONDownloadCompleted; procedure DoOnWriteStream(Sender: TObject; APos: Int64); @@ -272,27 +271,6 @@ begin end; end; -procedure TThreadDownload.DoOnTimer(Sender: TObject); -begin - if FDownloadType = dtJSON then - begin - FHTTPClient.Terminate; - FErrMsg := rsMainFrm_rsMessageError2; - FErrTyp := etTimeOut; - if Assigned(FTimer) then - FTimer.StopTimer; - TThreadTimer(Sender).Synchronize(@DoOnJSONDownloadCompleted); - //Synchronize(@DoOnJSONDownloadCompleted); - FOnJSONComplete := nil; - end - else if (FDownloadType = dtPackage) or (FDownloadType = dtUpdate) then - begin - Inc(FElapsed); - FSpeed := Round(FTotPosTmp/FElapsed); - if FSpeed > 0 then - FRemaining := Round((FTotSize - FTotPosTmp)/FSpeed); - end; -end; procedure TThreadDownload.DoOnJSONProgress; begin @@ -304,8 +282,15 @@ end; procedure TThreadDownload.DoOnWriteStream(Sender: TObject; APos: Int64); begin + FElapsed := GetTickCount64 - FStartTime; + if FElapsed < 1000 then + Exit; + FElapsed := FElapsed div 1000; FCurPos := APos; FTotPosTmp := FTotPos + APos; + FSpeed := Round(FTotPosTmp/FElapsed); + if FSpeed > 0 then + FRemaining := Round((FTotSize - FTotPosTmp)/FSpeed); Synchronize(@DoOnPackageDownloadProgress); Sleep(5); end; @@ -317,11 +302,13 @@ var UpdateSize: Int64; UpdCnt: Integer; begin + Sleep(50); FErrMsg := ''; FErrTyp := etNone; if FDownloadType = dtJSON then //JSON begin - Synchronize(@DoOnJSONProgress); + if not FNeedToBreak then + Synchronize(@DoOnJSONProgress); if FRemoteJSONFile <> cRemoteJSONFile then begin try @@ -341,14 +328,13 @@ begin FErrTyp := etConfig; FErrMsg := rsMainFrm_rsMessageNoRepository0; end; - if Assigned(FTimer) and FTimer.Enabled then - FTimer.StopTimer; if not FNeedToBreak then - Synchronize(@DoOnJSONDownloadCompleted); + Synchronize(@DoOnJSONDownloadCompleted) end else if FDownloadType = dtPackage then //download from repository begin FCnt := 0; + FStartTime := GetTickCount64; for I := 0 to SerializablePackages.Count - 1 do begin if NeedToBreak then @@ -392,6 +378,7 @@ begin begin FCnt := 0; UpdCnt := 0; + FStartTime := GetTickCount64; for I := 0 to SerializablePackages.Count - 1 do begin if FNeedToBreak then @@ -434,8 +421,6 @@ begin begin FUSuccess := True; Synchronize(@DoOnPackageUpdateCompleted); - if Assigned(FTimer) then - FTimer.Enabled := True; FCnt := 0; FTotCnt := UpdCnt; for I := 0 to SerializablePackages.Count - 1 do @@ -487,7 +472,6 @@ constructor TThreadDownload.Create; begin inherited Create(True); FreeOnTerminate := True; - FTimer := nil; FMS := TMemoryStream.Create; FHTTPClient := TFPHTTPClient.Create(nil); if Options.ProxyEnabled then @@ -501,13 +485,6 @@ end; destructor TThreadDownload.Destroy; begin - if Assigned(FTimer) then - begin - if FTimer.Enabled then - FTimer.StopTimer; - FTimer.Terminate; - FTimer.WaitFor; - end; FHTTPClient.Free; FMS.Free; inherited Destroy; @@ -520,13 +497,7 @@ begin FDownloadType := dtJSON; FSilent := ASilent; if Assigned(LazarusIDE) and LazarusIDE.IDEStarted and not LazarusIDE.IDEIsClosing then - begin - FTimer := TThreadTimer.Create; - FTimer.Interval := ATimeOut; - FTimer.OnTimer := @DoOnTimer; - FTimer.StartTimer; Start; - end; end; procedure TThreadDownload.DownloadPackages(const ADownloadTo: String); @@ -546,12 +517,7 @@ begin end; end; if Assigned(LazarusIDE) and LazarusIDE.IDEStarted and not LazarusIDE.IDEIsClosing then - begin - FTimer := TThreadTimer.Create; - FTimer.OnTimer := @DoOnTimer; - FTimer.StartTimer; Start; - end; end; procedure TThreadDownload.DoReceivedUpdateSize(Sender: TObject; @@ -613,13 +579,7 @@ begin if (SerializablePackages.Items[I].Checked) and (Trim(SerializablePackages.Items[I].DownloadZipURL) <> '') then Inc(FTotCnt); if (Assigned(LazarusIDE) and LazarusIDE.IDEStarted and (not LazarusIDE.IDEIsClosing)) then - begin - FTimer := TThreadTimer.Create; - FTimer.OnTimer := @DoOnTimer; - FTimer.StartTimer; - FTimer.Enabled := False; Start; - end; end; { TPackageDownloader} @@ -686,6 +646,8 @@ end; destructor TPackageDownloader.Destroy; begin +{ if Assigned(FDownload) then + FDownload.Terminate;} inherited Destroy; end; @@ -725,8 +687,6 @@ begin if Assigned(FDownload) then begin FDownload.FHTTPClient.Terminate; - if Assigned(FDownload.FTimer) then - FDownload.FTimer.StopTimer; FDownload.NeedToBreak := True; end; end; diff --git a/components/onlinepackagemanager/opkman_installer.pas b/components/onlinepackagemanager/opkman_installer.pas index 6a1fbddb01..ebff5db7db 100644 --- a/components/onlinepackagemanager/opkman_installer.pas +++ b/components/onlinepackagemanager/opkman_installer.pas @@ -200,7 +200,7 @@ begin if Assigned(FOnPackageInstallProgress) then FOnPackageInstallProgress(Self, FCnt, FTotCnt, FFileName, AInstallMessage); if AInstallMessage <> imPackageCompleted then - Sleep(1000); + Sleep(50); end; procedure TPackageInstaller.DoOnPackageInstallError(const AInstallMessage: TInstallMessage; @@ -222,7 +222,7 @@ begin ALazarusPkg.PackageStates := ALazarusPkg.PackageStates + [psError]; if Assigned(FOnPackageInstallError) then FOnPackageInstallError(Self, FFileName, ErrMsg); - Sleep(1000); + Sleep(50); end; procedure TPackageInstaller.Execute; diff --git a/components/onlinepackagemanager/opkman_intf.pas b/components/onlinepackagemanager/opkman_intf.pas index 546f3ba2ec..556332fe9c 100644 --- a/components/onlinepackagemanager/opkman_intf.pas +++ b/components/onlinepackagemanager/opkman_intf.pas @@ -29,11 +29,12 @@ unit opkman_intf; interface uses - Classes, SysUtils, Forms, Dialogs, Controls, contnrs, fpjson, + Classes, SysUtils, Forms, Dialogs, Controls, contnrs, fpjson, ExtCtrls, md5, + dateutils, // IdeIntf LazIDEIntf, PackageIntf, PackageLinkIntf, PackageDependencyIntf, IDECommands, // OPM - opkman_timer, opkman_downloader, opkman_serializablepackages, opkman_installer; + opkman_downloader, opkman_serializablepackages, opkman_installer, opkman_updates; type @@ -45,15 +46,16 @@ type FPackagesToInstall: TObjectList; FPackageDependecies: TObjectList; FPackageLinks: TObjectList; - FWaitForIDE: TThreadTimer; + FTimer: TTimer; FNeedToInit: Boolean; - FBusyUpdating: Boolean; - procedure DoWaitForIDE(Sender: TObject); + procedure DoOnTimer(Sender: TObject); procedure DoUpdatePackageLinks(Sender: TObject); + procedure DoOnIDEClose(Sender: TObject); procedure InitOPM; procedure SynchronizePackages; procedure AddToDownloadList(const AName: String); procedure AddToInstallList(const AName: String); + procedure DoHandleException(Sender: TObject; E: Exception); function Download(const ADstDir: String): TModalResult; function Extract(const ASrcDir, ADstDir: String; const AIsUpdate: Boolean = False): TModalResult; function Install(var AInstallStatus: TInstallStatus; var ANeedToRebuild: Boolean): TModalResult; @@ -78,24 +80,21 @@ uses opkman_common, opkman_options, opkman_const, opkman_progressfrm, opkman_zip constructor TOPMInterfaceEx.Create; begin + Application.AddOnExceptionHandler(@DoHandleException); FPackageLinks := TObjectList.Create(False); FPackagesToDownload := TObjectList.Create(False); FPackagesToInstall := TObjectList.Create(False); FPackageDependecies := TObjectList.Create(False); FNeedToInit := True; - FWaitForIDE := TThreadTimer.Create; - FWaitForIDE.Interval := 100; - FWaitForIDE.OnTimer := @DoWaitForIDE; - FWaitForIDE.StartTimer; + FTimer := TTimer.Create(nil); + FTimer.Interval := 50; + FTimer.OnTimer := @DoOnTimer; + FTimer.Enabled := True; end; destructor TOPMInterfaceEx.Destroy; begin - if (PackageDownloader<>nil) and PackageDownloader.DownloadingJSON then - PackageDownloader.Cancel; - FWaitForIDE.StopTimer; - FWaitForIDE.Terminate; - FWaitForIDE.WaitFor; + FTimer.Free; FPackageLinks.Clear; FPackageLinks.Free; FPackagesToDownload.Clear; @@ -111,30 +110,43 @@ begin inherited Destroy; end; -procedure TOPMInterfaceEx.DoWaitForIDE(Sender: TObject); +procedure TOPMInterfaceEx.DoOnIDEClose(Sender: TObject); begin - if Assigned(LazarusIDE) and Assigned(PackageEditingInterface) then + if Assigned(Updates) then + begin + Updates.StopUpdate; + Updates.Terminate; + Sleep(100); + end; +end; + + +procedure TOPMInterfaceEx.DoOnTimer(Sender: TObject); +var + FileName: String; +begin + if Assigned(LazarusIDE) and Assigned(PackageEditingInterface) and (not LazarusIDE.IDEIsClosing) then begin if FNeedToInit then begin InitOPM; FNeedToInit := False; - FWaitForIDE.StopTimer; - FWaitForIDE.Interval := 5000; - FWaitForIDE.StartTimer; + FTimer.Enabled := False; + FTimer.Interval := 5000; + FTimer.Enabled := True; end else begin - if (FPackageLinks.Count = 0) then + FTimer.Enabled := False; + if (not LazarusIDE.IDEIsClosing) then begin - if (not PackageDownloader.DownloadingJSON) and (not Application.Terminated) then + if Options.CheckForUpdates <> 5 then PackageDownloader.DownloadJSON(Options.ConTimeOut*1000, True); - Exit; + LazarusIDE.AddHandlerOnIDEClose(@DoOnIDEClose); + FileName := Format(LocalRepositoryUpdatesFile, [MD5Print(MD5String(Options.RemoteRepository[Options.ActiveRepositoryIndex]))]); + Updates := TUpdates.Create(FileName); + Updates.StartUpdate; end; - if (not Application.terminated) then - if (not FBusyUpdating) then - if (Assigned(OnPackageListAvailable)) then - OnPackageListAvailable(Self); end; end; end; @@ -179,41 +191,36 @@ var PackageLink: TPackageLink; FileName, Name, URL: String; begin - if FBusyUpdating then - Exit; - FBusyUpdating := True; - try - PkgLinks.ClearOnlineLinks; - FPackageLinks.Clear; - for I := 0 to SerializablePackages.Count - 1 do + PkgLinks.ClearOnlineLinks; + FPackageLinks.Clear; + for I := 0 to SerializablePackages.Count - 1 do + begin + MetaPackage := SerializablePackages.Items[I]; + for J := 0 to MetaPackage.LazarusPackages.Count - 1 do begin - MetaPackage := SerializablePackages.Items[I]; - for J := 0 to MetaPackage.LazarusPackages.Count - 1 do + LazPackage := TLazarusPackage(MetaPackage.LazarusPackages.Items[J]); + FileName := Options.LocalRepositoryPackagesExpanded + MetaPackage.PackageBaseDir + LazPackage.PackageRelativePath + LazPackage.Name; + Name := StringReplace(LazPackage.Name, '.lpk', '', [rfReplaceAll, rfIgnoreCase]); + URL := Options.RemoteRepository[Options.ActiveRepositoryIndex] + MetaPackage.RepositoryFileName; + PackageLink := FindOnlineLink(Name); + if PackageLink = nil then begin - LazPackage := TLazarusPackage(MetaPackage.LazarusPackages.Items[J]); - FileName := Options.LocalRepositoryPackagesExpanded + MetaPackage.PackageBaseDir + LazPackage.PackageRelativePath + LazPackage.Name; - Name := StringReplace(LazPackage.Name, '.lpk', '', [rfReplaceAll, rfIgnoreCase]); - URL := Options.RemoteRepository[Options.ActiveRepositoryIndex] + MetaPackage.RepositoryFileName; - PackageLink := FindOnlineLink(Name); - if PackageLink = nil then + PackageLink := PkgLinks.AddOnlineLink(FileName, Name, URL); + if PackageLink <> nil then begin - PackageLink := PkgLinks.AddOnlineLink(FileName, Name, URL); - if PackageLink <> nil then - begin - PackageLink.Version.Assign(LazPackage.Version); - PackageLink.PackageType := LazPackage.PackageType; - PackageLink.OPMFileDate := MetaPackage.RepositoryDate; - PackageLink.Author := LazPackage.Author; - PackageLink.Description := LazPackage.Description; - PackageLink.License := LazPackage.License; - FPackageLinks.Add(PackageLink); - end; + PackageLink.Version.Assign(LazPackage.Version); + PackageLink.PackageType := LazPackage.PackageType; + PackageLink.OPMFileDate := MetaPackage.RepositoryDate; + PackageLink.Author := LazPackage.Author; + PackageLink.Description := LazPackage.Description; + PackageLink.License := LazPackage.License; + FPackageLinks.Add(PackageLink); end; end; end; - finally - FBusyUpdating := False; end; + if (Assigned(OnPackageListAvailable)) then + OnPackageListAvailable(Self); end; procedure TOPMInterfaceEx.AddToDownloadList(const AName: String); @@ -537,4 +544,10 @@ begin end; end; +procedure TOPMInterfaceEx.DoHandleException(Sender: TObject; E: Exception); +begin + // +end; + + end. diff --git a/components/onlinepackagemanager/opkman_mainfrm.lfm b/components/onlinepackagemanager/opkman_mainfrm.lfm index 5574f9e1ac..c9a6270da5 100644 --- a/components/onlinepackagemanager/opkman_mainfrm.lfm +++ b/components/onlinepackagemanager/opkman_mainfrm.lfm @@ -15,6 +15,7 @@ object MainFrm: TMainFrm OnKeyPress = FormKeyPress OnShow = FormShow Position = poScreenCenter + LCLVersion = '2.1.0.0' object pnMain: TPanel Left = 0 Height = 580 @@ -432,6 +433,7 @@ object MainFrm: TMainFrm Caption = 'Create' DropdownMenu = pmCreate ImageIndex = 7 + OnClick = tbCreateClick ParentShowHint = False ShowHint = True Style = tbsDropDown diff --git a/components/onlinepackagemanager/opkman_mainfrm.pas b/components/onlinepackagemanager/opkman_mainfrm.pas index 4d676b2570..2e0920b275 100644 --- a/components/onlinepackagemanager/opkman_mainfrm.pas +++ b/components/onlinepackagemanager/opkman_mainfrm.pas @@ -29,19 +29,19 @@ unit opkman_mainfrm; interface uses - Classes, SysUtils, fpjson, md5, Graphics, VirtualTrees, + Classes, SysUtils, fpjson, Graphics, VirtualTrees, // LCL Forms, Controls, Dialogs, StdCtrls, ExtCtrls, Buttons, Menus, ComCtrls, Clipbrd, LCLIntf, LCLVersion, LCLProc, // LazUtils - LazFileUtils, + LazFileUtils, LazIDEIntf, // IdeIntf IDECommands, PackageIntf, // OpkMan - opkman_downloader, opkman_installer, + opkman_downloader, opkman_installer, opkman_updates, opkman_serializablepackages, opkman_visualtree, opkman_const, opkman_common, opkman_progressfrm, opkman_zipper, opkman_packagelistfrm, opkman_options, - opkman_optionsfrm, opkman_createrepositorypackagefrm, opkman_updates, + opkman_optionsfrm, opkman_createrepositorypackagefrm, opkman_createjsonforupdatesfrm, opkman_createrepositoryfrm; type @@ -127,6 +127,7 @@ type procedure miSaveToFileClick(Sender: TObject); procedure pnToolBarResize(Sender: TObject); procedure tbCleanUpClick(Sender: TObject); + procedure tbCreateClick(Sender: TObject); procedure tbDownloadClick(Sender: TObject); procedure tbHelpClick(Sender: TObject); procedure tbInstallClick(Sender: TObject); @@ -163,15 +164,12 @@ type procedure DoOnJSONProgress(Sender: TObject); procedure DoOnJSONDownloadCompleted(Sender: TObject; AJSON: TJSONStringType; AErrTyp: TErrorType; const AErrMsg: String = ''); procedure DoOnProcessJSON(Sender: TObject); - procedure DoOnUpdate(Sender: TObject); procedure DoDeactivate(Sender: TObject); function IsSomethingChecked(const AResolveDependencies: Boolean = True): Boolean; function Download(const ADstDir: String; var ADoExtract: Boolean): TModalResult; function Extract(const ASrcDir, ADstDir: String; var ADoOpen: Boolean; const AIsUpdate: Boolean = False): TModalResult; function Install(var AInstallStatus: TInstallStatus; var ANeedToRebuild: Boolean): TModalResult; function UpdateP(const ADstDir: String; var ADoExtract: Boolean): TModalResult; - procedure StartUpdates; - procedure StopUpdates; procedure Rebuild; function CheckDstDir(const ADstDir: String): Boolean; public @@ -198,31 +196,6 @@ begin FHintTimeOut := Application.HintHidePause; Application.HintHidePause := 1000000; Application.AddOnDeactivateHandler(@DoDeactivate, False); - {$IF LCL_FULLVERSION >= 1070000} - tbInstall.Style := tbsButtonDrop; - tbCreate.Style := tbsButtonDrop; - {$ENDIF} -end; - -procedure TMainFrm.StartUpdates; -var - FileName: String; -begin - FileName := Format(LocalRepositoryUpdatesFile, [MD5Print(MD5String(Options.RemoteRepository[Options.ActiveRepositoryIndex]))]); - Updates := TUpdates.Create(FileName); - Updates.OnUpdate := @DoOnUpdate; - Updates.StartUpdate; -end; - -procedure TMainFrm.StopUpdates; -begin - if Assigned(Updates) then - begin - Updates.StopUpdate; - Updates.Terminate; - Updates.WaitFor; - Updates := nil; - end; end; procedure TMainFrm.FormDestroy(Sender: TObject); @@ -230,9 +203,9 @@ begin SerializablePackages.OnProcessJSON := nil; PackageDownloader.OnJSONProgress := nil; PackageDownloader.OnJSONDownloadCompleted := nil; - StopUpdates; Application.RemoveOnDeactivateHandler(@DoDeactivate); VisualTree.Free; + VisualTree := nil; Application.HintHidePause := FHintTimeOut; end; @@ -250,9 +223,6 @@ begin SetupColors; GetPackageList; end - else - if not Application.Terminated then - StartUpdates; end; procedure TMainFrm.GetPackageList(const ARepositoryHasChanged: Boolean = False); @@ -268,7 +238,6 @@ begin SetupMessage(rsMainFrm_rsMessageChangingRepository); Sleep(1500); end; - StopUpdates; SetupMessage(rsMainFrm_rsMessageDownload); PackageDownloader.DownloadJSON(Options.ConTimeOut*1000); end; @@ -339,19 +308,14 @@ begin ProgressFrm := TProgressFrm.Create(MainFrm); try PackageUnzipper := TPackageUnzipper.Create; - try - ProgressFrm.SetupControls(1); - PackageUnzipper.OnZipProgress := @ProgressFrm.DoOnZipProgress; - PackageUnzipper.OnZipError := @ProgressFrm.DoOnZipError; - PackageUnzipper.OnZipCompleted := @ProgressFrm.DoOnZipCompleted; - PackageUnzipper.StartUnZip(ASrcDir, ADstDir, AIsUpdate); - Result := ProgressFrm.ShowModal; - if Result = mrOk then - ADoOpen := ProgressFrm.cbExtractOpen.Checked; - finally - if Assigned(PackageUnzipper) then - PackageUnzipper := nil; - end; + ProgressFrm.SetupControls(1); + PackageUnzipper.OnZipProgress := @ProgressFrm.DoOnZipProgress; + PackageUnzipper.OnZipError := @ProgressFrm.DoOnZipError; + PackageUnzipper.OnZipCompleted := @ProgressFrm.DoOnZipCompleted; + PackageUnzipper.StartUnZip(ASrcDir, ADstDir, AIsUpdate); + Result := ProgressFrm.ShowModal; + if Result = mrOk then + ADoOpen := ProgressFrm.cbExtractOpen.Checked; finally ProgressFrm.Free; end; @@ -413,10 +377,12 @@ begin Exit; end; VisualTree.PopulateTree; + if Assigned (Updates) then + Updates.StartUpdate(True); + VisualTree.UpdatePackageUStatus; EnableDisableControls(True); SetupMessage; mJSON.Text := AJSON; - StartUpdates; cbAll.Checked := False; Caption := rsLazarusPackageManager + ' ' + SerializablePackages.QuickStatistics; end; @@ -449,11 +415,6 @@ begin Application.ProcessMessages; end; -procedure TMainFrm.DoOnUpdate(Sender: TObject); -begin - VisualTree.UpdatePackageUStatus; -end; - procedure TMainFrm.DoDeactivate(Sender: TObject); begin if Assigned(VisualTree.ShowHintFrm) then @@ -704,7 +665,6 @@ begin if CanGo then begin - StopUpdates; Options.LastDownloadDir := DstDir; Options.Changed := True; PackageAction := paDownloadTo; @@ -726,7 +686,6 @@ begin end; end; SerializablePackages.RemoveErrorState; - StartUpdates; end; procedure TMainFrm.Rebuild; @@ -768,7 +727,6 @@ begin if MessageDlgEx(rsMainFrm_PackageUpdateWarning, mtConfirmation, [mbYes, mbNo], Self) <> mrYes then Exit; - StopUpdates; PackageAction := paUpdate; VisualTree.UpdatePackageStates; if SerializablePackages.DownloadCount > 0 then @@ -809,10 +767,7 @@ begin end; end; if not NeedToRebuild then - begin SerializablePackages.RemoveErrorState; - StartUpdates; - end; end; procedure TMainFrm.tbUninstallClick(Sender: TObject); @@ -874,7 +829,6 @@ begin end; NeedToRebuild := False; - StopUpdates; for I := 0 to SerializablePackages.Count - 1 do begin for J := 0 to SerializablePackages.Items[I].LazarusPackages.Count - 1 do @@ -899,7 +853,6 @@ begin begin NeedToRebuild := False; MessageDlgEx(Format(rsMainFrm_rsUninstall_Error, [LazarusPackage.Name]), mtError, [mbOk], Self); - StartUpdates; Exit; end else @@ -940,7 +893,6 @@ begin if CanGo then begin - StopUpdates; PackageAction := paInstall; VisualTree.UpdatePackageStates; if SerializablePackages.DownloadCount > 0 then @@ -980,10 +932,7 @@ begin end; end; if not NeedToRebuild then - begin SerializablePackages.RemoveErrorState; - StartUpdates; - end; end; procedure TMainFrm.miFromRepositoryClick(Sender: TObject); @@ -1019,6 +968,17 @@ begin end; end; +procedure TMainFrm.tbCreateClick(Sender: TObject); +begin + CreateRepositoryPackagesFrm := TCreateRepositoryPackagesFrm.Create(MainFrm); + try + CreateRepositoryPackagesFrm.SetType(0); + CreateRepositoryPackagesFrm.ShowModal; + finally + CreateRepositoryPackagesFrm.Free; + end; +end; + procedure TMainFrm.pnToolBarResize(Sender: TObject); var I: Integer; @@ -1038,13 +998,7 @@ end; procedure TMainFrm.miCreateRepositoryPackageClick(Sender: TObject); begin - CreateRepositoryPackagesFrm := TCreateRepositoryPackagesFrm.Create(MainFrm); - try - CreateRepositoryPackagesFrm.SetType(0); - CreateRepositoryPackagesFrm.ShowModal; - finally - CreateRepositoryPackagesFrm.Free; - end; + tbCreateClick(tbCreate); end; procedure TMainFrm.miCreateJSONForUpdatesClick(Sender: TObject); @@ -1266,7 +1220,6 @@ procedure TMainFrm.miJSONShowClick(Sender: TObject); begin if not mJSON.Visible then begin - StopUpdates; EnableDisableControls(False); mJSON.Visible := True; mJSON.BringToFront; @@ -1276,7 +1229,6 @@ begin mJSON.SendToBack; mJSON.Visible := False; EnableDisableControls(True); - StartUpdates; end; end; diff --git a/components/onlinepackagemanager/opkman_progressfrm.lfm b/components/onlinepackagemanager/opkman_progressfrm.lfm index 9ad79f94f1..e383098014 100644 --- a/components/onlinepackagemanager/opkman_progressfrm.lfm +++ b/components/onlinepackagemanager/opkman_progressfrm.lfm @@ -17,7 +17,7 @@ object ProgressFrm: TProgressFrm OnShow = FormShow PopupMode = pmExplicit Position = poOwnerFormCenter - LCLVersion = '1.9.0.0' + LCLVersion = '2.1.0.0' object pnLabels: TPanel Left = 0 Height = 249 diff --git a/components/onlinepackagemanager/opkman_progressfrm.pas b/components/onlinepackagemanager/opkman_progressfrm.pas index f758c4601b..5ee856b4b7 100644 --- a/components/onlinepackagemanager/opkman_progressfrm.pas +++ b/components/onlinepackagemanager/opkman_progressfrm.pas @@ -223,14 +223,17 @@ begin else lbReceived.Caption := rsProgressFrm_lbReceived_Caption0 + ' ' + FormatSize(ACurPos) + ' / ' + rsProgressFrm_Caption5; lbReceived.Update; - pb.Position := Round((ACurPos/ACurSize) * 100); + if ACurSize > 0 then + pb.Position := Round((ACurPos/ACurSize) * 100); pb.Update; lbReceivedTotal.Caption := rsProgressFrm_lbReceivedTotal_Caption0 + ' ' + FormatSize(ATotPos) + ' / ' + FormatSize(ATotSize); lbReceivedTotal.Update; - pbTotal.Position := Round((ATotPos/ATotSize) * 100); + if ATotSize > 0 then + pbTotal.Position := Round((ATotPos/ATotSize) * 100); pbTotal.Update; FCnt := ACnt; FTotCnt := ATotCnt; + Application.ProcessMessages; end; procedure TProgressFrm.DoOnPackageDownloadError(Sender: TObject; APackageName: String; @@ -286,14 +289,17 @@ begin lbRemainingData.Update; lbReceived.Caption := rsProgressFrm_lbReceived_Caption1 + ' ' + FormatSize(ACurPos) + ' / ' + FormatSize(ACurSize); lbReceived.Update; - pb.Position := Round((ACurPos/ACurSize) * 100); + if ACurSize > 0 then + pb.Position := Round((ACurPos/ACurSize) * 100); pb.Update; lbReceivedTotal.Caption := rsProgressFrm_lbReceivedTotal_Caption1 + ' ' + FormatSize(ATotPos) + ' / ' + FormatSize(ATotSize); lbReceivedTotal.Update; - pbTotal.Position := Round((ATotPos/ATotSize) * 100); + if ATotSize > 0 then + pbTotal.Position := Round((ATotPos/ATotSize) * 100); pbTotal.Update; FCnt := ACnt; FTotCnt := ATotCnt; + Application.ProcessMessages; end; procedure TProgressFrm.DoOnZipError(Sender: TObject; APackageName: String; const AErrMsg: String); @@ -464,6 +470,7 @@ begin end; Data^.FImageIndex := AUTyp; FVST.TopNode := Node; + Application.ProcessMessages; end; procedure TProgressFrm.DoOnPackageUpdateCompleted(Sender: TObject; diff --git a/components/onlinepackagemanager/opkman_timer.pas b/components/onlinepackagemanager/opkman_timer.pas deleted file mode 100644 index 8670f64d2a..0000000000 --- a/components/onlinepackagemanager/opkman_timer.pas +++ /dev/null @@ -1,105 +0,0 @@ -{ -*************************************************************************** -* * -* This source is free software; you can redistribute it and/or modify * -* it under the terms of the GNU General Public License as published by * -* the Free Software Foundation; either version 2 of the License, or * -* (at your option) any later version. * -* * -* This code is distributed in the hope that it will be useful, but * -* WITHOUT ANY WARRANTY; without even the implied warranty of * -* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * -* General Public License for more details. * -* * -* A copy of the GNU General Public License is available on the World * -* Wide Web at . You can also * -* obtain it by writing to the Free Software Foundation, * -* Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. * -* * -*************************************************************************** - -Author: Balázs Székely -} -unit opkman_timer; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils; - -type - { TThreadTimer } - TThreadTimer = class(TThread) - private - FTime: QWORD; - FInterval: Cardinal; - FOnTimer: TNotifyEvent; - FEnabled: Boolean; - procedure DoOnTimer; - protected - procedure Execute; override; - public - constructor Create; - destructor Destroy; override; - public - property OnTimer: TNotifyEvent read FOnTimer write FOnTimer; - property Interval: Cardinal read FInterval write FInterval; - property Enabled: Boolean read FEnabled write FEnabled; - procedure StopTimer; - procedure StartTimer; - end; - -implementation - -{ TThreadTimer } - -constructor TThreadTimer.Create; -begin - inherited Create(True); - FreeOnTerminate := True; - FInterval := 10000; - FEnabled := False; -end; - -destructor TThreadTimer.Destroy; -begin - // - inherited Destroy; -end; - -procedure TThreadTimer.DoOnTimer; -begin - if Assigned(FOnTimer) then - FOnTimer(Self); -end; - -procedure TThreadTimer.Execute; -begin - while not Terminated do - begin - Sleep(1000); - if (GetTickCount64 - FTime > FInterval) and FEnabled and not Terminated then - begin - FTime := GetTickCount64; - DoOnTimer; - end; - end; -end; - -procedure TThreadTimer.StopTimer; -begin - FEnabled := False; -end; - -procedure TThreadTimer.StartTimer; -begin - FTime := GetTickCount64; - FEnabled := True; - if Self.Suspended then - Start; -end; - -end. - diff --git a/components/onlinepackagemanager/opkman_updates.pas b/components/onlinepackagemanager/opkman_updates.pas index c7ab4f9d66..da5366fb9e 100644 --- a/components/onlinepackagemanager/opkman_updates.pas +++ b/components/onlinepackagemanager/opkman_updates.pas @@ -30,11 +30,11 @@ unit opkman_updates; interface uses - Classes, SysUtils, fpjson, fpjsonrtti, dateutils, + Classes, SysUtils, fpjson, fpjsonrtti, jsonparser, dateutils, // LazUtils Laz2_XMLCfg, LazIDEIntf, // OpkMan - opkman_serializablepackages, opkman_options, opkman_common, + opkman_serializablepackages, opkman_options, opkman_common, opkman_visualtree, {$IFDEF MSWINDOWS} opkman_const, {$IFDEF FPC311}zipper,{$ELSE}opkman_zip,{$ENDIF} @@ -108,12 +108,11 @@ type FBusyUpdating: Boolean; FBusySaving: Boolean; FOpenSSLAvailable: Boolean; - FOnUpdate: TNotifyEvent; FTime: QWORD; FInterval: Cardinal; FFileName: String; + FStarted: Boolean; function GetUpdateInfo(const AURL: String; var AJSON: TJSONStringType): Boolean; - procedure DoOnUpdate; procedure Load; procedure Save; procedure AssignPackageData(AMetaPackage: TMetaPackage); @@ -126,10 +125,8 @@ type public constructor Create(const AFileName: String); destructor Destroy; override; - procedure StartUpdate; + procedure StartUpdate(const AOnlyInit: Boolean = False); procedure StopUpdate; - published - property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate; end; var @@ -166,6 +163,20 @@ begin inherited Destroy; end; +function IsValidJSON(const AJSON: TJSONStringType): Boolean; +var + {%H-}JSONData: TJSONData; +begin + Result := True; + try + JSONData := GetJSON(AJSON); + JSONData.Free; + except + on E: EJSONParser do + Result := False; + end; +end; + function TUpdatePackage.LoadFromJSON(const AJSON: TJSONStringType): Boolean; var DeStreamer: TJSONDeStreamer; @@ -174,8 +185,11 @@ begin try Clear; try - DeStreamer.JSONToObject(AJSON, Self); - Result := True; + if IsValidJSON(AJSON) then + begin + DeStreamer.JSONToObject(AJSON, Self); + Result := True; + end; except on E: Exception do begin @@ -256,6 +270,7 @@ destructor TUpdates.Destroy; begin FHTTPClient.Free; FUpdatePackage.Free; + Updates := nil; inherited Destroy; end; @@ -312,8 +327,6 @@ begin finally FXML.Free; end; - if Assigned(FOnUpdate) and (not FNeedToBreak) then - Synchronize(@DoOnUpdate); end; procedure TUpdates.Save; @@ -505,12 +518,6 @@ begin end; end; -procedure TUpdates.DoOnUpdate; -begin - if Assigned(FOnUpdate) then - FOnUpdate(Self); -end; - procedure TUpdates.CheckForUpdates; var I: Integer; @@ -537,8 +544,6 @@ begin else ResetPackageData(SerializablePackages.Items[I]); end; - if Assigned(FOnUpdate) and (not FNeedToBreak) then - Synchronize(@DoOnUpdate); finally FBusyUpdating := False; end; @@ -548,21 +553,28 @@ procedure TUpdates.Execute; begin while not Terminated do begin - Sleep(1); - if (GetTickCount64 - FTime > FInterval) then - begin - FTime := GetTickCount64; - if IsTimeToUpdate then - CheckForUpdates; - end; if FNeedToBreak then Break; + Sleep(50); + if (GetTickCount64 - FTime > FInterval)then + begin + FTime := GetTickCount64; + if (IsTimeToUpdate) then + begin + CheckForUpdates; + if (not FNeedToBreak) and Assigned(VisualTree) then + Synchronize(@VisualTree.UpdatePackageUStatus) + end; + end; end; end; -procedure TUpdates.StartUpdate; +procedure TUpdates.StartUpdate(const AOnlyInit: Boolean = False); begin Load; + if AOnlyInit then + Exit; + FStarted := True; CheckForOpenSSL; FTime := GetTickCount64; FInterval := 6000; @@ -571,6 +583,7 @@ end; procedure TUpdates.StopUpdate; begin + FStarted := False; Save; FHTTPClient.Terminate; FNeedToBreak := True; diff --git a/components/onlinepackagemanager/opkman_zipper.pas b/components/onlinepackagemanager/opkman_zipper.pas index 8078813911..0aa61ce1fc 100644 --- a/components/onlinepackagemanager/opkman_zipper.pas +++ b/components/onlinepackagemanager/opkman_zipper.pas @@ -35,7 +35,7 @@ uses // LazUtils FileUtil, LazFileUtils, // OpkMan - opkman_timer, opkman_serializablepackages, opkman_common, + opkman_serializablepackages, opkman_common, {$IFDEF FPC311}zipper{$ELSE}opkman_zip{$ENDIF}; type @@ -61,17 +61,16 @@ type FTotPos: Int64; FTotPosTmp: Int64; FTotSize: Int64; - FElapsed: Integer; + FElapsed: QWord; + FStartTime: QWord; FRemaining: Integer; FSpeed: Integer; FErrMsg: String; FIsUpdate: Boolean; - FTimer: TThreadTimer; FUnZipper: TUnZipper; FOnZipProgress: TOnZipProgress; FOnZipError: TOnZipError; FOnZipCompleted: TOnZipCompleted; - procedure DoOnTimer(Sender: TObject); procedure DoOnProgressEx(Sender : TObject; const ATotPos, {%H-}ATotSize: Int64); procedure DoOnZipProgress; procedure DoOnZipError; @@ -146,7 +145,9 @@ var I: Integer; DelDir: String; begin + Sleep(50); FCnt := 0; + FStartTime := GetTickCount64; for I := 0 to SerializablePackages.Count - 1 do begin if SerializablePackages.Items[I].IsExtractable then @@ -191,7 +192,10 @@ begin end; end; if (FNeedToBreak) then - DeleteDirectory(DelDir, False) + begin + if DirectoryExists(DelDir) then + DeleteDirectory(DelDir, False) + end else begin SerializablePackages.MarkRuntimePackages; @@ -204,30 +208,27 @@ begin inherited Create(True); FreeOnTerminate := True; FUnZipper := TUnZipper.Create; - FTimer := nil; end; destructor TPackageUnzipper.Destroy; begin - if FTimer.Enabled then - FTimer.StopTimer; - FTimer.Terminate; FUnZipper.Free; inherited Destroy; end; -procedure TPackageUnzipper.DoOnTimer(Sender: TObject); -begin - Inc(FElapsed); - FSpeed := Round(FTotPosTmp/FElapsed); - FRemaining := Round((FTotSize - FTotPosTmp)/FSpeed); -end; - procedure TPackageUnzipper.DoOnProgressEx(Sender : TObject; const ATotPos, ATotSize: Int64); begin + FElapsed := GetTickCount64 - FStartTime; + if FElapsed < 1000 then + Exit; + FElapsed := FElapsed div 1000; + FCurPos := ATotPos; FCurSize := ATotSize; FTotPosTmp := FTotPos + FCurPos; + FSpeed := Round(FTotPosTmp/FElapsed); + if FSpeed > 0 then + FRemaining := Round((FTotSize - FTotPosTmp)/FSpeed); Synchronize(@DoOnZipProgress); Sleep(5); end; @@ -309,9 +310,6 @@ begin end; end; FStarted := True; - FTimer := TThreadTimer.Create; - FTimer.OnTimer := @DoOnTimer; - FTimer.StartTimer; Start; end; @@ -319,8 +317,6 @@ procedure TPackageUnzipper.StopUnZip; begin if Assigned(FUnZipper) then FUnZipper.Terminate; - if Assigned(FTimer) then - FTimer.StopTimer; FNeedToBreak := True; FStarted := False; end;