(*
/*

CLASS {NATIVE_Configuration|_Delphi_KOL},
NATIVE,
ABSTRACT:

*/
*)

unit NATIVE_Configuration;
{$I EXTERNAL_DEFINES.inc}

interface uses Windows, KOL, AL4;

type
    PConfiguration = ^TConfiguration;
    TConfiguration = object(TObj)
        Key_name: String;
        Read_only: Boolean;
        Can_create: Boolean;
        destructor Destroy; virtual;
    end;

function Create_new_configure(
         Area: Integer; const Path, Name: String;
         Can_write, Can_create: Boolean): Integer;
function Value_string(Handle: Integer; const Name_value, New_value: String;
         Set_new: Boolean): String;
function Binary_get(Handle: Integer; const Name_value: String): String;         
function Value_integer(Handle: Integer; const Name_value: String;
         New_value: Integer; Set_new: Boolean): Integer;
function Value_boolean(Handle: Integer; const Name_value: String;
         New_value: Boolean; Set_new: Boolean): Boolean;
function Value_present(Handle: Integer; const Name_value: String): Boolean;
procedure Value_delete(Handle: Integer; const Name_value: String);
procedure Subkey_delete(Handle: Integer; const Name_subkey: String);
procedure Values_list(Handle: Integer; List: DynAStr);
procedure Subkeys_list(Handle: Integer; List: DynAStr);

implementation

destructor TConfiguration.Destroy;
begin
    Key_name := '';
    inherited;
end;

function starting(const X, Y: String): Boolean;
begin
    Result := (Length(X) >= Length(Y)) and (Length(Y) > 0) and 
        (Copy(X, 1, Length(Y)) = Y);
end;

function create_key(const key_name: String; 
         Read_only: Boolean; Can_create: Boolean): THandle;
var Path: String;
    i: Integer;
    RootKey: DWORD;
