opensource/HeidiSQL
1
0
Fork 0
mirror of https://github.com/HeidiSQL/HeidiSQL.git synced 2025-08-06 18:24:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

Issue #1482: replace TJsonRegistry with Lazarus' TRegistry implementation, which reads and write an XML config on Linux

Browse Source
This commit is contained in:
Ansgar Becker
2025-03-30 20:24:43 +02:00
parent b266d1475e
commit 517425de94
3 changed files with 20 additions and 310 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
heidisql.lpr
View File

@ -19,7 +19,7 @@ uses
dbstructures.sqlite, change_password, loginform, data_sorting, extra_controls,
column_selection, loaddata, csv_detector, createdatabase, editvar, copytable,
exportgrid, usermanager, selectdbobject, reformatter, searchreplace,
connections, jsonregistry, sqlhelp, updatecheck, insertfiles, texteditor,
connections, sqlhelp, updatecheck, insertfiles, texteditor,
customize_highlighter, preferences;
{$R *.res}

34
source/apphelpers.pas
View File

@ -8,7 +8,7 @@ uses
Classes, SysUtils, Generics.Collections, Generics.Defaults, Controls, RegExpr, Math, FileUtil,
StrUtils, Graphics, GraphUtil, LCLIntf, Forms, Clipbrd, Process, ActnList, Menus, Dialogs,
Character, DateUtils, laz.VirtualTrees, SynEdit, SynEditHighlighter, EditBtn, ComCtrls, SynCompletion, fphttpclient,
dbconnection, dbstructures, jsonregistry;
dbconnection, dbstructures, Registry;
type
@ -272,7 +272,7 @@ type
FBasePath: String;
FSessionPath: String;
FStoredPath: String;
FRegistry: TJsonRegistry;
FRegistry: TRegistry;
FPortableMode: Boolean;
FPortableModeReadOnly: Boolean;
FRestoreTabsInitValue: Boolean;
@ -291,7 +291,7 @@ type
procedure Write(Index: TAppSettingIndex; FormatName: String;
DataType: TAppSettingDataType; I: Integer; B: Boolean; S: String);
public
const PathDelimiter: Char = '/';
const PathDelimiter = '\';
constructor Create;
destructor Destroy; override;
function ReadInt(Index: TAppSettingIndex; FormatName: String=''; Default: Integer=0): Integer;
@ -3525,7 +3525,8 @@ var
begin
inherited;
FDirnameUserAppData := '';
FRegistry := TJsonRegistry.Create(DirnameUserAppData + 'settings.json');
FRegistry := TRegistry.Create;
FRegistry.RootKey := HKEY_CURRENT_USER;
FReads := 0;
FWrites := 0;
@ -3567,7 +3568,7 @@ begin
MessageDlg(E.Message, mtError, [mbOK], 0, mbOK);
end;
end else begin
FBasePath := PathDelimiter;
FBasePath := PathDelimiter + 'Software' + PathDelimiter + APPNAME + PathDelimiter;
FSettingsFile := '';
end;
@ -4058,7 +4059,7 @@ begin
// Note that, contrary to the documentation, .DeleteKey is done even when this key has subkeys
PrepareRegistry;
if FSessionPath.IsEmpty then
raise Exception.CreateFmt(_('No path set, won''t delete root key %s'), [FRegistry.CurrentPath])
raise Exception.CreateFmt(_('No path set, won''t delete root key %s'), [FRegistry.CurrentPath])
else begin
KeyPath := AppendDelimiter(REGKEY_SESSIONS) + FSessionPath;
ResetPath;
@ -4361,8 +4362,6 @@ begin
Segments := Explode(LINEDELIMITER, Lines[i]);
if Segments.Count <> 3 then
continue;
// Windows registry to JSON path delimiter conversion: \ => /
Segments[0] := StringReplace(Segments[0], '\', PathDelimiter, [rfReplaceAll]);
KeyPath := FBasePath + ExtractFilePath(Segments[0]);
Name := ExtractFileName(Segments[0]);
DataType := StrToIntDef(Segments[1], 0);
@ -4378,7 +4377,7 @@ begin
Value := StringReplace(Value, CHR10REPLACEMENT, #10, [rfReplaceAll]);
FRegistry.WriteString(Name, Value);
end;
3: // Integer
3: // Integer (Delphi definition)
FRegistry.WriteInteger(Name, MakeInt(Value));
else
ErrorDialog(Name+' has an unsupported data type.');
@ -4392,7 +4391,8 @@ end;
function TAppSettings.ExportSettings(Filename: String): Boolean;
var
Content, Value: String;
//DataType: TRegDataType;
DataType: TRegDataType;
DataTypeInt: Integer;
procedure ReadKeyToContent(Path: String);
var
@ -4401,15 +4401,19 @@ var
SubPath: String;
begin
// Recursively read values in keys and their subkeys into "content" variable
{FRegistry.OpenKey(Path, True);
FRegistry.OpenKey(Path, True);
SubPath := Copy(Path, Length(FBasePath)+1, MaxInt);
Names := TStringList.Create;
FRegistry.GetValueNames(Names);
for i:=0 to Names.Count-1 do begin
DataType := FRegistry.GetDataType(Names[i]);
DataTypeInt := Integer(DataType);
// Delphi uses 3, Lazarus 4
if DataTypeInt = 4 then
DataTypeInt := 3;
Content := Content +
SubPath + Names[i] + DELIMITER +
IntToStr(Integer(DataType)) + DELIMITER;
SubPath + Names[i] + LINEDELIMITER +
DataTypeInt.ToString + LINEDELIMITER;
case DataType of
rdString: begin
Value := FRegistry.ReadString(Names[i]);
@ -4426,8 +4430,8 @@ var
Names.Clear;
FRegistry.GetKeyNames(Names);
for i:=0 to Names.Count-1 do
ReadKeyToContent(Path + AppendDelimiter(Names[i]));
Names.Free;}
ReadKeyToContent(Path + Names[i] + PathDelimiter);
Names.Free;
end;
begin

294
source/jsonregistry.pas
View File

@ -1,294 +0,0 @@
unit jsonregistry;
{$mode Delphi}{$H+}
interface
uses
Classes, SysUtils, jsonConf, fpjson, ExtCtrls;
type
{ TJSONConfigExtended }
TJSONConfigExtended = class(TJSONConfig)
public
function AddEndSlash(Path: UnicodeString): UnicodeString;
function StripEndSlash(Path: UnicodeString): UnicodeString;
procedure MoveKey(SourcePath: UnicodeString; TargetPath: UnicodeString; Delete: Boolean);
function DataType(Path: UnicodeString): TJSONtype;
end;
{ TJSONRegistry }
TJsonRegistry = class(TPersistent)
private
FJsConf: TJSONConfigExtended;
FCurrentKeyPath: UnicodeString;
FAutoFlushTimer: TTimer;
function GetAutoFlushMilliSeconds: Cardinal;
procedure SetAutoFlushMilliSeconds(aValue: Cardinal);
procedure AutoFlushOnTimer(Sender: TObject);
public
constructor Create(JsonFilePath: String);
destructor Destroy; override;
function FilePath: String;
// Keys:
function OpenKey(Path: UnicodeString; CanCreate: Boolean): Boolean;
procedure CloseKey;
function DeleteKey(Path: UnicodeString): Boolean;
procedure MoveKey(sourcepath: UnicodeString; targetpath: UnicodeString; Delete: Boolean);
procedure GetKeyNames(list: TStringList);
function CurrentPath: UnicodeString;
function KeyExists(path: UnicodeString): Boolean;
function HasSubKeys: Boolean;
// Values:
function DeleteValue(name: UnicodeString): Boolean;
procedure GetValueNames(list: TStringList);
function ValueExists(name: UnicodeString): Boolean;
function ReadInteger(name: UnicodeString): Integer;
function ReadBool(name: UnicodeString): Boolean;
function ReadString(name: UnicodeString): UnicodeString;
procedure WriteInteger(name: UnicodeString; value: Integer);
procedure WriteBool(name: UnicodeString; value: Boolean);
procedure WriteString(name: UnicodeString; value: UnicodeString);
function GetDataType(Path: UnicodeString): TJSONtype;
property AutoFlushMilliSeconds: Cardinal read GetAutoFlushMilliSeconds write SetAutoFlushMilliSeconds;
end;
implementation
{ TJSONConfigExtended }
function TJSONConfigExtended.AddEndSlash(Path: UnicodeString): UnicodeString;
begin
Result := Path;
if Result[Length(Result)] <> '/' then
Result := Result + '/';
end;
function TJSONConfigExtended.StripEndSlash(Path: UnicodeString): UnicodeString;
begin
Result := Path;
if Result[Length(Result)] = '/' then
Delete(Result, Length(Result), 1);
end;
procedure TJSONConfigExtended.MoveKey(SourcePath: UnicodeString;
TargetPath: UnicodeString; Delete: Boolean);
var
OldNode, NewNode, NewNodeParent: TJSONObject;
NewNodeName: UnicodeString;
TargetPathSlash, TargetPathNoSlash: UnicodeString;
begin
if Length(SourcePath) = 0 then
Raise EJSONConfigError.Create('Cannot move from empty path');
if Length(TargetPath) = 0 then
Raise EJSONConfigError.Create('Cannot move to empty path');
SourcePath := AddEndSlash(SourcePath);
OldNode := FindObject(SourcePath, False);
if not Assigned(OldNode) then
raise EJSONConfigError.CreateFmt('Source path does not exist: %s', [SourcePath]);
TargetPathSlash := AddEndSlash(TargetPath);
TargetPathNoSlash := StripEndSlash(TargetPath);
//showmessage('TargetPathSlash:"'+TargetPathSlash+'"'+sLineBreak+'TargetPathNoSlash:"'+TargetPathNoSlash+'"');
// Error if target exists
NewNode := FindObject(TargetPathSlash, False);
if Assigned(NewNode) then
Raise EJSONConfigError.CreateFmt('Target path already exists: %s', [TargetPathSlash]);
// Create copied key
NewNodeParent := FindObject(TargetPathNoSlash, True, NewNodeName);
NewNodeParent.Add(NewNodeName, OldNode.Clone);
if Delete then begin
// Deleting source key. Note we have cloned this before.
DeletePath(SourcePath);
end;
FModified:=True;
end;
function TJSONConfigExtended.DataType(Path: UnicodeString): TJSONtype;
var
e: TJSONData;
begin
e := FindElement(Path, False, True);
if Assigned(e) then
Result := e.JSONType
else
Result := jtUnknown;
end;
{ TJsonRegistry }
constructor TJsonRegistry.Create(JsonFilePath: String);
begin
FJsConf := TJSONConfigExtended.Create(nil);
FJsConf.Formatted := True;
FJsConf.Filename := JsonFilePath;
FAutoFlushTimer := TTimer.Create(nil);
FAutoFlushTimer.Enabled := False;
FAutoFlushTimer.OnTimer := AutoFlushOnTimer;
SetAutoFlushMilliSeconds(5000);
end;
destructor TJsonRegistry.Destroy;
begin
FJsConf.Flush;
FAutoFlushTimer.Free;
end;
function TJsonRegistry.GetAutoFlushMilliSeconds: Cardinal;
begin
Result := FAutoFlushTimer.Interval;
end;
procedure TJsonRegistry.SetAutoFlushMilliSeconds(aValue: Cardinal);
begin
FAutoFlushTimer.Enabled := False;
FAutoFlushTimer.Interval := aValue;
FAutoFlushTimer.Enabled := aValue > 0;
end;
procedure TJsonRegistry.AutoFlushOnTimer(Sender: TObject);
begin
FJsConf.Flush;
end;
function TJsonRegistry.FilePath: String;
begin
Result := FJsConf.Filename;
end;
function TJsonRegistry.OpenKey(Path: UnicodeString; CanCreate: Boolean): Boolean;
begin
try
FJsConf.OpenKey(Path, CanCreate);
FCurrentKeyPath := Path;
Result := True;
except
on EJSONConfigError do begin
Result := False;
end;
end;
end;
procedure TJsonRegistry.CloseKey;
begin
FJsConf.Flush;
FJsConf.CloseKey;
end;
function TJsonRegistry.DeleteKey(Path: UnicodeString): Boolean;
begin
FJsConf.DeletePath(Path);
Result := True;
end;
procedure TJsonRegistry.MoveKey(sourcepath: UnicodeString; targetpath: UnicodeString; Delete: Boolean);
begin
FJsConf.MoveKey(sourcepath, targetpath, Delete);
end;
procedure TJsonRegistry.GetKeyNames(list: TStringList);
begin
FJsConf.EnumSubKeys(FCurrentKeyPath, list);
end;
function TJsonRegistry.CurrentPath: UnicodeString;
begin
Result := FCurrentKeyPath;
end;
function TJsonRegistry.KeyExists(path: UnicodeString): Boolean;
var
SubKeys: TStringList;
LastDelim: Integer;
folder, name: UnicodeString;
begin
SubKeys := TStringList.Create;
path := FJsConf.StripEndSlash(path);
LastDelim := String(path).LastIndexOf('/');
name := Copy(path, LastDelim+2);
folder := Copy(path, 1, LastDelim);
//showmessage('folder:'+folder+sLineBreak+'name:'+name);
FJsConf.EnumSubKeys(folder, SubKeys);
Result := SubKeys.IndexOf(name) > -1;
SubKeys.Free;
end;
function TJsonRegistry.HasSubKeys: Boolean;
var
SubKeys: TStringList;
begin
SubKeys := TStringList.Create;
GetKeyNames(SubKeys);
Result := SubKeys.Count > 0;
SubKeys.Free;
end;
function TJsonRegistry.DeleteValue(name: UnicodeString): Boolean;
begin
FJsConf.DeleteValue(name);
Result := True;
end;
procedure TJsonRegistry.GetValueNames(list: TStringList);
begin
FJsConf.EnumValues(FCurrentKeyPath, list);
end;
function TJsonRegistry.ValueExists(name: UnicodeString): Boolean;
var
Values: TStringList;
begin
Values := TStringList.Create;
GetValueNames(Values);
Result := Values.IndexOf(name) > -1;
Values.Free;
end;
function TJsonRegistry.ReadInteger(name: UnicodeString): Integer;
begin
Result := FJsConf.GetValue(name, 0);
end;
function TJsonRegistry.ReadBool(name: UnicodeString): Boolean;
begin
Result := FJsConf.GetValue(name, False);
end;
function TJsonRegistry.ReadString(name: UnicodeString): UnicodeString;
begin
Result := FJsConf.GetValue(name, '');
end;
procedure TJsonRegistry.WriteInteger(name: UnicodeString; value: Integer);
begin
FJsConf.SetValue(name, value);
end;
procedure TJsonRegistry.WriteBool(name: UnicodeString; value: Boolean);
begin
FJsConf.SetValue(name, value);
end;
procedure TJsonRegistry.WriteString(name: UnicodeString; value: UnicodeString);
begin
FJsConf.SetValue(name, value);
end;
function TJsonRegistry.GetDataType(Path: UnicodeString): TJSONtype;
begin
Result := FJsConf.DataType(Path);
end;
end.