1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . R E G I S T R Y --
9 -- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 ------------------------------------------------------------------------------
33 with GNAT.Directory_Operations;
35 package body GNAT.Registry is
39 ------------------------------
40 -- Binding to the Win32 API --
41 ------------------------------
43 subtype LONG is Interfaces.C.long;
44 subtype ULONG is Interfaces.C.unsigned_long;
45 subtype DWORD is ULONG;
47 type PULONG is access all ULONG;
48 subtype PDWORD is PULONG;
49 subtype LPDWORD is PDWORD;
51 subtype Error_Code is LONG;
53 subtype REGSAM is LONG;
55 type PHKEY is access all HKEY;
57 ERROR_SUCCESS : constant Error_Code := 0;
59 REG_SZ : constant := 1;
60 REG_EXPAND_SZ : constant := 2;
62 function RegCloseKey (Key : HKEY) return LONG;
63 pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
65 function RegCreateKeyEx
72 lpSecurityAttributes : Address;
74 lpdwDisposition : LPDWORD)
76 pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
80 lpSubKey : Address) return LONG;
81 pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
83 function RegDeleteValue
85 lpValueName : Address) return LONG;
86 pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
91 lpValueName : Address;
92 lpcbValueName : LPDWORD;
96 lpcbData : LPDWORD) return LONG;
97 pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
104 phkResult : PHKEY) return LONG;
105 pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
107 function RegQueryValueEx
109 lpValueName : Address;
110 lpReserved : LPDWORD;
113 lpcbData : LPDWORD) return LONG;
114 pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
116 function RegSetValueEx
118 lpValueName : Address;
122 cbData : DWORD) return LONG;
123 pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
125 ---------------------
126 -- Local Constants --
127 ---------------------
129 Max_Key_Size : constant := 1_024;
130 -- Maximum number of characters for a registry key
132 Max_Value_Size : constant := 2_048;
133 -- Maximum number of characters for a key's value
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
154 if Result /= ERROR_SUCCESS then
155 raise Registry_Error with
156 Message & " (" & LONG'Image (Result) & ')';
164 procedure Close_Key (Key : HKEY) is
167 Result := RegCloseKey (Key);
168 Check_Result (Result, "Close_Key");
178 Mode : Key_Mode := Read_Write) return HKEY
183 REG_OPTION_NON_VOLATILE : constant := 16#0#;
185 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
186 C_Class : constant String := "" & ASCII.NUL;
187 C_Mode : constant REGSAM := To_C_Mode (Mode);
189 New_Key : aliased HKEY;
191 Dispos : aliased DWORD;
197 C_Sub_Key (C_Sub_Key'First)'Address,
199 C_Class (C_Class'First)'Address,
200 REG_OPTION_NON_VOLATILE,
203 New_Key'Unchecked_Access,
204 Dispos'Unchecked_Access);
206 Check_Result (Result, "Create_Key " & Sub_Key);
214 procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
215 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
218 Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
219 Check_Result (Result, "Delete_Key " & Sub_Key);
226 procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
227 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
230 Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
231 Check_Result (Result, "Delete_Value " & Sub_Key);
234 -------------------------
235 -- For_Every_Key_Value --
236 -------------------------
238 procedure For_Every_Key_Value
240 Expand : Boolean := False)
242 use GNAT.Directory_Operations;
249 Sub_Key : String (1 .. Max_Key_Size);
250 pragma Warnings (Off, Sub_Key);
252 Value : String (1 .. Max_Value_Size);
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;
270 Size_Sub_Key'Unchecked_Access,
272 Type_Sub_Key'Unchecked_Access,
274 Size_Value'Unchecked_Access);
276 exit when not (Result = ERROR_SUCCESS);
280 if Type_Sub_Key = REG_EXPAND_SZ and then Expand then
282 (Natural (Index) + 1,
283 Sub_Key (1 .. Integer (Size_Sub_Key)),
284 Directory_Operations.Expand_Path
285 (Value (1 .. Integer (Size_Value) - 1),
286 Directory_Operations.DOS),
289 elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then
291 (Natural (Index) + 1,
292 Sub_Key (1 .. Integer (Size_Sub_Key)),
293 Value (1 .. Integer (Size_Value) - 1),
301 end For_Every_Key_Value;
309 Sub_Key : String) return Boolean
314 New_Key := Open_Key (From_Key, Sub_Key);
317 -- We have been able to open the key so it exists
322 when Registry_Error =>
324 -- An error occurred, the key was not found
336 Mode : Key_Mode := Read_Only) return HKEY
340 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
341 C_Mode : constant REGSAM := To_C_Mode (Mode);
343 New_Key : aliased HKEY;
350 C_Sub_Key (C_Sub_Key'First)'Address,
353 New_Key'Unchecked_Access);
355 Check_Result (Result, "Open_Key " & Sub_Key);
366 Expand : Boolean := False) return String
368 use GNAT.Directory_Operations;
372 Value : String (1 .. Max_Value_Size);
373 pragma Warnings (Off, Value);
375 Size_Value : aliased ULONG;
376 Type_Value : aliased DWORD;
378 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
382 Size_Value := Value'Length;
387 C_Sub_Key (C_Sub_Key'First)'Address,
389 Type_Value'Unchecked_Access,
390 Value (Value'First)'Address,
391 Size_Value'Unchecked_Access);
393 Check_Result (Result, "Query_Value " & Sub_Key & " key");
395 if Type_Value = REG_EXPAND_SZ and then Expand then
396 return Directory_Operations.Expand_Path
397 (Value (1 .. Integer (Size_Value - 1)), Directory_Operations.DOS);
399 return Value (1 .. Integer (Size_Value - 1));
411 Expand : Boolean := False)
413 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
414 C_Value : constant String := Value & ASCII.NUL;
421 Value_Type := REG_EXPAND_SZ;
423 Value_Type := REG_SZ;
429 C_Sub_Key (C_Sub_Key'First)'Address,
432 C_Value (C_Value'First)'Address,
435 Check_Result (Result, "Set_Value " & Sub_Key & " key");
442 function To_C_Mode (Mode : Key_Mode) return REGSAM is
445 KEY_READ : constant := 16#20019#;
446 KEY_WRITE : constant := 16#20006#;
454 return KEY_READ + KEY_WRITE;