(*
/*

CLASS {NATIVE_Configuration|_Delphi_VCL}, NATIVE,
ABSTRACT:

NATIVE: "///COPY AL4_options.inc" .
*/
*)

unit NATIVE_Configuration;

interface

uses {$IFDEF LINUX}
		Registry,
	 {$ELSE WINDOWS} 
		Windows, Registry, SysUtils,
	 {$ENDIF}
	 AL4, Classes ;
	 
{$I AL4_options.inc}

type
    TConfiguration = class
        Key_name: String;
        Read_only: Boolean;
        Can_create: Boolean;
        destructor Destroy; override;
    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);
procedure Release_config(X_Handle: Integer);

{$IFDEF FPC}
type THackRegistry = class(TRegistry)
	 end;
{$ENDIF}

implementation

{$IFDEF USE_LISTS_OF_DESCRIPTORS} //////////////////////////////////////////////
var All_config: TList;

function alloc_config(C: TConfiguration): Integer;
begin
	if All_config = nil then All_config := TList.Create;
	Result := All_config.IndexOf(nil);
	if Result < 0 then begin
		Result := All_config.Count;
		All_config.Add(C);
	end
		else
	All_config[Result] := C;
end;
{$ENDIF} ///////////////////////////////////////////////////////////////////////

destructor TConfiguration.Destroy;
{$IFDEF USE_LISTS_OF_DESCRIPTORS}
var i: Integer;
{$ENDIF}
begin
	{$IFDEF USE_LISTS_OF_DESCRIPTORS}
	i := All_config.IndexOf(Self);
	if (i >= 0) then All_config[i] := nil;
	{$ENDIF}
	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;

var last_create_key: String;

function create_key(
const key_name: String; Can_create, Read_only: Boolean): TRegistry;
var Path: String;
    i: Integer;
