URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [g-regist.adb] - Rev 310
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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;
Go to most recent revision | Compare with Previous | Blame | View Log