aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/g-regist.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/ada/g-regist.adb')
-rw-r--r--gcc-4.9/gcc/ada/g-regist.adb545
1 files changed, 545 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/g-regist.adb b/gcc-4.9/gcc/ada/g-regist.adb
new file mode 100644
index 000000000..ba63b3c83
--- /dev/null
+++ b/gcc-4.9/gcc/ada/g-regist.adb
@@ -0,0 +1,545 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . R E G I S T R Y --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2009, 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#;
+
+ 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;