| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G N A T . R E G I S T R Y -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2014, 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 3, 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. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Interfaces.C; |
| with System; |
| with GNAT.Directory_Operations; |
| |
| package body GNAT.Registry is |
| |
| 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; |
| REG_EXPAND_SZ : constant := 2; |
| |
| 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"); |
| |
| function RegEnumKey |
| (Key : HKEY; |
| dwIndex : DWORD; |
| lpName : Address; |
| cchName : DWORD) return LONG; |
| pragma Import (Stdcall, RegEnumKey, "RegEnumKeyA"); |
| |
| --------------------- |
| -- Local Constants -- |
| --------------------- |
| |
| Max_Key_Size : constant := 1_024; |
| -- Maximum number of characters for a registry key |
| |
| Max_Value_Size : constant := 2_048; |
| -- Maximum number of characters for a key's value |
| |
| ----------------------- |
| -- 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 |
| raise Registry_Error with |
| 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 -- |
| ------------------- |
| |
| procedure For_Every_Key |
| (From_Key : HKEY; |
| Recursive : Boolean := False) |
| is |
| procedure Recursive_For_Every_Key |
| (From_Key : HKEY; |
| Recursive : Boolean := False; |
| Quit : in out Boolean); |
| |
| ----------------------------- |
| -- Recursive_For_Every_Key -- |
| ----------------------------- |
| |
| procedure Recursive_For_Every_Key |
| (From_Key : HKEY; |
| Recursive : Boolean := False; |
| Quit : in out Boolean) |
| is |
| use type LONG; |
| use type ULONG; |
| |
| Index : ULONG := 0; |
| Result : LONG; |
| |
| Sub_Key : Interfaces.C.char_array (1 .. Max_Key_Size); |
| pragma Warnings (Off, Sub_Key); |
| |
| Size_Sub_Key : aliased ULONG; |
| Sub_Hkey : HKEY; |
| |
| function Current_Name return String; |
| |
| ------------------ |
| -- Current_Name -- |
| ------------------ |
| |
| function Current_Name return String is |
| begin |
| return Interfaces.C.To_Ada (Sub_Key); |
| end Current_Name; |
| |
| -- Start of processing for Recursive_For_Every_Key |
| |
| begin |
| loop |
| Size_Sub_Key := Sub_Key'Length; |
| |
| Result := |
| RegEnumKey |
| (From_Key, Index, Sub_Key (1)'Address, Size_Sub_Key); |
| |
| exit when not (Result = ERROR_SUCCESS); |
| |
| Sub_Hkey := Open_Key (From_Key, Interfaces.C.To_Ada (Sub_Key)); |
| |
| Action (Natural (Index) + 1, Sub_Hkey, Current_Name, Quit); |
| |
| if not Quit and then Recursive then |
| Recursive_For_Every_Key (Sub_Hkey, True, Quit); |
| end if; |
| |
| Close_Key (Sub_Hkey); |
| |
| exit when Quit; |
| |
| Index := Index + 1; |
| end loop; |
| end Recursive_For_Every_Key; |
| |
| -- Local Variables |
| |
| Quit : Boolean := False; |
| |
| -- Start of processing for For_Every_Key |
| |
| begin |
| Recursive_For_Every_Key (From_Key, Recursive, Quit); |
| end For_Every_Key; |
| |
| ------------------------- |
| -- For_Every_Key_Value -- |
| ------------------------- |
| |
| procedure For_Every_Key_Value |
| (From_Key : HKEY; |
| Expand : Boolean := False) |
| is |
| use GNAT.Directory_Operations; |
| use type LONG; |
| use type ULONG; |
| |
| Index : ULONG := 0; |
| Result : LONG; |
| |
| Sub_Key : String (1 .. Max_Key_Size); |
| pragma Warnings (Off, Sub_Key); |
| |
| Value : String (1 .. Max_Value_Size); |
| 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); |
| |
| Quit := False; |
| |
| if Type_Sub_Key = REG_EXPAND_SZ and then Expand then |
| Action |
| (Natural (Index) + 1, |
| Sub_Key (1 .. Integer (Size_Sub_Key)), |
| Directory_Operations.Expand_Path |
| (Value (1 .. Integer (Size_Value) - 1), |
| Directory_Operations.DOS), |
| Quit); |
| |
| elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then |
| Action |
| (Natural (Index) + 1, |
| Sub_Key (1 .. Integer (Size_Sub_Key)), |
| Value (1 .. Integer (Size_Value) - 1), |
| Quit); |
| end if; |
| |
| exit when Quit; |
| |
| Index := Index + 1; |
| 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; |
| Expand : Boolean := False) return String |
| is |
| use GNAT.Directory_Operations; |
| use type LONG; |
| use type ULONG; |
| |
| Value : String (1 .. Max_Value_Size); |
| 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"); |
| |
| if Type_Value = REG_EXPAND_SZ and then Expand then |
| return Directory_Operations.Expand_Path |
| (Value (1 .. Integer (Size_Value - 1)), |
| Directory_Operations.DOS); |
| else |
| return Value (1 .. Integer (Size_Value - 1)); |
| end if; |
| end Query_Value; |
| |
| --------------- |
| -- Set_Value -- |
| --------------- |
| |
| procedure Set_Value |
| (From_Key : HKEY; |
| Sub_Key : String; |
| Value : String; |
| Expand : Boolean := False) |
| is |
| C_Sub_Key : constant String := Sub_Key & ASCII.NUL; |
| C_Value : constant String := Value & ASCII.NUL; |
| |
| Value_Type : DWORD; |
| Result : LONG; |
| |
| begin |
| Value_Type := (if Expand then REG_EXPAND_SZ else REG_SZ); |
| |
| Result := |
| RegSetValueEx |
| (From_Key, |
| C_Sub_Key (C_Sub_Key'First)'Address, |
| 0, |
| Value_Type, |
| 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#; |
| KEY_WOW64_64KEY : constant := 16#00100#; |
| KEY_WOW64_32KEY : constant := 16#00200#; |
| |
| begin |
| case Mode is |
| when Read_Only => |
| return KEY_READ + KEY_WOW64_32KEY; |
| |
| when Read_Write => |
| return KEY_READ + KEY_WRITE + KEY_WOW64_32KEY; |
| |
| when Read_Only_64 => |
| return KEY_READ + KEY_WOW64_64KEY; |
| |
| when Read_Write_64 => |
| return KEY_READ + KEY_WRITE + KEY_WOW64_64KEY; |
| end case; |
| end To_C_Mode; |
| |
| end GNAT.Registry; |
