diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/g-regist.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/g-regist.adb | 458 |
1 files changed, 0 insertions, 458 deletions
diff --git a/gcc-4.4.3/gcc/ada/g-regist.adb b/gcc-4.4.3/gcc/ada/g-regist.adb deleted file mode 100644 index 2c706ff69..000000000 --- a/gcc-4.4.3/gcc/ada/g-regist.adb +++ /dev/null @@ -1,458 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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"); - - --------------------- - -- 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_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 - if Expand then - Value_Type := REG_EXPAND_SZ; - else - Value_Type := REG_SZ; - end if; - - 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; |