begin
    Path := key_name;
    RESULT := KEY_WRITE;
    if starting(path, 'HKEY_CURRENT_USER\') then
        RootKey := HKEY_CURRENT_USER
    else if starting(path, 'HKEY_LOCAL_MACHINE\') then
        RootKey := HKEY_LOCAL_MACHINE
    else if starting(path, 'HKEY_CURRENT_CONFIG\') then
        RootKey := HKEY_CURRENT_CONFIG
    else if starting(path, 'HKEY_CLASSES_ROOT\') then
        RootKey := HKEY_CLASSES_ROOT
    else if starting(path, 'HKEY_PERFORMANCE_DATA\') then
        RootKey := HKEY_PERFORMANCE_DATA
    else if starting(path, 'HKEY_USERS\') then
        RootKey := HKEY_USERS
    else
        Exit;
    for i := 1 to Length(Path) do
    begin
        if Path[i] = '\' then
        begin
            Path := Copy(Path, i+1, MaxInt);
            break;
        end;
    end;
    if Read_only then
        RESULT := RegKeyOpenRead(RootKey, Path)
    else if not Can_create then RESULT := RegKeyOpenWrite(RootKey, Path)
    else RESULT := RegKeyOpenCreate(RootKey, Path);
end;


function Create_new_configure(
         Area: Integer; const Path, Name: String;
         Can_write, Can_create: Boolean): Integer;
var C: PConfiguration;
begin
    new(C, Create);
    C.Key_name := Path;
    if (Area = 1) and not starting(C.Key_name, 'HKEY_') then 
        C.Key_name := 'HKEY_LOCAL_MACHINE\' + C.Key_name
    else if (Area = 0) and not starting(C.Key_name, 'HKEY_') then
        C.Key_name := 'HKEY_CURRENT_USER\Software\' +
        Name + '\' + C.Key_name;
    C.Read_only := not Can_write;
    C.Can_create := Can_create;
    RESULT := Integer(C); 
end;

function Value_string(Handle: Integer; const Name_value, New_value: String;
         Set_new: Boolean): String;
var C: PConfiguration;
    R: THandle;
begin
    RESULT := '';
    C := PConfiguration(Handle);
    R := create_key(C.Key_name, C.Read_only, C.Can_create);
    RESULT := RegKeyGetStr(R, Name_value);
    if not C.Read_only and Set_new then
    begin
        if RegKeyValExists(R, Name_value) or C.Can_create then
           RegKeySetStr(R, Name_value, New_value);
    end;
    RegKeyClose(R);
end;    

function Binary_get(Handle: Integer; const Name_value: String): String;         
var C: PConfiguration;
    R: THandle;
    buf: array[0 .. 4095] of Char;
    sz, i: Integer;
begin
    RESULT := '';
    C := PConfiguration(Handle);
    R := create_key(C.Key_name, true, false);
    sz := 0;
    if RegKeyValExists(R, Name_value) then
       sz := RegKeyGetBinary(R, Name_value, buf, Sizeof(buf));
    RegKeyClose(R);
    if (sz = 0) then Exit;
    SetLength(Result, sz);
    for i := 0 to sz-1 do
        Result[i+1] := buf[i];
end;    

function Value_integer(Handle: Integer; const Name_value: String;
         New_value: Integer; Set_new: Boolean): Integer;
var C: PConfiguration;
    R: THandle;
begin
    RESULT := 0;
    C := PConfiguration(Handle);
    R := create_key(C.Key_name, C.Read_only, C.Can_create);
    RESULT := RegKeyGetDw(R, Name_value);
    if not C.Read_only and Set_new then
    begin
        if RegKeyValExists(R, Name_value) or C.Can_create then
           RegKeySetDw(R, Name_value, New_value);
    end;
    RegKeyClose(R);
end;    

function Value_boolean(Handle: Integer; const Name_value: String;
         New_value: Boolean; Set_new: Boolean): Boolean;
var C: PConfiguration;
    R: THandle;
begin
    RESULT := FALSE;
    C := PConfiguration(Handle);
    R := create_key(C.Key_name, C.Read_only, C.Can_create);
    RESULT := RegKeyGetDw(R, Name_value) <> 0;
    if not C.Read_only and Set_new then
    begin
        if RegKeyValExists(R, Name_value) or C.Can_create then
           RegKeySetDw(R, Name_value, Integer(New_value));
    end;
    RegKeyClose(R);
end;    

function Value_present(Handle: Integer; const Name_value: String): Boolean;
var C: PConfiguration;
    R: THandle;
begin
    C := PConfiguration(Handle);
    R := create_key(C.Key_name, C.Read_only, C.Can_create);
    RESULT := RegKeyValExists(R, Name_value);
    RegKeyClose(R);
end;    

procedure Value_delete(Handle: Integer; const Name_value: String);
var C: PConfiguration;
    R: THandle;
begin
    C := PConfiguration(Handle);
    R := create_key(C.Key_name, C.Read_only, C.Can_create);
    RegKeyDeleteValue(R, Name_value);
    RegKeyClose(R);
end;    

procedure Subkey_delete(Handle: Integer; const Name_subkey: String);
var C: PConfiguration;
    R: THandle;
begin
    C := PConfiguration(Handle);
    R := create_key(C.Key_name, C.Read_only, C.Can_create);
    RegKeyDelete(R, Name_subkey);
    RegKeyClose(R);
end;    

procedure Values_list(Handle: Integer; List: DynAStr);
var C: PConfiguration;
    R: THandle;
    Names: PStrList;
    i: Integer;
begin
    C := PConfiguration(Handle);
    R := create_key(C.Key_name, C.Read_only, C.Can_create);
    Names := NewStrList;
    RegKeyGetValueNames(R, Names);
    List.Clear();
    List.Extend('', Names.Count);
    for i := 0 to Names.Count-1 do
    	List.SetStrings(i, Names.Items[i]);
    Names.Free;
    RegKeyClose(R);
end;    

procedure Subkeys_list(Handle: Integer; List: DynAStr);
var C: PConfiguration;
    R: THandle;
    Names: PStrList;
    i: Integer;
begin
    C := PConfiguration(Handle);
    R := create_key(C.Key_name, C.Read_only, C.Can_create);
    Names := NewStrList;
    RegKeyGetSubKeys(R, Names);
    List.Clear;
    List.Extend('', Names.Count);
    for i := 0 to Names.Count-1 do
    	List.SetStrings(i, Names.Items[i]);
    Names.Free;
    RegKeyClose(R);
end;    

(*
/*
    
CONST STR:
    NATIVE_configure_import = "uses NATIVE_Configuration;"

    NATIVE_new_configure_object = @
    "   RESULT := Create_new_configure("
    "       X_Area, X_Path, X_Name,"
    "       not X_Read, X_can_create);"
    
    NATIVE_release_configure_object = @
    "   if X_Handle <> 0 then"
    "       PConfiguration(X_Handle).Free;"
    "   X_Handle := 0;"
    
    NATIVE_value_string = @
    "   RESULT := Value_string(X_Handle, X_Name, X_New, X_Set);"
    
    NATIVE_value_integer = @
    "   RESULT := Value_integer(X_Handle, X_Name, X_New, X_Set);"
    
    NATIVE_value_boolean = @
    "   RESULT := Value_boolean(X_Handle, X_Name, X_New, X_Set);"
    
    NATIVE_binary_get = @
    "   RESULT := Binary_get(X_Handle, X_Name);"
    
    NATIVE_present_value = @
    "   RESULT := Value_present(X_Handle, X_Name);"
    
    NATIVE_list_values = @
    "   Values_list(X_Handle, X_List);"
    
    NATIVE_list_subkeys = @
    "   Subkeys_list(X_Handle, X_List);"
    
    NATIVE_delete_value = @
    "   Value_delete(X_Handle, X_Name);"
    
    NATIVE_delete_subkey = @
    "   Subkey_delete(X_Handle, X_Name);"

    .
        
*/
*)

end .

(*
/*
END
*/
*)