begin
    Path := key_name;
    i := KEY_WRITE;
    if Read_only then i := KEY_READ;
    RESULT := TRegistry.Create(i);
    if starting(path, 'HKEY_CURRENT_USER\') then
        RESULT.RootKey := HKEY_CURRENT_USER
    else if starting(path, 'HKEY_LOCAL_MACHINE\') then
        RESULT.RootKey := HKEY_LOCAL_MACHINE
    else if starting(path, 'HKEY_CURRENT_CONFIG\') then
        RESULT.RootKey := HKEY_CURRENT_CONFIG
    else if starting(path, 'HKEY_CLASSES_ROOT\') then
        RESULT.RootKey := HKEY_CLASSES_ROOT
    else if starting(path, 'HKEY_PERFORMANCE_DATA\') then
        RESULT.RootKey := HKEY_PERFORMANCE_DATA
    else if starting(path, 'HKEY_USERS\') then
        RESULT.RootKey := HKEY_USERS
    else
    begin
        RESULT.Free;
        RESULT := nil;
        Exit;
    end;

    for i := 1 to Length(Path) do
    begin
        if Path[i] = '\' then
        begin
            Path := Copy(Path, i+1, MaxInt);
            break;
        end;
    end;

    if not RESULT.OpenKey(Path, Can_create) then
    begin
        RESULT.Free;
        RESULT := nil;
    end
    else last_create_key := key_name;
end;


function Create_new_configure(
         Area: Integer; const Path, Name: String;
         Can_write, Can_create: Boolean): Integer;
var C: TConfiguration;
begin
    C := TConfiguration.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;
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	Result := alloc_config(C);
    {$ELSE}
    	RESULT := Integer(C);
    {$ENDIF} 
end;

function Value_string(Handle: Integer; const Name_value, New_value: String;
         Set_new: Boolean): String;
var C: TConfiguration;
    R: TRegistry;
    {$IFDEF FPC}
    	{$IFNDEF LINUX}
	    temp: String;
	    bytes: PWideChar;
	    size: DWORD;
	    W, NW: WideString;
	    RD : DWord;
	    {$ENDIF}
    {$ENDIF}
begin
    RESULT := '';
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	C := TConfiguration(All_config[Handle]);
    {$ELSE}
    	C := TConfiguration(Handle);
    {$ENDIF}
    R := create_key(C.Key_name, C.Can_create, not Set_new);
    if R <> nil then
    try
        try 
        	if R.ValueExists(Name_value) then
        	begin
            {$IFDEF FPC}
            	{$IFNDEF LINUX}
        		NW := WideString(Name_value);
        		RD := REG_SZ;
        		if (0 = RegQueryValueExW(R.CurrentKey,PWideChar(NW),Nil,
                  @RD,nil,lpdword(@size)))
        			and (size  <> 0) then
        		begin
	        		GetMem(bytes, (size + 1) * Sizeof(WideChar));
	        		try
		        		bytes[size] := #0; 
		        		
		        		if 0 <> RegQueryValueExW(R.CurrentKey,
		        			PWideChar(NW),Nil,@RD,PByte(bytes),
		        			lpdword(@size)) then Exit;
	
		    			W := bytes;
	                    //writeln(Name_value + ':');
	                    //writeln(String(W) + '  -->');
		            	
		     			size := WideCharToMultiByte(CP_UTF8, 0, PWideChar(W),
		            		Length(W), nil, 0, nil, nil);
		            		
			            if size <> 0 then
			            begin
				            SetLength(RESULT, size);
				            
			     			WideCharToMultiByte(CP_UTF8, 0, PWideChar(W),
			            		Length(W), Pointer(PChar(RESULT)),
			            		size, nil, nil);
		     			end;
	                    //writeln(RESULT); writeln('');
	        		finally
	        			FreeMem(bytes);
	        		end;
        		end;
        		{$define string_obtained_ok}
        		{$ENDIF}
            {$ENDIF}
            {$IFNDEF string_obtained_ok}
            	RESULT := R.ReadString(Name_value);
            {$ENDIF}
            end;
        except
        end;
        if not C.Read_only and Set_new then
        begin
        	{$IFDEF FPC}
        		{$IFNDEF LINUX}
        		W := WideString(New_value);
        		NW := WideString(Name_value);
        		RegSetValueExW(R.CurrentKey, PWideChar(NW), 0,
        			REG_SZ, PWideChar(W), Length(W) * Sizeof(WideChar));
        		{$define written_ok}
        		{$ENDIF}
        		//TODO
        	{$ENDIF}
        	{$IFnDEF written_ok}
	            if R.ValueExists(Name_value) or C.Can_create then
	            R.WriteString(Name_value, New_value);
            {$ENDIF}
        end;
    finally
    	R.CloseKey();
        R.Free;
    end;
end;    

function Binary_get(Handle: Integer; const Name_value: String): String;
var C: TConfiguration;
    R: TRegistry;
    buf: array[0 .. 4095] of Char;
    sz, i: Integer;
begin
    RESULT := '';
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	C := TConfiguration(All_config[Handle]);
    {$ELSE}
    	C := TConfiguration(Handle);
    {$ENDIF}
    R := create_key(C.Key_name, false, true);
    if R <> nil then
    try
        try 
            sz := R.ReadBinaryData(Name_value, buf, Sizeof(buf));
            SetLength(Result, sz);
            for i := 0 to sz-1 do
                Result[i+1] := buf[i];
        except
        end;
    finally
    	R.CloseKey();
        R.Free;
    end;
end;    

function Value_integer(Handle: Integer; const Name_value: String;
         New_value: Integer; Set_new: Boolean): Integer;
var C: TConfiguration;
    R: TRegistry;
begin
    RESULT := 0;
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	C := TConfiguration(All_config[Handle]);
    {$ELSE}
    	C := TConfiguration(Handle);
    {$ENDIF}
    R := create_key(C.Key_name, C.Can_create, not Set_new);
    if R <> nil then
    try
        try
        	if R.ValueExists(Name_value) then
               RESULT := R.ReadInteger(Name_value);
        except
        end;
        if not C.Read_only and Set_new then
        begin
            if R.ValueExists(Name_value) or C.Can_create then
            R.WriteInteger(Name_value, New_value);
        end;
    finally
    	R.CloseKey();
        R.Free;
    end;
end;    

function Value_boolean(Handle: Integer; const Name_value: String;
         New_value: Boolean; Set_new: Boolean): Boolean;
var C: TConfiguration;
    R: TRegistry;
begin
    RESULt := FALSE;
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	C := TConfiguration(All_config[Handle]);
    {$ELSE}
    	C := TConfiguration(Handle);
    {$ENDIF}
    R := create_key(C.Key_name, C.Can_create, not Set_new);
    if R <> nil then
    try
        try
        	if R.ValueExists(Name_value) then
        	   RESULT := R.ReadBool(Name_value);
        except
        end;
        if not C.Read_only and Set_new then
        begin
            if R.ValueExists(Name_value) or C.Can_create then
            R.WriteBool(Name_value, New_value);
        end;
    finally
    	R.CloseKey();
        R.Free;
    end;
end;    

function Value_present(Handle: Integer; const Name_value: String): Boolean;
var C: TConfiguration;
    R: TRegistry;
begin
    RESULT := FALSE;
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	C := TConfiguration(All_config[Handle]);
    {$ELSE}
    	C := TConfiguration(Handle);
    {$ENDIF}
    R := create_key(C.Key_name, C.Can_create, true);
    if R <> nil then
    try
        try
            RESULT := R.ValueExists(Name_value);
        except
        end;
    finally
    	R.CloseKey();
        R.Free;
    end;
end;    

procedure Value_delete(Handle: Integer; const Name_value: String);
var C: TConfiguration;
    R: TRegistry;
begin
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	C := TConfiguration(All_config[Handle]);
    {$ELSE}
    	C := TConfiguration(Handle);
    {$ENDIF}
    R := create_key(C.Key_name, C.Can_create, false);
    if R <> nil then
    try
        if not C.Read_only then
            try
                R.DeleteValue(Name_value);
            except
            end;
    finally
    	R.CloseKey();
        R.Free;
    end;
end;    

procedure Subkey_delete(Handle: Integer; const Name_subkey: String);
var C: TConfiguration;
    R: TRegistry;
begin
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	C := TConfiguration(All_config[Handle]);
    {$ELSE}
    	C := TConfiguration(Handle);
    {$ENDIF}
    R := create_key(C.Key_name, C.Can_create, false);
    if R <> nil then
    try
        R.DeleteKey(Name_subkey);
    finally
    	R.CloseKey();
        R.Free;
    end;
end;    

procedure Values_list(Handle: Integer; List: DynAStr);
var C: TConfiguration;
    R: TRegistry;
begin
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	C := TConfiguration(All_config[Handle]);
    {$ELSE}
    	C := TConfiguration(Handle);
    {$ENDIF}
    R := create_key(C.Key_name, C.Can_create, true);
    if R <> nil then
    try
        List.Clear;
        R.GetValueNames(DynAStr(List).List);
    finally
    	R.CloseKey();
        R.Free;
    end;
end;    

procedure Subkeys_list(Handle: Integer; List: DynAStr);
var C: TConfiguration;
    R: TRegistry;
begin
    {$IFDEF USE_LISTS_OF_DESCRIPTORS}
    	C := TConfiguration(All_config[Handle]);
    {$ELSE}
    	C := TConfiguration(Handle);
    {$ENDIF}
    R := create_key(C.Key_name, C.Can_create, true);
    if R <> nil then
    try
        List.Clear;
        R.GetKeyNames(DynAStr(List).List);
    finally
    	R.CloseKey();
        R.Free;
    end;
end;    

procedure Release_config(X_Handle: Integer);
var C: TConfiguration;
begin
     {$IFDEF USE_LISTS_OF_DESCRIPTORS}
     	C := TConfiguration(All_config[X_Handle]);
     	All_config[X_Handle] := nil;
     {$ELSE}
     	C := TConfiguration(X_Handle);
   	 {$ENDIF}
        C.Free;
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 = @
    "	Release_config(X_Handle);"
    
    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.
