paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-06 12:40:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

Opkman: In order to prevent memory leaks, the update of serializable packages are protected with critical sections.

Browse Source 
git-svn-id: trunk@59719 -
This commit is contained in:
balazs 2018-12-03 13:54:14 +00:00
parent c48f6d7a4b
commit 0c07ac1983
5 changed files with 201 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
components/onlinepackagemanager/opkman_common.pas
View File

@ -116,6 +116,7 @@ var
LocalRepositoryUpdatesFile: String;
PackageAction: TPackageAction;
InstallPackageList: TObjectList;
CriticalSection: TRTLCriticalSection;
function MessageDlgEx(const AMsg: String; ADlgType: TMsgDlgType; AButtons:
TMsgDlgButtons; AParent: TForm): TModalResult;

18
components/onlinepackagemanager/opkman_intf.pas
View File

@ -80,6 +80,7 @@ uses opkman_common, opkman_options, opkman_const, opkman_progressfrm, opkman_zip
constructor TOPMInterfaceEx.Create;
begin
InitCriticalSection(CriticalSection);
Application.AddOnExceptionHandler(@DoHandleException);
FPackageLinks := TObjectList.Create(False);
FPackagesToDownload := TObjectList.Create(False);
@ -107,23 +108,25 @@ begin
SerializablePackages.Free;
Options.Free;
InstallPackageList.Free;
DoneCriticalsection(CriticalSection);
inherited Destroy;
end;
procedure TOPMInterfaceEx.DoOnIDEClose(Sender: TObject);
begin
if Assigned(PackageDownloader) then
if PackageDownloader.DownloadingJSON then
PackageDownloader.Cancel;
if Assigned(Updates) then
begin
Updates.StopUpdate;
Updates.Terminate;
Sleep(100);
Updates.WaitFor;
end;
end;
procedure TOPMInterfaceEx.DoOnTimer(Sender: TObject);
var
FileName: String;
begin
if Assigned(LazarusIDE) and Assigned(PackageEditingInterface) and (not LazarusIDE.IDEIsClosing) then
begin
@ -141,11 +144,12 @@ begin
if (not LazarusIDE.IDEIsClosing) then
begin
if Options.CheckForUpdates <> 5 then
begin
PackageDownloader.DownloadJSON(Options.ConTimeOut*1000, True);
LazarusIDE.AddHandlerOnIDEClose(@DoOnIDEClose);
FileName := Format(LocalRepositoryUpdatesFile, [MD5Print(MD5String(Options.RemoteRepository[Options.ActiveRepositoryIndex]))]);
Updates := TUpdates.Create(FileName);
Updates.StartUpdate;
LazarusIDE.AddHandlerOnIDEClose(@DoOnIDEClose);
Updates := TUpdates.Create;
Updates.StartUpdate;
end;
end;
end;
end;

4
components/onlinepackagemanager/opkman_mainfrm.pas
View File

@ -38,7 +38,7 @@ uses
// IdeIntf
IDECommands, PackageIntf,
// OpkMan
opkman_downloader, opkman_installer, opkman_updates,
opkman_downloader, opkman_installer,
opkman_serializablepackages, opkman_visualtree, opkman_const, opkman_common,
opkman_progressfrm, opkman_zipper, opkman_packagelistfrm, opkman_options,
opkman_optionsfrm, opkman_createrepositorypackagefrm, opkman_maindm,
@ -389,8 +389,6 @@ begin
Exit;
end;
VisualTree.PopulateTree;
if Assigned (Updates) then
Updates.StartUpdate(True);
VisualTree.UpdatePackageUStatus;
EnableDisableControls(True);
SetupMessage;

102
components/onlinepackagemanager/opkman_serializablepackages.pas
View File

