123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638 |
- { ***************************************************************************
- Copyright (c) 2015-2019 Kike Pérez
- Unit : Quick.Config.Registry
- Description : Save config to Windows Registry
- Author : Kike Pérez
- Version : 1.5
- Created : 21/10/2017
- Modified : 12/04/2019
- This file is part of QuickLib: https://github.com/exilon/QuickLib
- ***************************************************************************
- Licensed under the Apache License, Version 2.0 (the "License");
- you may not use this file except in compliance with the License.
- You may obtain a copy of the License at
- http://www.apache.org/licenses/LICENSE-2.0
- Unless required by applicable law or agreed to in writing, software
- distributed under the License is distributed on an "AS IS" BASIS,
- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
- See the License for the specific language governing permissions and
- limitations under the License.
- *************************************************************************** }
- unit Quick.Config.Registry;
- {$i QuickLib.inc}
- interface
- uses
- Classes,
- Windows,
- SysUtils,
- Registry,
- Quick.Json.Serializer,
- {$IFDEF DELPHIRX102_UP}
- System.Json,
- System.JSON.Types,
- {$ELSE}
- {$IFDEF FPC}
- fpjson,
- //jsonparser,
- //fpjsonrtti,
- Quick.Json.fpc.Compatibility,
- {$ELSE}
- Rest.Json.Types,
- System.JSON,
- Rest.Json,
- {$ENDIF}
- {$ENDIF}
- Quick.Commons,
- Quick.Config.Base;
- type
- {$IFNDEF FPC}
- TNotSerializableProperty = Quick.Json.Serializer.TNotSerializableProperty;
- TCommentProperty = Quick.Json.Serializer.TCommentProperty;
- TCustomNameProperty = Quick.Json.Serializer.TCustomNameProperty;
- {$ENDIF}
- TAppConfigRegistryProvider = class(TAppConfigProvider)
- private
- fRootKey : HKEY;
- fMainKey : string;
- fRegConfig : TRegistry;
- function JsonToRegistry(const StrJson : string) : Boolean;
- function RegistryToJson(out StrJson : string) : Boolean;
- class function IsSimpleJsonValue(v: TJSONValue): Boolean;
- function IsRegKeyObject(const cCurrentKey : string = '') : Boolean;
- function IsRegKeyArray(const cCurrentKey : string = '') : Boolean;
- function ProcessPairRead(const cCurrentKey, cRegKey : string; aIndex : Integer) : TJSONValue;
- function ProcessElementRead(const cCurrentKey, cRegKey : string; aIndex : Integer) : TJSONValue;
- procedure ProcessPairWrite(const cCurrentKey: string; obj: TJSONObject; aIndex: integer);
- procedure ProcessElementWrite(const cCurrentKey: string; arr: TJSONArray; aIndex, aMax : integer);
- function AddRegKey(const cCurrentKey, NewKey : string) : Boolean;
- function ReadRegValue(const cCurrentKey, cName : string) : TJSONValue;
- procedure AddRegValue(const cCurrentKey, cName : string; cValue : TJSONValue);
- protected
- procedure Load(cConfig : TAppConfig); override;
- procedure Save(cConfig : TAppConfig); override;
- public
- constructor Create(aHRoot : HKEY = HKEY_CURRENT_USER; const aMainKey : string = ''); virtual;
- destructor Destroy; override;
- property HRoot : HKEY read fRootKey write fRootKey;
- property MainKey : string read fMainKey write fMainKey;
- end;
- EAppConfig = Exception;
- TAppConfigRegistry = class(TAppConfig)
- private
- function GetProvider : TAppConfigRegistryProvider;
- public
- constructor Create(aHRoot : HKEY = HKEY_CURRENT_USER; const aMainKey : string = '');
- destructor Destroy; override;
- property Provider : TAppConfigRegistryProvider read GetProvider;
- end;
- {Usage: create a descend class from TAppConfigRegistry and add published properties to be loaded/saved
- TMyConfig = class(TAppConfigRegistry)
- private
- fName : string;
- fSurname : string;
- fStatus : Integer;
- published
- property Name : string read fName write fName;
- property SurName : string read fSurname write fSurname;
- property Status : Integer read fStatus write fStatus;
- end;
- MyConfig := TMyConfig.Create;
- MyConfig.Provider.MainKey := 'MyAppName';
- MyConfig.Name := 'John';
- MyConfig.Save;
- }
- implementation
- { TAppConfigRegistryProvider }
- constructor TAppConfigRegistryProvider.Create(aHRoot : HKEY = HKEY_CURRENT_USER; const aMainKey : string = '');
- begin
- inherited Create;
- if aHRoot <> HKEY_CURRENT_USER then fRootKey := aHRoot
- else fRootKey := HKEY_CURRENT_USER;
- if aMainKey <> '' then fMainKey := aMainKey
- else fMainKey := ExtractFileNameWithoutExt(ParamStr(0));
- fRegConfig := TRegistry.Create(KEY_READ or KEY_WRITE);
- end;
- destructor TAppConfigRegistryProvider.Destroy;
- begin
- if Assigned(fRegConfig) then fRegConfig.Free;
- inherited;
- end;
- procedure TAppConfigRegistryProvider.Load(cConfig : TAppConfig);
- var
- Serializer: TJsonSerializer;
- json : string;
- begin
- fRegConfig.Access := KEY_READ;
- fRegConfig.RootKey := fRootKey;
- if not fRegConfig.KeyExists('\Software\' + fMainKey) then
- begin
- if not CreateIfNotExists then raise EAppConfig.Create('Not exists MainKey in registry!')
- else TAppConfigRegistry(cConfig).DefaultValues;
- Save(cConfig);
- end;
- RegistryToJson(json);
- serializer := TJsonSerializer.Create(slPublishedProperty);
- try
- serializer.JsonToObject(cConfig,json);
- finally
- serializer.Free;
- end;
- end;
- procedure TAppConfigRegistryProvider.Save(cConfig : TAppConfig);
- begin
- JsonToRegistry(cConfig.ToJSON);
- end;
- function TAppConfigRegistryProvider.JsonToRegistry(const StrJson : string) : Boolean;
- var
- jValue : TJSONValue;
- aCount : Integer;
- i : Integer;
- aCurrentKey : string;
- begin
- Result := False;
- if fMainKey = '' then raise EAppConfig.Create('MainKey not defined!');
- fRegConfig.Access := KEY_READ or KEY_WRITE;
- fRegConfig.RootKey := fRootKey;
- aCurrentKey := '\Software\' + fMainKey;
- if fRegConfig.KeyExists(aCurrentKey) then
- begin
- try
- if fRegConfig.KeyExists(aCurrentKey + '_bak') then fRegConfig.DeleteKey(aCurrentKey + '_bak');
- fRegConfig.MoveKey(aCurrentKey,aCurrentKey + '_bak',True);
- except
- raise EAppConfig.Create('Can''t write Config Registry');
- end;
- end;
- try
- if not AddRegKey('\Software',fMainKey) then
- begin
- raise EAppConfig.Create('Can''t create key');
- end;
- {$IFNDEF FPC}
- jValue := TJSONObject.ParseJSONValue(TEncoding.ASCII.GetBytes(StrJson),0) as TJSONValue;
- {$ELSE}
- jValue := TJSONObject.ParseJSONValue(StrJson) as TJSONValue;
- {$ENDIF}
- try
- if IsSimpleJsonValue(jValue) then
- begin
- {$IFNDEF FPC}
- AddRegValue(aCurrentKey,TJSONPair(jValue).JsonString.ToString.DeQuotedString('"'),TJSONPair(jValue).JsonValue);
- {$ELSE}
- AddRegValue(aCurrentKey,TJSONPair(jValue).JsonString.DeQuotedString('"'),TJSONPair(jValue).JsonValue);
- {$ENDIF}
- end
- {$IFNDEF FPC}
- else if jValue is TJSONObject then
- {$ELSE}
- else if jvalue.JSONType = jtObject then
- {$ENDIF}
- begin
- aCount := TJSONObject(jValue).Count;
- for i := 0 to aCount - 1 do
- ProcessPairWrite(aCurrentKey,TJSONObject(jValue),i);
- end
- {$IFNDEF FPC}
- else if jValue is TJSONArray then
- {$ELSE}
- else if jValue.JSONType = jtArray then
- {$ENDIF}
- begin
- aCount := TJSONArray(jValue).Count;
- for i := 0 to aCount - 1 do
- ProcessElementWrite(aCurrentKey,TJSONArray(jValue),i,aCount);
- end
- else raise EAppConfig.Create('Error Saving config to Registry');
- Result := True;
- finally
- jValue.Free;
- end;
- if fRegConfig.KeyExists(aCurrentKey + '_bak') then fRegConfig.DeleteKey(aCurrentKey + '_bak');
- except
- on E : Exception do
- begin
- fRegConfig.DeleteKey(aCurrentKey);
- fRegConfig.MoveKey(aCurrentKey+'_bak',aCurrentKey,True);
- raise EAppConfig.Create(e.message);
- end;
- end;
- end;
- function TAppConfigRegistryProvider.RegistryToJson(out StrJson : string) : Boolean;
- var
- jValue : TJSONValue;
- jPair : TJSONPair;
- jArray : TJSONArray;
- a, b : string;
- aCount : Integer;
- i : Integer;
- aName : string;
- aValue : TJSONValue;
- aCurrentKey : string;
- newObj : TJSONObject;
- RegKeyList : TStringList;
- RegValueList : TStringList;
- RegKey : string;
- RegValue : string;
- RegKeyInfo : TRegKeyInfo;
- begin
- Result := False;
- //check if exists root key
- fRegConfig.Access := KEY_READ;
- fRegConfig.RootKey := fRootKey;
- if fRegConfig.KeyExists('\Software\' + fMainKey) then
- begin
- fRegConfig.OpenKeyReadOnly('\Software\' + fMainKey);
- aCurrentKey := '\Software\' + fMainKey;
- end
- else raise EAppConfig.Create('Can''t read key');
- newObj := TJSONObject.Create;
- try
- //read root values
- RegValueList := TStringList.Create;
- try
- fRegConfig.GetValueNames(RegValueList);
- for RegValue in RegValueList do
- begin
- newObj.AddPair(RegValue,ReadRegValue(aCurrentKey,RegValue));
- end;
- finally
- RegValueList.Free;
- end;
- //read root keys
- RegKeyList := TStringList.Create;
- try
- fRegConfig.GetKeyNames(RegKeyList);
- for RegKey in RegKeyList do
- begin
- fRegConfig.OpenKeyReadOnly(aCurrentKey + '\' + RegKey);
- if IsRegKeyObject then
- begin
- jValue := ProcessPairRead(aCurrentKey + '\' + RegKey,Regkey,i);
- newObj.AddPair(RegKey,jValue);
- end
- else if IsRegKeyArray then
- begin
- jValue := ProcessElementRead(aCurrentKey + '\' + RegKey,Regkey,i);
- newObj.AddPair(RegKey,jValue);
- end
- else raise EAppConfig.Create('Unknow value reading Config Registry');
- end;
- finally
- RegKeyList.Free;
- end;
- StrJson := newObj.ToJSON;
- finally
- newObj.Free;
- end;
- end;
- function TAppConfigRegistryProvider.IsRegKeyObject(const cCurrentKey : string = '') : Boolean;
- begin
- Result := not IsRegKeyArray(cCurrentKey);
- end;
- function TAppConfigRegistryProvider.IsRegKeyArray(const cCurrentKey : string = '') : Boolean;
- var
- RegValue : string;
- RegValueList : TStrings;
- RegKey : string;
- RegKeyList : TStrings;
- n : Integer;
- begin
- Result := False;
- if cCurrentKey <> '' then fRegConfig.OpenKeyReadOnly(cCurrentKey);
- //check if exists RegKey numeric (indicates is a Array)
- RegKeyList := TStringList.Create;
- try
- {$IFNDEF FPC}
- fRegConfig.GetKeyNames(RegKeyList);
- {$ELSE}
- try
- fRegConfig.GetKeyNames(RegKeyList);
- except
- end;
- {$ENDIF}
- for RegKey in RegKeyList do
- if TryStrToInt(RegKey,n) then
- begin
- Result := True;
- Break;
- end;
- finally
- RegKeyList.Free;
- end;
- //check if exists RegValue numeric (indicates is a Array)
- RegValueList := TStringList.Create;
- try
- {$IFNDEF FPC}
- fRegConfig.GetValueNames(RegValueList);
- {$ELSE}
- try
- fRegConfig.GetValueNames(RegValueList);
- except
- end;
- {$ENDIF}
- for RegValue in RegValueList do
- if TryStrToInt(RegValue,n) then
- begin
- Result := True;
- Break;
- end;
- finally
- RegValueList.Free;
- end;
- end;
- class function TAppConfigRegistryProvider.IsSimpleJsonValue(v: TJSONValue): Boolean;
- begin
- Result := (v is {$IFDEF FPC}fpjson.TJsonIntegerNumber{$ELSE}TJSONNumber{$ENDIF})
- or (v is {$IFDEF FPC}fpjson.{$ENDIF}TJSONString)
- {$IFNDEF FPC}
- or (v is TJSONTrue)
- or (v is TJSONFalse)
- {$ELSE}
- or (v is {$IFDEF FPC}fpjson.TJSONBoolean{$ELSE}TJsonBool{$ENDIF})
- {$ENDIF}
- or (v is {$IFDEF FPC}fpjson.{$ENDIF}TJSONNull);
- end;
- function TAppConfigRegistryProvider.ReadRegValue(const cCurrentKey, cName : string) : TJSONValue;
- var
- aValue : string;
- RegInfo : TRegDataInfo;
- begin
- if fRegConfig.OpenKeyReadOnly(cCurrentKey) then
- begin
- if fRegConfig.GetDataInfo(cName,RegInfo) then
- case RegInfo.RegData of
- rdInteger : Result := TJSONNumber.Create(fRegConfig.ReadInteger(cName));
- rdString :
- begin
- aValue := fRegConfig.ReadString(cName);
- if aValue.ToLower = 'true' then Result := TJSONBool.Create(True)
- else if aValue.ToLower = 'false' then Result := TJSONBool.Create(False)
- else Result := TJSONString.Create(aValue);
- end;
- else Result := TJSONNull.Create;
- end;
- end;
- end;
- function TAppConfigRegistryProvider.AddRegKey(const cCurrentKey, NewKey : string) : Boolean;
- begin
- Result := fRegConfig.CreateKey(Format('%s\%s',[cCurrentKey,NewKey]));
- end;
- procedure TAppConfigRegistryProvider.AddRegValue(const cCurrentKey, cName : string; cValue : TJSONValue);
- var
- aName : string;
- aValue : string;
- begin
- aName := cName.DeQuotedString('"');
- {$IFNDEF FPC}
- aValue := cValue.ToString.DeQuotedString('"');
- {$ELSE}
- aValue := cValue.AsString;// .DeQuotedString('"');
- {$ENDIF}
- fRegConfig.OpenKey(cCurrentKey,True);
- if cValue is {$IFDEF FPC}fpjson.TJSONIntegerNumber{$ELSE}TJSONNumber{$ENDIF} then fRegConfig.WriteInteger(aName,StrToInt64(aValue))
- else if cValue is {$IFDEF FPC}fpjson.{$ENDIF}TJSONString then fRegConfig.WriteString(aName,aValue)
- else if cValue is {$IFDEF FPC}fpjson.TJSONBoolean{$ELSE}TJSONBool{$ENDIF} then fRegConfig.WriteString(aName,aValue);
- //else if cValue is TJSONNull then fRegConfig.WriteString(aName,'');
- end;
- function TAppConfigRegistryProvider.ProcessPairRead(const cCurrentKey, cRegKey : string; aIndex : Integer) : TJSONValue;
- var
- i : Integer;
- jValue : TJSONValue;
- RegValue : string;
- RegValueList : TStrings;
- RegKey : string;
- RegKeyList : TStrings;
- newObj : TJSONObject;
- begin
- newObj := TJSONObject.Create;
- //read root values
- RegValueList := TStringList.Create;
- try
- {$IFNDEF FPC}
- fRegConfig.GetValueNames(RegValueList);
- {$ELSE}
- try
- fRegConfig.GetValueNames(RegValueList);
- except
- end;
- {$ENDIF}
- for RegValue in RegValueList do
- begin
- newObj.AddPair(RegValue,ReadRegValue(cCurrentKey,RegValue));
- end;
- finally
- RegValueList.Free;
- end;
- //read root keys
- RegKeyList := TStringList.Create;
- try
- {$IFNDEF FPC}
- fRegConfig.GetKeyNames(RegKeyList);
- {$ELSE}
- try
- fRegConfig.GetKeyNames(RegKeyList);
- except
- end;
- {$ENDIF}
- for RegKey in RegKeyList do
- begin
- fRegConfig.OpenKeyReadOnly(cCurrentKey + '\' + RegKey);
- if IsRegKeyObject then
- begin
- jValue := ProcessPairRead(cCurrentKey + '\' + RegKey,Regkey,i);
- newObj.AddPair(RegKey,jValue);
- end
- else if IsRegKeyArray then
- begin
- jValue := ProcessElementRead(cCurrentKey + '\' + RegKey,Regkey,i);
- newObj.AddPair(RegKey,jValue);
- end
- else raise EAppConfig.Create('Unknow value reading Config Registry');
- end;
- finally
- RegKeyList.Free;
- end;
- Result := TJsonValue(newObj);
- end;
- function TAppConfigRegistryProvider.ProcessElementRead(const cCurrentKey, cRegKey : string; aIndex : Integer) : TJSONValue;
- var
- i : Integer;
- jValue : TJSONValue;
- RegValue : string;
- RegValueList : TStrings;
- RegKey : string;
- RegKeyList : TStrings;
- newObj : TJSONArray;
- begin
- newObj := TJSONArray.Create;
- //read root values
- RegValueList := TStringList.Create;
- try
- {$IFNDEF FPC}
- fRegConfig.GetValueNames(RegValueList);
- {$ELSE}
- try
- fRegConfig.GetValueNames(RegValueList);
- except
- end;
- {$ENDIF}
- for RegValue in RegValueList do
- begin
- newObj.AddElement(ReadRegValue(cCurrentKey,RegValue));
- end;
- finally
- RegValueList.Free;
- end;
- //read root keys
- RegKeyList := TStringList.Create;
- try
- {$IFNDEF FPC}
- fRegConfig.GetKeyNames(RegKeyList);
- {$ELSE}
- try
- fRegConfig.GetKeyNames(RegKeyList);
- except
- end;
- {$ENDIF}
- for RegKey in RegKeyList do
- begin
- fRegConfig.OpenKeyReadOnly(cCurrentKey + '\' + RegKey);
- if IsRegKeyObject then
- begin
- jValue := ProcessPairRead(cCurrentKey + '\' + RegKey,Regkey,i);
- newObj.AddElement(jValue);
- end
- else if IsRegKeyArray then
- begin
- jValue := ProcessElementRead(cCurrentKey + '\' + RegKey,Regkey,i);
- newObj.AddElement(jValue);
- end
- else raise EAppConfig.Create('Unknow value reading Config Registry');
- end;
- finally
- RegKeyList.Free;
- end;
- Result := TJsonValue(newObj);
- end;
- procedure TAppConfigRegistryProvider.ProcessPairWrite(const cCurrentKey: string; obj: TJSONObject; aIndex: integer);
- var
- jPair: TJSONPair;
- i : Integer;
- aCount: integer;
- begin
- jPair := obj.Pairs[aIndex];
- if IsSimpleJsonValue(jPair.JsonValue) then
- begin
- AddRegValue(cCurrentKey,jPair.JsonString{$IFNDEF FPC}.ToString{$ENDIF},jPair.JsonValue);
- Exit;
- end;
- if jPair.JsonValue is {$IFDEF FPC}fpjson.{$ENDIF}TJSONObject then
- begin
- aCount := TJSONObject(jPair.JsonValue).Count;
- for i := 0 to aCount - 1 do
- ProcessPairWrite(cCurrentKey + '\' + jPair.JsonString{$IFNDEF FPC}.ToString{$ENDIF}.DeQuotedString('"'), TJSONObject(jPair.JsonValue),i);
- end
- else if jPair.JsonValue is {$IFDEF FPC}fpjson.{$ENDIF}TJSONArray then
- begin
- aCount := TJSONArray(jPair.JsonValue).Count;
- for i := 0 to aCount - 1 do
- ProcessElementWrite(cCurrentKey + '\' + jPair.JsonString{$IFNDEF FPC}.ToString{$ENDIF}.DeQuotedString('"'), TJSONArray(jPair.JsonValue),i,aCount);
- end
- else raise EAppConfig.Create('Error Saving config to Registry');
- end;
- procedure TAppConfigRegistryProvider.ProcessElementWrite(const cCurrentKey: string; arr: TJSONArray; aIndex, aMax: integer);
- var
- jValue: TJSONValue;
- i : Integer;
- aCount: integer;
- dig : Integer;
- begin
- jValue := arr.Items[aIndex];
- dig := CountDigits(aMax);
- if IsSimpleJsonValue(jValue) then
- begin
- AddRegValue(cCurrentKey,Zeroes(aIndex,dig),jValue);
- Exit;
- end;
- if jValue is {$IFDEF FPC}fpjson.{$ENDIF}TJSONObject then
- begin
- aCount := TJSONObject(jValue).Count;
- for i := 0 to aCount - 1 do
- ProcessPairWrite(cCurrentKey + '\' + Zeroes(aIndex,dig),TJSONObject(jValue),i);
- end
- else if jValue is {$IFDEF FPC}fpjson.{$ENDIF}TJSONArray then
- begin
- aCount := TJSONArray(jValue).Count;
- for i := 0 to aCount - 1 do
- ProcessElementWrite(cCurrentKey + '\' + Zeroes(i,dig),TJSONArray(jValue),i,aCount);
- end
- else raise EAppConfig.Create('Error Saving config to Registry');
- end;
- { TAppConfigRegistry }
- constructor TAppConfigRegistry.Create(aHRoot : HKEY = HKEY_CURRENT_USER; const aMainKey : string = '');
- begin
- inherited Create(TAppConfigRegistryProvider.Create(aHRoot,aMainKey));
- end;
- destructor TAppConfigRegistry.Destroy;
- begin
- inherited;
- end;
- function TAppConfigRegistry.GetProvider: TAppConfigRegistryProvider;
- begin
- if not Assigned(fProvider) then raise EAppConfig.Create('No provider assigned!');
- Result := TAppConfigRegistryProvider(fProvider);
- end;
- end.
|