1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . R E G I S T R Y --
11 -- Copyright (C) 2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
39 package body GNAT.Registry is
44 ------------------------------
45 -- Binding to the Win32 API --
46 ------------------------------
48 subtype LONG is Interfaces.C.long;
49 subtype ULONG is Interfaces.C.unsigned_long;
50 subtype DWORD is ULONG;
52 type PULONG is access all ULONG;
53 subtype PDWORD is PULONG;
54 subtype LPDWORD is PDWORD;
56 subtype Error_Code is LONG;
58 subtype REGSAM is LONG;
60 type PHKEY is access all HKEY;
62 ERROR_SUCCESS : constant Error_Code := 0;
64 REG_SZ : constant := 1;
66 function RegCloseKey (Key : HKEY) return LONG;
67 pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
69 function RegCreateKeyEx
76 lpSecurityAttributes : Address;
78 lpdwDisposition : LPDWORD)
80 pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
86 pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
88 function RegDeleteValue
90 lpValueName : Address)
92 pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
97 lpValueName : Address;
98 lpcbValueName : LPDWORD;
104 pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
106 function RegOpenKeyEx
113 pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
115 function RegQueryValueEx
117 lpValueName : Address;
118 lpReserved : LPDWORD;
123 pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
125 function RegSetValueEx
127 lpValueName : Address;
133 pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
135 -----------------------
136 -- Local Subprograms --
137 -----------------------
139 function To_C_Mode (Mode : Key_Mode) return REGSAM;
140 -- Returns the Win32 mode value for the Key_Mode value.
142 procedure Check_Result (Result : LONG; Message : String);
143 -- Checks value Result and raise the exception Registry_Error if it is not
144 -- equal to ERROR_SUCCESS. Message and the error value (Result) is added
145 -- to the exception message.
151 procedure Check_Result (Result : LONG; Message : String) is
155 if Result /= ERROR_SUCCESS then
156 Exceptions.Raise_Exception
157 (Registry_Error'Identity,
158 Message & " (" & LONG'Image (Result) & ')');
166 procedure Close_Key (Key : HKEY) is
170 Result := RegCloseKey (Key);
171 Check_Result (Result, "Close_Key");
181 Mode : Key_Mode := Read_Write)
187 REG_OPTION_NON_VOLATILE : constant := 16#0#;
189 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
190 C_Class : constant String := "" & ASCII.Nul;
191 C_Mode : constant REGSAM := To_C_Mode (Mode);
193 New_Key : aliased HKEY;
195 Dispos : aliased DWORD;
198 Result := RegCreateKeyEx
200 C_Sub_Key (C_Sub_Key'First)'Address,
202 C_Class (C_Class'First)'Address,
203 REG_OPTION_NON_VOLATILE,
206 New_Key'Unchecked_Access,
207 Dispos'Unchecked_Access);
209 Check_Result (Result, "Create_Key " & Sub_Key);
217 procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
218 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
222 Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
223 Check_Result (Result, "Delete_Key " & Sub_Key);
230 procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
231 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
235 Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
236 Check_Result (Result, "Delete_Value " & Sub_Key);
239 -------------------------
240 -- For_Every_Key_Value --
241 -------------------------
243 procedure For_Every_Key_Value (From_Key : HKEY) is
250 Sub_Key : String (1 .. 100);
251 pragma Warnings (Off, Sub_Key);
253 Value : String (1 .. 100);
254 pragma Warnings (Off, Value);
256 Size_Sub_Key : aliased ULONG;
257 Size_Value : aliased ULONG;
258 Type_Sub_Key : aliased DWORD;
264 Size_Sub_Key := Sub_Key'Length;
265 Size_Value := Value'Length;
267 Result := RegEnumValue
270 Size_Sub_Key'Unchecked_Access,
272 Type_Sub_Key'Unchecked_Access,
274 Size_Value'Unchecked_Access);
276 exit when not (Result = ERROR_SUCCESS);
278 if Type_Sub_Key = REG_SZ then
281 Action (Natural (Index) + 1,
282 Sub_Key (1 .. Integer (Size_Sub_Key)),
283 Value (1 .. Integer (Size_Value) - 1),
292 end For_Every_Key_Value;
306 New_Key := Open_Key (From_Key, Sub_Key);
309 -- We have been able to open the key so it exists
314 when Registry_Error =>
316 -- An error occurred, the key was not found
328 Mode : Key_Mode := Read_Only)
333 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
334 C_Mode : constant REGSAM := To_C_Mode (Mode);
336 New_Key : aliased HKEY;
340 Result := RegOpenKeyEx
342 C_Sub_Key (C_Sub_Key'First)'Address,
345 New_Key'Unchecked_Access);
347 Check_Result (Result, "Open_Key " & Sub_Key);
363 Value : String (1 .. 100);
364 pragma Warnings (Off, Value);
366 Size_Value : aliased ULONG;
367 Type_Value : aliased DWORD;
369 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
373 Size_Value := Value'Length;
375 Result := RegQueryValueEx
377 C_Sub_Key (C_Sub_Key'First)'Address,
379 Type_Value'Unchecked_Access,
380 Value (Value'First)'Address,
381 Size_Value'Unchecked_Access);
383 Check_Result (Result, "Query_Value " & Sub_Key & " key");
385 return Value (1 .. Integer (Size_Value - 1));
397 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
398 C_Value : constant String := Value & ASCII.Nul;
403 Result := RegSetValueEx
405 C_Sub_Key (C_Sub_Key'First)'Address,
408 C_Value (C_Value'First)'Address,
411 Check_Result (Result, "Set_Value " & Sub_Key & " key");
418 function To_C_Mode (Mode : Key_Mode) return REGSAM is
421 KEY_READ : constant := 16#20019#;
422 KEY_WRITE : constant := 16#20006#;
430 return KEY_READ + KEY_WRITE;