unit unitEXRegistry;

interface

uses windows, classes, sysutils, registry;

type

TWalkProc = procedure (const keyName, valueName : string; dataType : DWORD; data : pointer; DataLen : Integer) of object;

TSearchParam = (rsKeys, rsValues, rsData);
TSearchParams = set of TSearchParam;

TSearchNode = class
  fValueNames : TStringList;
  fKeyNames : TStringList;
  fCurrentKey : string;
  fPath: string;
  fValueIDX, fKeyIDX : Integer;
  fRegRoot : HKEY;
  constructor Create (ARegRoot : HKEY; const APath : string);
  destructor Destroy; override;

  procedure LoadKeyNames;
  procedure LoadValueNames;
end;

TExRegistry = class (TRegistry)
private
  fSaveServer : string;
  fExportStrings : TStrings;
  fLastExportKey : string;
  fSearchParams : TSearchParams;
  fSearchString : string;
  fSearchStack : TList;
  fMatchWholeString : boolean;
  fCancelSearch : boolean;
  fLocalRoot : HKEY;
  fValuesSize : Integer;
  procedure ExportProc (const keyName, valueName : string; dataType : DWORD; data : pointer; DataLen : Integer);
  procedure ValuesSizeProc (const keyName, valueName : string; dataType : DWORD; data : pointer; DataLen : Integer);
  procedure ClearSearchStack;

public
  destructor Destroy; override;
  procedure SetRoot (root : HKey; const server : string);
  procedure CopyValueFromReg (const valueName : string; otherReg : TExRegistry; deleteSource : boolean);
  procedure CopyKeyFromReg (const keyName : string; otherReg : TExRegistry; deleteSource : boolean);
  function GetValueType (const valueName : string) : DWORD;
  procedure ReadStrings (const valueName : string; strings : TStrings);
  procedure WriteStrings (const valueName : string; strings : TStrings);
  procedure ExportKey (const fileName : string);
  procedure ImportRegFile (const fileName : string);
  procedure WriteTypedBinaryData (const valueName : string; tp : Integer; var data; size : Integer);
  procedure Walk (walkProc : TWalkProc; valuesRequired : boolean);
  function FindFirst (const data : string; params : TSearchParams; MatchWholeString : boolean; var retPath, retValue : string) : boolean;
  function FindNext (var retPath, retValue : string) : boolean;
  procedure CancelSearch;
  property SearchString : string read fSearchString;
  procedure GetValuesSize (var size : Integer);
end;

EExRegistryException = class (ERegistryException)
private
    fCode: Integer;
    function GetError : string;
public
  constructor CreateLastError (const st : string);
  constructor Create (code : DWORD; const st : string);
  property Code : Integer read fCode;
end;

implementation

{ TExRegistry }

resourcestring
  errUnableToConnect = 'Unable to connect to the registry on %s (%d)';

type
  TRootRec = record
    key : HKEY;
    name : string
  end;

const
  NO_ROOT_KEYS = 7;
  RootKeys : array [0..NO_ROOT_KEYS - 1] of TRootRec = (
    (key : HKEY_CLASSES_ROOT;     name : 'HKEY_CLASSES_ROOT'),
    (key : HKEY_CURRENT_USER;     name : 'HKEY_CURRENT_USER'),
    (key : HKEY_LOCAL_MACHINE;    name : 'HKEY_LOCAL_MACHINE'),
    (key : HKEY_USERS;            name : 'HKEY_USERS'),
    (key : HKEY_PERFORMANCE_DATA; name : 'HKEY_PERFORMANCE_DATA'),
    (key : HKEY_CURRENT_CONFIG;   name : 'HKEY_CURRENT_CONFIG'),
    (key : HKEY_DYN_DATA;         name : 'HKEY_DYN_DATA'));


function RootKeyName (key : HKEY) : string;
var
  i : Integer;
begin
  result := '';
  for i := 0 to NO_ROOT_KEYS - 1 do
    if RootKeys [i].key = key then
    begin
      result := RootKeys [i].name;
      break
    end
end;

function RootKeyVal (const st : string) : HKEY;
var
  i : Integer;
begin
  result := $ffffffff;
  for i := 0 to NO_ROOT_KEYS - 1 do
    if RootKeys [i].name = st then
    begin
      result := RootKeys [i].key;
      break
    end
end;


procedure TExRegistry.CancelSearch;
begin
  fCancelSearch := True;
end;

procedure TExRegistry.ClearSearchStack;
var
  i : Integer;
begin
  if Assigned (fSearchStack) then
  begin
    for i := 0 to fSearchStack.Count - 1 do
      TSearchNode (fSearchStack [i]).Free;
    fSearchStack.Free;
    fSearchStack := Nil
  end
end;

procedure TExRegistry.CopyKeyFromReg(const keyName: string;
  otherReg: TExRegistry; deleteSource : boolean);
