{$I CompMode.INI}

{$IFDEF Debug}
Unit Registry;
{$ELSE}
UNIT B3;
{$ENDIF}

Interface

{$IFDEF Debug}
Uses
  Windows, StrList, AclUtils;
{$ELSE}
Uses
  Windows, A12, B1;
{$ENDIF}

type
  TRegKeyInfo = record
    NumSubKeys: Integer;
    MaxSubKeyLen: Integer;
    NumValues: Integer;
    MaxValueLen: Integer;
    MaxDataLen: Integer;
    FileTime: TFileTime;
  end;

  TRegDataType = (rdUnknown, rdString, rdExpandString, rdInteger, rdBinary);

  TRegDataInfo = record
    RegData: TRegDataType;
    DataSize: Integer;
  end;

  TRG = class(TObject)
  private
    FCurrentKey   : HKEY;
    FRootKey      : HKEY;
    FCurrentPath  : string;
    FCloseRootKey : Boolean;
    FAccess       : LongWord;
    procedure SetRootKey(Value: HKEY);
  protected
    procedure ChangeKey(Value: HKey; const Path: string);
    function  GetBaseKey(Relative: Boolean): HKey;
    function  GetData(const Name: string; Buffer: Pointer; BufSize: Integer; var RegData: TRegDataType): Integer;
    function  GetKey(const Key: string): HKEY;
    procedure PutData(const Name: string; Buffer: Pointer; BufSize: Integer; RegData: TRegDataType);
    procedure SetCurrentKey(Value: HKEY);
  public
    constructor Create; overload;
    procedure CloseKey;
    function  GetDataInfo(const ValueName: string; var Value: TRegDataInfo): Boolean;
    function  GetDataSize(const ValueName: string): Integer;
    function  GetDataType(const ValueName: string): TRegDataType;
    function  GetKeyInfo(var Value: TRegKeyInfo): Boolean;
    procedure GetKeyNames(Strings: TStrlist);
    function  KeyExists(const Key: string): Boolean;
    function  OpenKey(const Key: string; CanCreate: Boolean): Boolean;
    function  ReadBinaryData(const Name: string; var Buffer; BufSize: Integer): Integer;
    function  ReadInteger(const Name: string): Integer;
    function  ReadString(const Name: string): string;
    function  ValueExists(const Name: string): Boolean;
    procedure WriteInteger(const Name: string; Value: Integer);
    procedure WriteString(const Name, Value: string);
    property  RootKey: HKEY read FRootKey write SetRootKey;
  end;

Implementation

