434 lines
12 KiB
Ada
434 lines
12 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- G N A T . R E G I S T R Y --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- --
|
|
-- Copyright (C) 2001 Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
-- for more details. You should have received a copy of the GNU General --
|
|
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
|
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
|
-- MA 02111-1307, USA. --
|
|
-- --
|
|
-- As a special exception, if other files instantiate generics from this --
|
|
-- unit, or you link this unit with other files to produce an executable, --
|
|
-- this unit does not by itself cause the resulting executable to be --
|
|
-- covered by the GNU General Public License. This exception does not --
|
|
-- however invalidate any other reasons why the executable file might be --
|
|
-- covered by the GNU Public License. --
|
|
-- --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Ada.Exceptions;
|
|
with Interfaces.C;
|
|
with System;
|
|
|
|
package body GNAT.Registry is
|
|
|
|
use Ada;
|
|
use System;
|
|
|
|
------------------------------
|
|
-- Binding to the Win32 API --
|
|
------------------------------
|
|
|
|
subtype LONG is Interfaces.C.long;
|
|
subtype ULONG is Interfaces.C.unsigned_long;
|
|
subtype DWORD is ULONG;
|
|
|
|
type PULONG is access all ULONG;
|
|
subtype PDWORD is PULONG;
|
|
subtype LPDWORD is PDWORD;
|
|
|
|
subtype Error_Code is LONG;
|
|
|
|
subtype REGSAM is LONG;
|
|
|
|
type PHKEY is access all HKEY;
|
|
|
|
ERROR_SUCCESS : constant Error_Code := 0;
|
|
|
|
REG_SZ : constant := 1;
|
|
|
|
function RegCloseKey (Key : HKEY) return LONG;
|
|
pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
|
|
|
|
function RegCreateKeyEx
|
|
(Key : HKEY;
|
|
lpSubKey : Address;
|
|
Reserved : DWORD;
|
|
lpClass : Address;
|
|
dwOptions : DWORD;
|
|
samDesired : REGSAM;
|
|
lpSecurityAttributes : Address;
|
|
phkResult : PHKEY;
|
|
lpdwDisposition : LPDWORD)
|
|
return LONG;
|
|
pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
|
|
|
|
function RegDeleteKey
|
|
(Key : HKEY;
|
|
lpSubKey : Address)
|
|
return LONG;
|
|
pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
|
|
|
|
function RegDeleteValue
|
|
(Key : HKEY;
|
|
lpValueName : Address)
|
|
return LONG;
|
|
pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
|
|
|
|
function RegEnumValue
|
|
(Key : HKEY;
|
|
dwIndex : DWORD;
|
|
lpValueName : Address;
|
|
lpcbValueName : LPDWORD;
|
|
lpReserved : LPDWORD;
|
|
lpType : LPDWORD;
|
|
lpData : Address;
|
|
lpcbData : LPDWORD)
|
|
return LONG;
|
|
pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
|
|
|
|
function RegOpenKeyEx
|
|
(Key : HKEY;
|
|
lpSubKey : Address;
|
|
ulOptions : DWORD;
|
|
samDesired : REGSAM;
|
|
phkResult : PHKEY)
|
|
return LONG;
|
|
pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
|
|
|
|
function RegQueryValueEx
|
|
(Key : HKEY;
|
|
lpValueName : Address;
|
|
lpReserved : LPDWORD;
|
|
lpType : LPDWORD;
|
|
lpData : Address;
|
|
lpcbData : LPDWORD)
|
|
return LONG;
|
|
pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
|
|
|
|
function RegSetValueEx
|
|
(Key : HKEY;
|
|
lpValueName : Address;
|
|
Reserved : DWORD;
|
|
dwType : DWORD;
|
|
lpData : Address;
|
|
cbData : DWORD)
|
|
return LONG;
|
|
pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
|
|
|
|
-----------------------
|
|
-- Local Subprograms --
|
|
-----------------------
|
|
|
|
function To_C_Mode (Mode : Key_Mode) return REGSAM;
|
|
-- Returns the Win32 mode value for the Key_Mode value.
|
|
|
|
procedure Check_Result (Result : LONG; Message : String);
|
|
-- Checks value Result and raise the exception Registry_Error if it is not
|
|
-- equal to ERROR_SUCCESS. Message and the error value (Result) is added
|
|
-- to the exception message.
|
|
|
|
------------------
|
|
-- Check_Result --
|
|
------------------
|
|
|
|
procedure Check_Result (Result : LONG; Message : String) is
|
|
use type LONG;
|
|
|
|
begin
|
|
if Result /= ERROR_SUCCESS then
|
|
Exceptions.Raise_Exception
|
|
(Registry_Error'Identity,
|
|
Message & " (" & LONG'Image (Result) & ')');
|
|
end if;
|
|
end Check_Result;
|
|
|
|
---------------
|
|
-- Close_Key --
|
|
---------------
|
|
|
|
procedure Close_Key (Key : HKEY) is
|
|
Result : LONG;
|
|
|
|
begin
|
|
Result := RegCloseKey (Key);
|
|
Check_Result (Result, "Close_Key");
|
|
end Close_Key;
|
|
|
|
----------------
|
|
-- Create_Key --
|
|
----------------
|
|
|
|
function Create_Key
|
|
(From_Key : HKEY;
|
|
Sub_Key : String;
|
|
Mode : Key_Mode := Read_Write)
|
|
return HKEY
|
|
is
|
|
use type REGSAM;
|
|
use type DWORD;
|
|
|
|
REG_OPTION_NON_VOLATILE : constant := 16#0#;
|
|
|
|
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
|
|
C_Class : constant String := "" & ASCII.Nul;
|
|
C_Mode : constant REGSAM := To_C_Mode (Mode);
|
|
|
|
New_Key : aliased HKEY;
|
|
Result : LONG;
|
|
Dispos : aliased DWORD;
|
|
|
|
begin
|
|
Result := RegCreateKeyEx
|
|
(From_Key,
|
|
C_Sub_Key (C_Sub_Key'First)'Address,
|
|
0,
|
|
C_Class (C_Class'First)'Address,
|
|
REG_OPTION_NON_VOLATILE,
|
|
C_Mode,
|
|
Null_Address,
|
|
New_Key'Unchecked_Access,
|
|
Dispos'Unchecked_Access);
|
|
|
|
Check_Result (Result, "Create_Key " & Sub_Key);
|
|
return New_Key;
|
|
end Create_Key;
|
|
|
|
----------------
|
|
-- Delete_Key --
|
|
----------------
|
|
|
|
procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
|
|
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
|
|
Result : LONG;
|
|
|
|
begin
|
|
Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
|
|
Check_Result (Result, "Delete_Key " & Sub_Key);
|
|
end Delete_Key;
|
|
|
|
------------------
|
|
-- Delete_Value --
|
|
------------------
|
|
|
|
procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
|
|
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
|
|
Result : LONG;
|
|
|
|
begin
|
|
Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
|
|
Check_Result (Result, "Delete_Value " & Sub_Key);
|
|
end Delete_Value;
|
|
|
|
-------------------------
|
|
-- For_Every_Key_Value --
|
|
-------------------------
|
|
|
|
procedure For_Every_Key_Value (From_Key : HKEY) is
|
|
use type LONG;
|
|
use type ULONG;
|
|
|
|
Index : ULONG := 0;
|
|
Result : LONG;
|
|
|
|
Sub_Key : String (1 .. 100);
|
|
pragma Warnings (Off, Sub_Key);
|
|
|
|
Value : String (1 .. 100);
|
|
pragma Warnings (Off, Value);
|
|
|
|
Size_Sub_Key : aliased ULONG;
|
|
Size_Value : aliased ULONG;
|
|
Type_Sub_Key : aliased DWORD;
|
|
|
|
Quit : Boolean;
|
|
|
|
begin
|
|
loop
|
|
Size_Sub_Key := Sub_Key'Length;
|
|
Size_Value := Value'Length;
|
|
|
|
Result := RegEnumValue
|
|
(From_Key, Index,
|
|
Sub_Key (1)'Address,
|
|
Size_Sub_Key'Unchecked_Access,
|
|
null,
|
|
Type_Sub_Key'Unchecked_Access,
|
|
Value (1)'Address,
|
|
Size_Value'Unchecked_Access);
|
|
|
|
exit when not (Result = ERROR_SUCCESS);
|
|
|
|
if Type_Sub_Key = REG_SZ then
|
|
Quit := False;
|
|
|
|
Action (Natural (Index) + 1,
|
|
Sub_Key (1 .. Integer (Size_Sub_Key)),
|
|
Value (1 .. Integer (Size_Value) - 1),
|
|
Quit);
|
|
|
|
exit when Quit;
|
|
|
|
Index := Index + 1;
|
|
end if;
|
|
|
|
end loop;
|
|
end For_Every_Key_Value;
|
|
|
|
----------------
|
|
-- Key_Exists --
|
|
----------------
|
|
|
|
function Key_Exists
|
|
(From_Key : HKEY;
|
|
Sub_Key : String)
|
|
return Boolean
|
|
is
|
|
New_Key : HKEY;
|
|
|
|
begin
|
|
New_Key := Open_Key (From_Key, Sub_Key);
|
|
Close_Key (New_Key);
|
|
|
|
-- We have been able to open the key so it exists
|
|
|
|
return True;
|
|
|
|
exception
|
|
when Registry_Error =>
|
|
|
|
-- An error occurred, the key was not found
|
|
|
|
return False;
|
|
end Key_Exists;
|
|
|
|
--------------
|
|
-- Open_Key --
|
|
--------------
|
|
|
|
function Open_Key
|
|
(From_Key : HKEY;
|
|
Sub_Key : String;
|
|
Mode : Key_Mode := Read_Only)
|
|
return HKEY
|
|
is
|
|
use type REGSAM;
|
|
|
|
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
|
|
C_Mode : constant REGSAM := To_C_Mode (Mode);
|
|
|
|
New_Key : aliased HKEY;
|
|
Result : LONG;
|
|
|
|
begin
|
|
Result := RegOpenKeyEx
|
|
(From_Key,
|
|
C_Sub_Key (C_Sub_Key'First)'Address,
|
|
0,
|
|
C_Mode,
|
|
New_Key'Unchecked_Access);
|
|
|
|
Check_Result (Result, "Open_Key " & Sub_Key);
|
|
return New_Key;
|
|
end Open_Key;
|
|
|
|
-----------------
|
|
-- Query_Value --
|
|
-----------------
|
|
|
|
function Query_Value
|
|
(From_Key : HKEY;
|
|
Sub_Key : String)
|
|
return String
|
|
is
|
|
use type LONG;
|
|
use type ULONG;
|
|
|
|
Value : String (1 .. 100);
|
|
pragma Warnings (Off, Value);
|
|
|
|
Size_Value : aliased ULONG;
|
|
Type_Value : aliased DWORD;
|
|
|
|
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
|
|
Result : LONG;
|
|
|
|
begin
|
|
Size_Value := Value'Length;
|
|
|
|
Result := RegQueryValueEx
|
|
(From_Key,
|
|
C_Sub_Key (C_Sub_Key'First)'Address,
|
|
null,
|
|
Type_Value'Unchecked_Access,
|
|
Value (Value'First)'Address,
|
|
Size_Value'Unchecked_Access);
|
|
|
|
Check_Result (Result, "Query_Value " & Sub_Key & " key");
|
|
|
|
return Value (1 .. Integer (Size_Value - 1));
|
|
end Query_Value;
|
|
|
|
---------------
|
|
-- Set_Value --
|
|
---------------
|
|
|
|
procedure Set_Value
|
|
(From_Key : HKEY;
|
|
Sub_Key : String;
|
|
Value : String)
|
|
is
|
|
C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
|
|
C_Value : constant String := Value & ASCII.Nul;
|
|
|
|
Result : LONG;
|
|
|
|
begin
|
|
Result := RegSetValueEx
|
|
(From_Key,
|
|
C_Sub_Key (C_Sub_Key'First)'Address,
|
|
0,
|
|
REG_SZ,
|
|
C_Value (C_Value'First)'Address,
|
|
C_Value'Length);
|
|
|
|
Check_Result (Result, "Set_Value " & Sub_Key & " key");
|
|
end Set_Value;
|
|
|
|
---------------
|
|
-- To_C_Mode --
|
|
---------------
|
|
|
|
function To_C_Mode (Mode : Key_Mode) return REGSAM is
|
|
use type REGSAM;
|
|
|
|
KEY_READ : constant := 16#20019#;
|
|
KEY_WRITE : constant := 16#20006#;
|
|
|
|
begin
|
|
case Mode is
|
|
when Read_Only =>
|
|
return KEY_READ;
|
|
|
|
when Read_Write =>
|
|
return KEY_READ + KEY_WRITE;
|
|
end case;
|
|
end To_C_Mode;
|
|
|
|
end GNAT.Registry;
|