var
  i : Integer;
  values : TStringList;
  sourceReg : TExRegistry;
  destReg : TExRegistry;
begin
  sourceReg := TExRegistry.Create;
  destReg := TExRegistry.Create;
  values := TStringList.Create;
  try
    sourceReg.RootKey := otherReg.CurrentKey;
    if deleteSource then
      sourceReg.OpenKey (keyName, False)
    else
      sourceReg.OpenKeyReadOnly (keyName);
    sourceReg.GetValueNames (values);

    destReg.RootKey := CurrentKey;
    if destReg.OpenKey (keyName, True) then
    begin
      for i := 0 to values.Count - 1 do
        destReg.CopyValueFromReg (values [i], sourceReg, deleteSource);

      sourceReg.GetKeyNames (values);
      for i := 0 to values.Count - 1 do
        destReg.CopyKeyFromReg (values [i], sourceReg, deleteSource);

      if DeleteSource then
        if not otherReg.DeleteKey (keyName) then
          Raise ERegistryException.Create ('Unable to delete moved key')
    end
    else
      raise ERegistryException.Create ('Unable to open destination');
  finally
    values.Free;
    destReg.Free;
    sourceReg.Free
  end
end;

procedure TExRegistry.CopyValueFromReg(const valueName: string;
  otherReg: TExRegistry; deleteSource : boolean);
var
  buffer : PByte;
  BufSize : DWORD;
  DataType : DWORD;
begin
  BufSize := 65536;
  GetMem (buffer, BufSize);
  try
    DataType := REG_NONE;

    SetLastError (RegQueryValueEx(otherReg.CurrentKey, PChar(valueName), nil, @DataType, Buffer,
      @BufSize));

     if GetLastError <> ERROR_SUCCESS then
      raise EExRegistryException.CreateLastError ('Unable to copy value');

    SetLastError (RegSetValueEx (CurrentKey, PChar (valueName), 0, DataType, buffer, BufSize));
    if GetLastError <> ERROR_SUCCESS then
      raise EExRegistryException.CreateLastError ('Unable to copy value');

    if deleteSource then
      if not otherReg.DeleteValue (valueName) then
        raise ERegistryException.Create ('Unable to delete moved value')
  finally
    FreeMem (buffer)
  end
end;


destructor TExRegistry.Destroy;
begin
  ClearSearchStack;
  inherited Destroy
end;

procedure TExRegistry.ExportKey(const fileName: string);
begin
  fExportStrings := TStringList.Create;
  fExportStrings.Add ('REGEDIT4');
  try
    fLastExportKey := '';
    Walk (ExportProc, True);
    fExportStrings.Add ('');
  finally
    fExportStrings.SaveToFile (fileName);
    fExportStrings.Free;
  end
end;

procedure TExRegistry.ExportProc(const keyName, valueName: string;
  dataType: DWORD; data: pointer; DataLen: Integer);