@ -31,7 +31,7 @@ unit opkman_serializablepackages;
interface
uses
Classes, SysUtils, Variants, contnrs, dateutils, fpjson, jsonparser,
Classes, SysUtils, Variants, contnrs, dateutils, fpjson, jsonparser, md5,
// LazUtils
FileUtil, Laz2_XMLCfg, LazFileUtils,
// IdeIntf
@ -237,6 +237,7 @@ type
FLastError: String;
FOnProcessJSON: TNotifyEvent;
FOnUpdatePackageLinks: TNotifyEvent;
FUpdates: String;
function GetCount: Integer;
function GetDownloadCount: Integer;
function GetExtractCount: Integer;
@ -255,6 +256,8 @@ type
function GetPackageVersion(const APath: String): String;
function GetPackageDescription(const APath: String): String;
function GetPackageLicense(const APath: String): String;
procedure LoadUpdateInfo;
procedure SaveUpdateInfo;
public
constructor Create;
destructor Destroy; override;
@ -590,10 +593,13 @@ end;
constructor TSerializablePackages.Create;
begin
FMetaPackages := TCollection.Create(TMetaPackage);
FUpdates := Format(LocalRepositoryUpdatesFile, [MD5Print(MD5String(Options.RemoteRepository[Options.ActiveRepositoryIndex]))]);
end;
destructor TSerializablePackages.Destroy;
begin
if Count > 0 then
SaveUpdateInfo;
Clear;
FMetaPackages.Free;
inherited Destroy;
@ -968,8 +974,11 @@ begin
Parser.Free;
end;
if Result then
begin
LoadUpdateInfo;
if Assigned(FOnUpdatePackageLinks) then
FOnUpdatePackageLinks(Self);
end;
end;
function TSerializablePackages.LazarusPackagesToJSON(AMetaPackage: TMetaPackage;
@ -1115,6 +1124,97 @@ begin
end;
end;
procedure TSerializablePackages.LoadUpdateInfo;
var
PackageCount: Integer;
LazarusPkgCount: Integer;
I, J: Integer;
Path, SubPath: String;
PackageName: String;
LazarusPkgName: String;
MetaPkg: TMetaPackage;
LazarusPkg: TLazarusPackage;
HasUpdate: Boolean;
FXML: TXMLConfig;
begin
if not FileExists(FUpdates) then
Exit;
FXML := TXMLConfig.Create(FUpdates);
try
PackageCount := FXML.GetValue('Count/Value', 0);
for I := 0 to PackageCount - 1 do
begin
Path := 'Package' + IntToStr(I) + '/';
PackageName := FXML.GetValue(Path + 'Name', '');
MetaPkg := FindMetaPackage(PackageName, fpbPackageName);
if MetaPkg <> nil then
begin
HasUpdate := False;
MetaPkg.DownloadZipURL := FXML.GetValue(Path + 'DownloadZipURL', '');
MetaPkg.DisableInOPM := FXML.GetValue(Path + 'DisableInOPM', False);
MetaPkg.Rating := FXML.GetValue(Path + 'Rating', 0);
LazarusPkgCount := FXML.GetValue(Path + 'Count', 0);
for J := 0 to LazarusPkgCount - 1 do
begin
SubPath := Path + 'PackageFile' + IntToStr(J) + '/';
LazarusPkgName := FXML.GetValue(SubPath + 'Name', '');
LazarusPkg := MetaPkg.FindLazarusPackage(LazarusPkgName);
if LazarusPkg <> nil then
begin
LazarusPkg.UpdateVersion := FXML.GetValue(SubPath + 'UpdateVersion', '');
LazarusPkg.ForceNotify := FXML.GetValue(SubPath + 'ForceNotify', False);
LazarusPkg.InternalVersion := FXML.GetValue(SubPath + 'InternalVersion', 0);;
LazarusPkg.InternalVersionOld := FXML.GetValue(SubPath + 'InternalVersionOld', 0);
LazarusPkg.RefreshHasUpdate;
if not HasUpdate then
HasUpdate := (LazarusPkg.HasUpdate) and (LazarusPkg.InstalledFileVersion < LazarusPkg.UpdateVersion);
end;
end;
MetaPkg.HasUpdate := HasUpdate;
end;
end;
finally
FXML.Free;
end;
end;
procedure TSerializablePackages.SaveUpdateInfo;
var
I, J: Integer;
Path, SubPath: String;
MetaPkg: TMetaPackage;
LazarusPkg: TLazarusPackage;
FXML: TXMLConfig;
begin
FXML := TXMLConfig.CreateClean(FUpdates);
try
FXML.SetDeleteValue('Version/Value', OpkVersion, 0);
FXML.SetDeleteValue('Count/Value', Count, 0);
for I := 0 to Count - 1 do
begin
MetaPkg := Items[I];
Path := 'Package' + IntToStr(I) + '/';
FXML.SetDeleteValue(Path + 'Name', MetaPkg.Name, '');
FXML.SetDeleteValue(Path + 'DownloadZipURL', MetaPkg.DownloadZipURL, '');
FXML.SetDeleteValue(Path + 'DisableInOPM', MetaPkg.DisableInOPM, False);
FXML.SetDeleteValue(Path + 'Rating', MetaPkg.Rating, 0);
FXML.SetDeleteValue(Path + 'Count', Items[I].LazarusPackages.Count, 0);
for J := 0 to Items[I].LazarusPackages.Count - 1 do
begin
SubPath := Path + 'PackageFile' + IntToStr(J) + '/';
LazarusPkg := TLazarusPackage(Items[I].LazarusPackages.Items[J]);
FXML.SetDeleteValue(SubPath + 'Name', LazarusPkg.Name, '');
FXML.SetDeleteValue(SubPath + 'UpdateVersion', LazarusPkg.UpdateVersion, '');
FXML.SetDeleteValue(SubPath + 'ForceNotify', LazarusPkg.ForceNotify, False);
FXML.SetDeleteValue(SubPath + 'InternalVersion', LazarusPkg.InternalVersion, 0);
FXML.SetDeleteValue(SubPath + 'InternalVersionOld', LazarusPkg.InternalVersionOld, 0);
end;
end;
FXML.Flush;
finally
FXML.Free;
end;
end;
function TSerializablePackages.IsPackageInstalled(const ALazarusPkg: TLazarusPackage;
const APackageBaseDir: String): Boolean;

214
components/onlinepackagemanager/opkman_updates.pas
View File

@ -32,7 +32,7 @@ interface
uses
Classes, SysUtils, fpjson, fpjsonrtti, jsonparser, dateutils,
// LazUtils
Laz2_XMLCfg, LazIDEIntf,
LazIDEIntf,
// OpkMan
opkman_serializablepackages, opkman_options, opkman_common, opkman_visualtree,
{$IFDEF MSWINDOWS}
@ -101,31 +101,29 @@ type
{ TUpdates }
TUpdates = class(TThread)
private
FSP_Temp: TSerializablePackages;
FHTTPClient: TFPHTTPClient;
FUpdatePackage: TUpdatePackage;
FVersion: Integer;
FNeedToBreak: Boolean;
FBusyUpdating: Boolean;
FBusySaving: Boolean;
FOpenSSLAvailable: Boolean;
FTime: QWORD;
FInterval: Cardinal;
FFileName: String;
FStarted: Boolean;
function GetUpdateInfo(const AURL: String; var AJSON: TJSONStringType): Boolean;
procedure Load;
procedure Save;
procedure AssignPackageData(AMetaPackage: TMetaPackage);
procedure ResetPackageData(AMetaPackage: TMetaPackage);
procedure CheckForOpenSSL;
procedure CheckForUpdates;
procedure GetSerializablePackages;
procedure SetSerializablePackages;
function IsTimeToUpdate: Boolean;
protected
procedure Execute; override;
public
constructor Create(const AFileName: String);
constructor Create;
destructor Destroy; override;
procedure StartUpdate(const AOnlyInit: Boolean = False);
procedure StartUpdate;
procedure StopUpdate;
end;
@ -247,11 +245,11 @@ end;
{ TUpdates }
constructor TUpdates.Create(const AFileName: String);
constructor TUpdates.Create;
begin
inherited Create(True);
FSP_Temp := TSerializablePackages.Create;
FreeOnTerminate := True;
FFileName := AFileName;
FHTTPClient := TFPHTTPClient.Create(nil);
{$IFDEF FPC311}
FHTTPClient.IOTimeout := Options.ConTimeOut*1000;
@ -270,107 +268,12 @@ destructor TUpdates.Destroy;
begin
FHTTPClient.Free;
FUpdatePackage.Free;
FSP_Temp.Clear;
FSP_Temp.Free;
Updates := nil;
inherited Destroy;
end;
procedure TUpdates.Load;
var
PackageCount: Integer;
LazarusPkgCount: Integer;
I, J: Integer;
Path, SubPath: String;
PackageName: String;
LazarusPkgName: String;
MetaPkg: TMetaPackage;
LazarusPkg: TLazarusPackage;
HasUpdate: Boolean;
FXML: TXMLConfig;
begin
if (not Assigned(SerializablePackages)) or (SerializablePackages.Count = 0) then
Exit;
FXML := TXMLConfig.Create(FFileName);
try
FVersion := FXML.GetValue('Version/Value', 0);
PackageCount := FXML.GetValue('Count/Value', 0);
for I := 0 to PackageCount - 1 do
begin
Path := 'Package' + IntToStr(I) + '/';
PackageName := FXML.GetValue(Path + 'Name', '');
MetaPkg := SerializablePackages.FindMetaPackage(PackageName, fpbPackageName);
if MetaPkg <> nil then
begin
HasUpdate := False;
MetaPkg.DownloadZipURL := FXML.GetValue(Path + 'DownloadZipURL', '');
MetaPkg.DisableInOPM := FXML.GetValue(Path + 'DisableInOPM', False);
MetaPkg.Rating := FXML.GetValue(Path + 'Rating', 0);
LazarusPkgCount := FXML.GetValue(Path + 'Count', 0);
for J := 0 to LazarusPkgCount - 1 do
begin
SubPath := Path + 'PackageFile' + IntToStr(J) + '/';
LazarusPkgName := FXML.GetValue(SubPath + 'Name', '');
LazarusPkg := MetaPkg.FindLazarusPackage(LazarusPkgName);
if LazarusPkg <> nil then
begin
LazarusPkg.UpdateVersion := FXML.GetValue(SubPath + 'UpdateVersion', '');
LazarusPkg.ForceNotify := FXML.GetValue(SubPath + 'ForceNotify', False);
LazarusPkg.InternalVersion := FXML.GetValue(SubPath + 'InternalVersion', 0);;
LazarusPkg.InternalVersionOld := FXML.GetValue(SubPath + 'InternalVersionOld', 0);
LazarusPkg.RefreshHasUpdate;
if not HasUpdate then
HasUpdate := (LazarusPkg.HasUpdate) and (LazarusPkg.InstalledFileVersion < LazarusPkg.UpdateVersion);
end;
end;
MetaPkg.HasUpdate := HasUpdate;
end;
end;
finally
FXML.Free;
end;
end;
procedure TUpdates.Save;
var
I, J: Integer;
Path, SubPath: String;
MetaPkg: TMetaPackage;
LazarusPkg: TLazarusPackage;
FXML: TXMLConfig;
begin
if (not Assigned(SerializablePackages)) or (SerializablePackages.Count = 0) or (FBusySaving) then
Exit;
FBusySaving := True;
FXML := TXMLConfig.CreateClean(FFileName);
try
FXML.SetDeleteValue('Version/Value', OpkVersion, 0);
FXML.SetDeleteValue('Count/Value', SerializablePackages.Count, 0);
for I := 0 to SerializablePackages.Count - 1 do
begin
MetaPkg := SerializablePackages.Items[I];
Path := 'Package' + IntToStr(I) + '/';
FXML.SetDeleteValue(Path + 'Name', MetaPkg.Name, '');
FXML.SetDeleteValue(Path + 'DownloadZipURL', MetaPkg.DownloadZipURL, '');
FXML.SetDeleteValue(Path + 'DisableInOPM', MetaPkg.DisableInOPM, False);
FXML.SetDeleteValue(Path + 'Rating', MetaPkg.Rating, 0);
FXML.SetDeleteValue(Path + 'Count', SerializablePackages.Items[I].LazarusPackages.Count, 0);
for J := 0 to SerializablePackages.Items[I].LazarusPackages.Count - 1 do
begin
SubPath := Path + 'PackageFile' + IntToStr(J) + '/';
LazarusPkg := TLazarusPackage(SerializablePackages.Items[I].LazarusPackages.Items[J]);
FXML.SetDeleteValue(SubPath + 'Name', LazarusPkg.Name, '');
FXML.SetDeleteValue(SubPath + 'UpdateVersion', LazarusPkg.UpdateVersion, '');
FXML.SetDeleteValue(SubPath + 'ForceNotify', LazarusPkg.ForceNotify, False);
FXML.SetDeleteValue(SubPath + 'InternalVersion', LazarusPkg.InternalVersion, 0);
FXML.SetDeleteValue(SubPath + 'InternalVersionOld', LazarusPkg.InternalVersionOld, 0);
end;
end;
FXML.Flush;
finally
FXML.Free;
FBusySaving := False;
end;
end;
procedure TUpdates.AssignPackageData(AMetaPackage: TMetaPackage);
var
I: Integer;
@ -378,8 +281,6 @@ var
LazarusPkg: TLazarusPackage;
UpdLazPkgs: TUpdateLazPackages;
begin
if FBusySaving then
Exit;
HasUpdate := False;
AMetaPackage.DownloadZipURL := FUpdatePackage.FUpdatePackageData.DownloadZipURL;
AMetaPackage.DisableInOPM := FUpdatePackage.FUpdatePackageData.DisableInOPM;
@ -405,8 +306,6 @@ var
I: Integer;
LazarusPkg: TLazarusPackage;
begin
if FBusySaving then
Exit;
AMetaPackage.DownloadZipURL := '';
AMetaPackage.DisableInOPM := False;
AMetaPackage.HasUpdate := False;
@ -467,10 +366,9 @@ end;
function TUpdates.IsTimeToUpdate: Boolean;
begin
Result := Assigned(SerializablePackages) and (FOpenSSLAvailable) and
(not FBusyUpdating) and (not FNeedToBreak);
Result := (FOpenSSLAvailable) and (not FBusyUpdating) and (not FNeedToBreak);
case Options.CheckForUpdates of
0: Result := MinutesBetween(Now, Options.LastUpdate) >= 15;
0: Result := MinutesBetween(Now, Options.LastUpdate) >= 5;
1: Result := HoursBetween(Now, Options.LastUpdate) >= 1;
2: Result := DaysBetween(Now, Options.LastUpdate) >= 1;
3: Result := WeeksBetween(Now, Options.LastUpdate) >= 1;
@ -523,32 +421,96 @@ var
I: Integer;
JSON: TJSONStringType;
begin
if FSP_Temp.Count = 0 then
Exit;
FBusyUpdating := True;
try
Options.LastUpdate := Now;
Options.Changed := True;
for I := 0 to SerializablePackages.Count - 1 do
for I := 0 to FSP_Temp.Count - 1 do
begin
if FNeedToBreak then
Break;
JSON := '';
if (Assigned(LazarusIDE) and LazarusIDE.IDEIsClosing) then
Break;
if GetUpdateInfo(Trim(SerializablePackages.Items[I].DownloadURL), JSON) then
if GetUpdateInfo(Trim(FSP_Temp.Items[I].DownloadURL), JSON) then
begin
if FUpdatePackage.LoadFromJSON(JSON) then
AssignPackageData(SerializablePackages.Items[I])
AssignPackageData(FSP_Temp.Items[I])
else
ResetPackageData(SerializablePackages.Items[I]);
ResetPackageData(FSP_Temp.Items[I]);
end
else
ResetPackageData(SerializablePackages.Items[I]);
ResetPackageData(FSP_Temp.Items[I]);
end;
finally
FBusyUpdating := False;
end;
end;
procedure TUpdates.GetSerializablePackages;
var
JSON: TJSONStringType;
begin
if (FNeedToBreak) or (SerializablePackages.Count = 0) then
Exit;
EnterCriticalSection(CriticalSection);
try
FSP_Temp.Clear;
try
JSON := '';
SerializablePackages.PackagesToJSON(JSON);
FSP_Temp.JSONToPackages(JSON);
except
end;
finally
LeaveCriticalSection(CriticalSection);
end;
end;
procedure TUpdates.SetSerializablePackages;
var
I, J: Integer;
MetaPackage: TMetaPackage;
HasUpdate: Boolean;
LazarusPackage: TLazarusPackage;
begin
if (FNeedToBreak) or (SerializablePackages.Count = 0) or (FSP_Temp.Count = 0) then
Exit;
EnterCriticalSection(CriticalSection);
try
for I := 0 to FSP_Temp.Count - 1 do
begin
MetaPackage := SerializablePackages.FindMetaPackage(FSP_Temp.Items[I].Name, fpbPackageName);
if MetaPackage <> nil then
begin
MetaPackage.DownloadZipURL := FSP_Temp.Items[I].DownloadZipURL;
MetaPackage.DisableInOPM := FSP_Temp.Items[I].DisableInOPM;
HasUpdate := False;
for J := 0 to FSP_Temp.Items[I].LazarusPackages.Count - 1 do
begin
LazarusPackage := MetaPackage.FindLazarusPackage(TLazarusPackage(FSP_Temp.Items[I].LazarusPackages.Items[J]).Name);
if LazarusPackage <> nil then
begin
LazarusPackage.UpdateVersion := TLazarusPackage(FSP_Temp.Items[I].LazarusPackages.Items[J]).UpdateVersion;
LazarusPackage.ForceNotify := TLazarusPackage(FSP_Temp.Items[I].LazarusPackages.Items[J]).ForceNotify;
LazarusPackage.InternalVersion := TLazarusPackage(FSP_Temp.Items[I].LazarusPackages.Items[J]).InternalVersion;
LazarusPackage.RefreshHasUpdate;
if not HasUpdate then
HasUpdate := (LazarusPackage.HasUpdate) and (LazarusPackage.InstalledFileVersion < LazarusPackage.UpdateVersion);
end;
end;
MetaPackage.HasUpdate := HasUpdate;
end;
end;
finally
LeaveCriticalSection(CriticalSection);
end;
end;
procedure TUpdates.Execute;
begin
while not Terminated do
@ -561,19 +523,18 @@ begin
FTime := GetTickCount64;
if (IsTimeToUpdate) then
begin
CheckForUpdates;
if (not FNeedToBreak) and Assigned(VisualTree) then
Synchronize(@VisualTree.UpdatePackageUStatus)
GetSerializablePackages;
CheckForUpdates;
SetSerializablePackages;
if (not FNeedToBreak) and Assigned(VisualTree) then
Synchronize(@VisualTree.UpdatePackageUStatus);
end;
end;
end;
end;
procedure TUpdates.StartUpdate(const AOnlyInit: Boolean = False);
procedure TUpdates.StartUpdate;
begin
Load;
if AOnlyInit then
Exit;
FStarted := True;
CheckForOpenSSL;
FTime := GetTickCount64;
@ -584,7 +545,6 @@ end;
procedure TUpdates.StopUpdate;
begin
FStarted := False;
Save;
FHTTPClient.Terminate;
FNeedToBreak := True;
end;