1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . R E G I S T R Y --
10 -- Copyright (C) 2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
38 package body GNAT.Registry is
43 ------------------------------
44 -- Binding to the Win32 API --
45 ------------------------------
47 subtype LONG is Interfaces.C.long;
48 subtype ULONG is Interfaces.C.unsigned_long;
49 subtype DWORD is ULONG;
51 type PULONG is access all ULONG;
52 subtype PDWORD is PULONG;
53 subtype LPDWORD is PDWORD;
55 subtype Error_Code is LONG;
57 subtype REGSAM is LONG;
59 type PHKEY is access all HKEY;
61 ERROR_SUCCESS : constant Error_Code := 0;
63 REG_SZ : constant := 1;
65 function RegCloseKey (Key : HKEY) return LONG;
66 pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
68 function RegCreateKeyEx
75 lpSecurityAttributes : Address;
77 lpdwDisposition : LPDWORD)
79 pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
85 pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
87 function RegDeleteValue
89 lpValueName : Address)
91 pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
96 lpValueName : Address;
97 lpcbValueName : LPDWORD;
103 pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
105 function RegOpenKeyEx
112 pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
114 function RegQueryValueEx
116 lpValueName : Address;
117 lpReserved : LPDWORD;
122 pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
124 function RegSetValueEx
126 lpValueName : Address;
132 pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
134 -----------------------
135 -- Local Subprograms --
136 -----------------------
138 function To_C_Mode (Mode : Key_Mode) return REGSAM;
139 -- Returns the Win32 mode value for the Key_Mode value.
141 procedure Check_Result (Result : LONG; Message : String);
142 -- Checks value Result and raise the exception Registry_Error if it is not
143 -- equal to ERROR_SUCCESS. Message and the error value (Result) is added
144 -- to the exception message.
150 procedure Check_Result (Result : LONG; Message : String) is
154 if Result /= ERROR_SUCCESS then
155 Exceptions.Raise_Exception
156 (Registry_Error'Identity,
157 Message & " (" & LONG'Image (Result) & ')');
165 procedure Close_Key (Key : HKEY) is
169 Result := RegCloseKey (Key);
170 Check_Result (Result, "Close_Key");
180 Mode : Key_Mode := Read_Write)
186 REG_OPTION_NON_VOLATILE : constant := 16#0#;
188 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
189 C_Class : constant String := "" & ASCII.Nul;
190 C_Mode : constant REGSAM := To_C_Mode (Mode);
192 New_Key : aliased HKEY;
194 Dispos : aliased DWORD;
197 Result := RegCreateKeyEx
199 C_Sub_Key (C_Sub_Key'First)'Address,
201 C_Class (C_Class'First)'Address,
202 REG_OPTION_NON_VOLATILE,
205 New_Key'Unchecked_Access,
206 Dispos'Unchecked_Access);
208 Check_Result (Result, "Create_Key " & Sub_Key);
216 procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
217 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
221 Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
222 Check_Result (Result, "Delete_Key " & Sub_Key);
229 procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
230 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
234 Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
235 Check_Result (Result, "Delete_Value " & Sub_Key);
238 -------------------------
239 -- For_Every_Key_Value --
240 -------------------------
242 procedure For_Every_Key_Value (From_Key : HKEY) is
249 Sub_Key : String (1 .. 100);
250 pragma Warnings (Off, Sub_Key);
252 Value : String (1 .. 100);
253 pragma Warnings (Off, Value);
255 Size_Sub_Key : aliased ULONG;
256 Size_Value : aliased ULONG;
257 Type_Sub_Key : aliased DWORD;
263 Size_Sub_Key := Sub_Key'Length;
264 Size_Value := Value'Length;
266 Result := RegEnumValue
269 Size_Sub_Key'Unchecked_Access,
271 Type_Sub_Key'Unchecked_Access,
273 Size_Value'Unchecked_Access);
275 exit when not (Result = ERROR_SUCCESS);
277 if Type_Sub_Key = REG_SZ then
280 Action (Natural (Index) + 1,
281 Sub_Key (1 .. Integer (Size_Sub_Key)),
282 Value (1 .. Integer (Size_Value) - 1),
291 end For_Every_Key_Value;
305 New_Key := Open_Key (From_Key, Sub_Key);
308 -- We have been able to open the key so it exists
313 when Registry_Error =>
315 -- An error occurred, the key was not found
327 Mode : Key_Mode := Read_Only)
332 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
333 C_Mode : constant REGSAM := To_C_Mode (Mode);
335 New_Key : aliased HKEY;
339 Result := RegOpenKeyEx
341 C_Sub_Key (C_Sub_Key'First)'Address,
344 New_Key'Unchecked_Access);
346 Check_Result (Result, "Open_Key " & Sub_Key);
362 Value : String (1 .. 100);
363 pragma Warnings (Off, Value);
365 Size_Value : aliased ULONG;
366 Type_Value : aliased DWORD;
368 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
372 Size_Value := Value'Length;
374 Result := RegQueryValueEx
376 C_Sub_Key (C_Sub_Key'First)'Address,
378 Type_Value'Unchecked_Access,
379 Value (Value'First)'Address,
380 Size_Value'Unchecked_Access);
382 Check_Result (Result, "Query_Value " & Sub_Key & " key");
384 return Value (1 .. Integer (Size_Value - 1));
396 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
397 C_Value : constant String := Value & ASCII.Nul;
402 Result := RegSetValueEx
404 C_Sub_Key (C_Sub_Key'First)'Address,
407 C_Value (C_Value'First)'Address,
410 Check_Result (Result, "Set_Value " & Sub_Key & " key");
417 function To_C_Mode (Mode : Key_Mode) return REGSAM is
420 KEY_READ : constant := 16#20019#;
421 KEY_WRITE : constant := 16#20006#;
429 return KEY_READ + KEY_WRITE;