var
  st : string;
  st1 : string;
  j : Integer;
  localRoot : HKey;

  function MakeCStringConst (s : string) : string;
  var
    i : Integer;
  begin
    result := '';
    for i := 1 to Length (s) do
    begin
      if s [i] in ['\', '"'] then
        result := result + '\';
      result := result + s [i]
    end
  end;

begin
  localRoot := fLocalRoot;
  if localRoot = 0 then
    localRoot := RootKey;

  if fLastExportKey <> keyName then
  begin
    fExportStrings.Add ('');
    fExportStrings.Add (Format ('[%s\%s]', [rootKeyName (localRoot), keyName]));

    fLastExportKey := keyName;
  end;

  if dataLen <> 0 then
  begin
    if valueName = '' then
      st := '@='
    else
      st := Format ('"%s"=', [MakeCStringConst (valueName)]);

    case dataType of
      REG_DWORD :
      begin
        st1 := LowerCase (Format ('%8.8x', [PDWORD (data)^]));
        st := st + format ('dword:%s', [st1])
      end;

      REG_SZ    :
        begin
          PChar (data) [dataLen] := #0;
          st := st + format ('"%s"', [MakeCStringConst (PChar (data))]);
        end;

      else
      begin
        if dataType = REG_BINARY then
          st := st + 'hex:'
        else
          st := st + format ('hex(%d):', [dataType]);
        for j := 0 to dataLen - 1 do
        begin
          st1 := LowerCase (format ('%02.2x', [Byte (PChar (data) [j])]));
          if j < dataLen - 1 then
            st1 := st1 + ',';

          if Length (st) + Length (st1) >= 77 then
          begin
            fExportStrings.Add (st + st1 + '\');
            st := '  ';
          end
          else
            st := st + st1;
        end
      end
    end;
    fExportStrings.Add (st);
  end
end;

function TExRegistry.FindFirst(const data: string; params: TSearchParams; MatchWholeString : boolean;
  var retPath, retValue: string): boolean;
var
  path, nPath, keyName : string;
  p : Integer;
  n : TSearchNode;
begin
  ClearSearchStack;

  fSearchStack := TList.Create;
  path := currentPath;


  nPath := '';
  repeat
    p := Pos ('\', path);
    if p > 0 then
    begin
      nPath := nPath + '\' + Copy (path, 1, p - 1);
      path := Copy (path, p + 1, MaxInt);
      n := TSearchNode.Create (RootKey, nPath);
      n.LoadKeyNames;
      p := Pos ('\', path);
      if p > 0 then
        keyName := Copy (path, 1, p - 1)
      else
        keyName := path;

      n.fKeyIDX := n.fKeyNames.IndexOf (keyName);

      fSearchStack.Add (n);
    end
  until p = 0;

  n := TSearchNode.Create (RootKey, nPath + '\' + path);
  fSearchStack.Add (n);

  fSearchString := UpperCase (data);
  fSearchParams := params;
  fMatchWholeString := MatchWholeString;
  result := FindNext (retPath, retValue);
end;

function TExRegistry.FindNext(var retPath, retValue: string): boolean;
var
  n : TSearchNode;
  found : boolean;
  k : string;
  msg : TMsg;
begin
  found := False;
  fCancelSearch := False;
  while (not found) and (not fCancelSearch) and (fSearchStack.Count > 0) do
  begin
    while PeekMessage (msg, 0, 0, 0, PM_REMOVE) do
    begin
      TranslateMessage (msg);
      DispatchMessage (msg)
    end;

    n := TSearchNode (fSearchStack [fSearchStack.Count - 1]);
    if rsValues in fSearchParams then
    begin
      n.LoadValueNames;
      with n do
        if fValueIdx < fValueNames.Count then
        repeat
          Inc (fValueIdx);
          if fValueIdx < fValueNames.Count then
          begin
            if fMatchWholeString then
              found := fSearchString = fValueNames [fValueIdx]
            else
              found := Pos (fSearchString, fValueNames [fValueIdx]) > 0
          end
        until fCancelSearch or found or (fValueIdx = fValueNames.Count)
    end;

    if not fCancelSearch and not found then
    begin
      n.LoadKeyNames;
      with n do
        if fKeyIdx < fKeyNames.Count then
        begin
          Inc (fKeyIdx);
          if fKeyIdx < fKeyNames.Count then
          begin

            if rsKeys in fSearchParams then
              if fMatchWholeString then
                found := fSearchString = fKeyNames [fKeyIdx]
              else
                found := Pos (fSearchString, fKeyNames [fKeyIdx]) > 0;

            if not found then
            begin
              if n.fPath = '\' then
                k := '\' + fKeyNames [fKeyIdx]
              else
                k := n.fPath + '\' + fKeyNames [fKeyIdx];

              fSearchStack.Add (TSearchNode.Create (RootKey, k));

              continue
            end
          end
      end
    end;

    if fCancelSearch then
      Break;

    if not found then
    begin
      n.Free;
      fSearchStack.Delete (fSearchStack.Count - 1)
    end
    else
    begin
      retPath := n.fPath;
      if n.fKeyIdx > -1 then
        retPath := retPath + '\' + n.fKeyNames [n.fKeyIdx];

      if rsValues in fSearchParams then
        if (n.fValueIdx > -1) and (n.fValueIdx < n.fValueNames.Count) then
          retValue := n.fValueNames [n.fValueIdx]
        else
          retValue := '';
    end
  end;
  result := found
end;

procedure TExRegistry.GetValuesSize(var size: Integer);
begin
  fValuesSize := 0;
  Walk (ValuesSizeProc, False);
  if fValuesSize = 0 then
    fValuesSize := -1;
  size := fValuesSize
end;

function TExRegistry.GetValueType(const valueName: string): DWORD;
var
  valueType : DWORD;
begin
  SetLastError (RegQueryValueEx (CurrentKey, PChar (valueName), Nil, @valueType, Nil, Nil));
  if GetLastError = ERROR_SUCCESS then
    result := valueType
  else
    raise EExRegistryException.CreateLastError ('Unable to get value type');
end;

procedure TExRegistry.ImportRegFile(const fileName: string);
var
  strings : TStrings;
  st : string;
  i : Integer;

  procedure SyntaxError;
  begin
    raise Exception.CreateFmt ('Syntax error in reg file %s at line %d', [fileName, i])
  end;

  procedure CreateNewKey;
  var
    s : string;
    p : Integer;
    r : HKEY;
  begin
    Delete (st, 1, 1);
    if st [Length (st)] <> ']' then
      SyntaxError;

    Delete (st, Length (st), 1);

    p := pos ('\', st);
    if p = 0 then
      SyntaxError;
    s := Copy (st, 1, p - 1);
    st := Copy (st, p + 1, MaxInt);