function IsRelative(var Value: string): Boolean;
begin
  Result := not ((Value <> '') and (Value[1] = '\'));
  if not Result then Delete(value, 1, 1);
end;

function RegDataToDataType(Value: TRegDataType): Integer;
begin
  case Value of
    rdString: Result := REG_SZ;
    rdExpandString: Result := REG_EXPAND_SZ;
    rdInteger: Result := REG_DWORD;
    rdBinary: Result := REG_BINARY;
  else
    Result := REG_NONE;
  end;
end;

function DataTypeToRegData(Value: Integer): TRegDataType;
begin
  if Value = REG_SZ then Result := rdString
  else if Value = REG_EXPAND_SZ then Result := rdExpandString
  else if Value = REG_DWORD then Result := rdInteger
  else if Value = REG_BINARY then Result := rdBinary
  else Result := rdUnknown;
end;

constructor TRG.Create;
begin
  RootKey := HKEY_CURRENT_USER;
  FAccess := KEY_ALL_ACCESS;
end;

procedure TRG.CloseKey;
begin
  if FCurrentKey <> 0 then begin
    RegCloseKey(FCurrentKey);
    FCurrentKey := 0;
    FCurrentPath := '';
  end;
end;

procedure TRG.SetRootKey(Value: HKEY);
begin
  if RootKey <> Value then begin
    if FCloseRootKey then begin
      RegCloseKey(RootKey);
      FCloseRootKey := False;
    end;
    FRootKey := Value;
    CloseKey;
  end;
end;

procedure TRG.ChangeKey(Value: HKey; const Path: string);
begin
  CloseKey;
  FCurrentKey := Value;
  FCurrentPath := Path;
end;

function TRG.GetBaseKey(Relative: Boolean): HKey;
begin
  if (FCurrentKey = 0) or not Relative then
    Result := RootKey else
    Result := FCurrentKey;
end;

procedure TRG.SetCurrentKey(Value: HKEY);
begin
  FCurrentKey := Value;
end;

function TRG.OpenKey(const Key: String; Cancreate: boolean): Boolean;
var
  TempKey: HKey;
  S: string;
  Disposition: Integer;
  Relative: Boolean;
begin
  S := Key;
  Relative := IsRelative(S);
  TempKey := 0;
  if not CanCreate or (S = '') then
  begin
    Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,
      FAccess, TempKey) = ERROR_SUCCESS;
  end else
    Result := RegCreateKeyEx(GetBaseKey(Relative), PChar(S), 0, nil,
      REG_OPTION_NON_VOLATILE, FAccess, nil, TempKey, @Disposition) = ERROR_SUCCESS;
  if Result then
  begin
    if (FCurrentKey <> 0) and Relative then S := FCurrentPath + '\' + S;
    ChangeKey(TempKey, S);
  end;
end;

function TRG.GetKeyInfo(var Value: TRegKeyInfo): Boolean;
begin
  FillChar(Value, SizeOf(TRegKeyInfo), 0);
  Result := RegQueryInfoKey(FCurrentKey, nil, nil, nil, @Value.NumSubKeys,
    @Value.MaxSubKeyLen, nil, @Value.NumValues, @Value.MaxValueLen,
    @Value.MaxDataLen, nil, @Value.FileTime) = ERROR_SUCCESS;
  if SysLocale.FarEast and (Win32Platform = VER_PLATFORM_WIN32_NT) then
    with Value do begin
      Inc(MaxSubKeyLen, MaxSubKeyLen);
      Inc(MaxValueLen, MaxValueLen);
    end;
end;

procedure TRG.GetKeyNames(Strings: TStrlist);
var
  Len: DWORD;
  I: Integer;
  Info: TRegKeyInfo;
  S: string;
begin
  if GetKeyInfo(Info) then begin
    SetString(S, nil, Info.MaxSubKeyLen + 1);
    for I := 0 to Info.NumSubKeys - 1 do begin
      Len := Info.MaxSubKeyLen + 1;
      RegEnumKeyEx(FCurrentKey, I, PChar(S), Len, nil, nil, nil, nil);
      Strings.Add(PChar(S));
    end;
  end;
end;


function TRG.GetDataInfo(const ValueName: string; var Value: TRegDataInfo): Boolean;
var
  DataType: Integer;
begin
  FillChar(Value, SizeOf(TRegDataInfo), 0);
  Result := RegQueryValueEx(FCurrentKey, PChar(ValueName), nil, @DataType, nil,
    @Value.DataSize) = ERROR_SUCCESS;
  Value.RegData := DataTypeToRegData(DataType);
end;

function TRG.GetDataSize(const ValueName:string) : Integer;
var
  Info : TRegDataInfo;
begin
  if GetDataInfo(ValueName,Info) then Result:=Info.DataSize else Result:=-1;
end;

function TRG.GetDataType(const ValueName:string) : TRegDataType;
var
  Info: TRegDataInfo;
begin
  if GetDataInfo(ValueName,Info) then Result:=Info.RegData else Result:=rdUnknown;
end;

procedure TRG.WriteString(const Name,Value:string);
begin
  PutData(Name,PChar(Value),Length(Value)+1,rdString);
end;

function TRG.ReadString(const Name:string): string;
var
  Len     : Integer;
  RegData : TRegDataType;
begin
  Len:=GetDataSize(Name);
  if Len>0 then begin
    SetString(Result,nil,Len);
    GetData(Name,PChar(Result),Len,RegData);
    if (RegData=rdString)or(RegData=rdExpandString)then SetLength(Result,StrLen(PChar(Result)));
  end else Result:='';
end;

procedure TRG.WriteInteger(const Name:string;Value:Integer);
begin
  PutData(Name,@Value,SizeOf(Integer),rdInteger);
end;

function TRG.ReadInteger(const Name:string) : Integer;
var
  RegData : TRegDataType;
begin
  GetData(Name,@Result,SizeOf(Integer),RegData);
end;

function TRG.ReadBinaryData(const Name:string;var Buffer;BufSize:Integer) : Integer;
var
  RegData : TRegDataType;
  Info    : TRegDataInfo;
begin
  if GetDataInfo(Name,Info) then begin
    Result:=Info.DataSize;
    RegData:=Info.RegData;
    if ((RegData=rdBinary)or(RegData=rdUnknown))and(Result<=BufSize)then GetData(Name,@Buffer,Result,RegData);
  end else Result:=0;
end;

procedure TRG.PutData(const Name: string; Buffer: Pointer;
  BufSize: Integer; RegData: TRegDataType);
var
  DataType: Integer;
begin
  DataType := RegDataToDataType(RegData);
  RegSetValueEx(FCurrentKey, PChar(Name), 0, DataType, Buffer, BufSize);
end;

function TRG.GetData(const Name: string; Buffer: Pointer;
  BufSize: Integer; var RegData: TRegDataType): Integer;
var
  DataType: Integer;
begin
  DataType := REG_NONE;
  RegQueryValueEx(FCurrentKey, PChar(Name), nil, @DataType, PByte(Buffer), @BufSize);
  Result := BufSize;
  RegData := DataTypeToRegData(DataType);
end;

function TRG.ValueExists(const Name: string): Boolean;
var
  Info: TRegDataInfo;
begin
  Result := GetDataInfo(Name, Info);
end;

function TRG.GetKey(const Key: string): HKEY;
var
  S: string;
  Relative: Boolean;
begin
  S := Key;
  Relative := IsRelative(S);
  Result := 0;
  RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0, FAccess, Result);
end;

function TRG.KeyExists(const Key: string): Boolean;
var
  TempKey: HKEY;
begin
  TempKey := GetKey(Key);
  if TempKey <> 0 then RegCloseKey(TempKey);
  Result := TempKey <> 0;
end;

end.
