File : g-regist.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T . R E G I S T R Y --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- Extensive contributions were provided by Ada Core Technologies Inc. --
28 -- --
29 ------------------------------------------------------------------------------
30
31 with Interfaces.C;
32 with System;
33 with GNAT.Directory_Operations;
34
35 package body GNAT.Registry is
36
37 use System;
38
39 ------------------------------
40 -- Binding to the Win32 API --
41 ------------------------------
42
43 subtype LONG is Interfaces.C.long;
44 subtype ULONG is Interfaces.C.unsigned_long;
45 subtype DWORD is ULONG;
46
47 type PULONG is access all ULONG;
48 subtype PDWORD is PULONG;
49 subtype LPDWORD is PDWORD;
50
51 subtype Error_Code is LONG;
52
53 subtype REGSAM is LONG;
54
55 type PHKEY is access all HKEY;
56
57 ERROR_SUCCESS : constant Error_Code := 0;
58
59 REG_SZ : constant := 1;
60 REG_EXPAND_SZ : constant := 2;
61
62 function RegCloseKey (Key : HKEY) return LONG;
63 pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
64
65 function RegCreateKeyEx
66 (Key : HKEY;
67 lpSubKey : Address;
68 Reserved : DWORD;
69 lpClass : Address;
70 dwOptions : DWORD;
71 samDesired : REGSAM;
72 lpSecurityAttributes : Address;
73 phkResult : PHKEY;
74 lpdwDisposition : LPDWORD)
75 return LONG;
76 pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
77
78 function RegDeleteKey
79 (Key : HKEY;
80 lpSubKey : Address) return LONG;
81 pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
82
83 function RegDeleteValue
84 (Key : HKEY;
85 lpValueName : Address) return LONG;
86 pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
87
88 function RegEnumValue
89 (Key : HKEY;
90 dwIndex : DWORD;
91 lpValueName : Address;
92 lpcbValueName : LPDWORD;
93 lpReserved : LPDWORD;
94 lpType : LPDWORD;
95 lpData : Address;
96 lpcbData : LPDWORD) return LONG;
97 pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
98
99 function RegOpenKeyEx
100 (Key : HKEY;
101 lpSubKey : Address;
102 ulOptions : DWORD;
103 samDesired : REGSAM;
104 phkResult : PHKEY) return LONG;
105 pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
106
107 function RegQueryValueEx
108 (Key : HKEY;
109 lpValueName : Address;
110 lpReserved : LPDWORD;
111 lpType : LPDWORD;
112 lpData : Address;
113 lpcbData : LPDWORD) return LONG;
114 pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
115
116 function RegSetValueEx
117 (Key : HKEY;
118 lpValueName : Address;
119 Reserved : DWORD;
120 dwType : DWORD;
121 lpData : Address;
122 cbData : DWORD) return LONG;
123 pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
124
125 function RegEnumKey
126 (Key : HKEY;
127 dwIndex : DWORD;
128 lpName : Address;
129 cchName : DWORD) return LONG;
130 pragma Import (Stdcall, RegEnumKey, "RegEnumKeyA");
131
132 ---------------------
133 -- Local Constants --
134 ---------------------
135
136 Max_Key_Size : constant := 1_024;
137 -- Maximum number of characters for a registry key
138
139 Max_Value_Size : constant := 2_048;
140 -- Maximum number of characters for a key's value
141
142 -----------------------
143 -- Local Subprograms --
144 -----------------------
145
146 function To_C_Mode (Mode : Key_Mode) return REGSAM;
147 -- Returns the Win32 mode value for the Key_Mode value
148
149 procedure Check_Result (Result : LONG; Message : String);
150 -- Checks value Result and raise the exception Registry_Error if it is not
151 -- equal to ERROR_SUCCESS. Message and the error value (Result) is added
152 -- to the exception message.
153
154 ------------------
155 -- Check_Result --
156 ------------------
157
158 procedure Check_Result (Result : LONG; Message : String) is
159 use type LONG;
160 begin
161 if Result /= ERROR_SUCCESS then
162 raise Registry_Error with
163 Message & " (" & LONG'Image (Result) & ')';
164 end if;
165 end Check_Result;
166
167 ---------------
168 -- Close_Key --
169 ---------------
170
171 procedure Close_Key (Key : HKEY) is
172 Result : LONG;
173 begin
174 Result := RegCloseKey (Key);
175 Check_Result (Result, "Close_Key");
176 end Close_Key;
177
178 ----------------
179 -- Create_Key --
180 ----------------
181
182 function Create_Key
183 (From_Key : HKEY;
184 Sub_Key : String;
185 Mode : Key_Mode := Read_Write) return HKEY
186 is
187 use type REGSAM;
188 use type DWORD;
189
190 REG_OPTION_NON_VOLATILE : constant := 16#0#;
191
192 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
193 C_Class : constant String := "" & ASCII.NUL;
194 C_Mode : constant REGSAM := To_C_Mode (Mode);
195
196 New_Key : aliased HKEY;
197 Result : LONG;
198 Dispos : aliased DWORD;
199
200 begin
201 Result :=
202 RegCreateKeyEx
203 (From_Key,
204 C_Sub_Key (C_Sub_Key'First)'Address,
205 0,
206 C_Class (C_Class'First)'Address,
207 REG_OPTION_NON_VOLATILE,
208 C_Mode,
209 Null_Address,
210 New_Key'Unchecked_Access,
211 Dispos'Unchecked_Access);
212
213 Check_Result (Result, "Create_Key " & Sub_Key);
214 return New_Key;
215 end Create_Key;
216
217 ----------------
218 -- Delete_Key --
219 ----------------
220
221 procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
222 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
223 Result : LONG;
224 begin
225 Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
226 Check_Result (Result, "Delete_Key " & Sub_Key);
227 end Delete_Key;
228
229 ------------------
230 -- Delete_Value --
231 ------------------
232
233 procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
234 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
235 Result : LONG;
236 begin
237 Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
238 Check_Result (Result, "Delete_Value " & Sub_Key);
239 end Delete_Value;
240
241 -------------------
242 -- For_Every_Key --
243 -------------------
244
245 procedure For_Every_Key
246 (From_Key : HKEY;
247 Recursive : Boolean := False)
248 is
249 procedure Recursive_For_Every_Key
250 (From_Key : HKEY;
251 Recursive : Boolean := False;
252 Quit : in out Boolean);
253
254 -----------------------------
255 -- Recursive_For_Every_Key --
256 -----------------------------
257
258 procedure Recursive_For_Every_Key
259 (From_Key : HKEY;
260 Recursive : Boolean := False;
261 Quit : in out Boolean)
262 is
263 use type LONG;
264 use type ULONG;
265
266 Index : ULONG := 0;
267 Result : LONG;
268
269 Sub_Key : Interfaces.C.char_array (1 .. Max_Key_Size);
270 pragma Warnings (Off, Sub_Key);
271
272 Size_Sub_Key : aliased ULONG;
273 Sub_Hkey : HKEY;
274
275 function Current_Name return String;
276
277 ------------------
278 -- Current_Name --
279 ------------------
280
281 function Current_Name return String is
282 begin
283 return Interfaces.C.To_Ada (Sub_Key);
284 end Current_Name;
285
286 -- Start of processing for Recursive_For_Every_Key
287
288 begin
289 loop
290 Size_Sub_Key := Sub_Key'Length;
291
292 Result :=
293 RegEnumKey
294 (From_Key, Index, Sub_Key (1)'Address, Size_Sub_Key);
295
296 exit when not (Result = ERROR_SUCCESS);
297
298 Sub_Hkey := Open_Key (From_Key, Interfaces.C.To_Ada (Sub_Key));
299
300 Action (Natural (Index) + 1, Sub_Hkey, Current_Name, Quit);
301
302 if not Quit and then Recursive then
303 Recursive_For_Every_Key (Sub_Hkey, True, Quit);
304 end if;
305
306 Close_Key (Sub_Hkey);
307
308 exit when Quit;
309
310 Index := Index + 1;
311 end loop;
312 end Recursive_For_Every_Key;
313
314 -- Local Variables
315
316 Quit : Boolean := False;
317
318 -- Start of processing for For_Every_Key
319
320 begin
321 Recursive_For_Every_Key (From_Key, Recursive, Quit);
322 end For_Every_Key;
323
324 -------------------------
325 -- For_Every_Key_Value --
326 -------------------------
327
328 procedure For_Every_Key_Value
329 (From_Key : HKEY;
330 Expand : Boolean := False)
331 is
332 use GNAT.Directory_Operations;
333 use type LONG;
334 use type ULONG;
335
336 Index : ULONG := 0;
337 Result : LONG;
338
339 Sub_Key : String (1 .. Max_Key_Size);
340 pragma Warnings (Off, Sub_Key);
341
342 Value : String (1 .. Max_Value_Size);
343 pragma Warnings (Off, Value);
344
345 Size_Sub_Key : aliased ULONG;
346 Size_Value : aliased ULONG;
347 Type_Sub_Key : aliased DWORD;
348
349 Quit : Boolean;
350
351 begin
352 loop
353 Size_Sub_Key := Sub_Key'Length;
354 Size_Value := Value'Length;
355
356 Result :=
357 RegEnumValue
358 (From_Key, Index,
359 Sub_Key (1)'Address,
360 Size_Sub_Key'Unchecked_Access,
361 null,
362 Type_Sub_Key'Unchecked_Access,
363 Value (1)'Address,
364 Size_Value'Unchecked_Access);
365
366 exit when not (Result = ERROR_SUCCESS);
367
368 Quit := False;
369
370 if Type_Sub_Key = REG_EXPAND_SZ and then Expand then
371 Action
372 (Natural (Index) + 1,
373 Sub_Key (1 .. Integer (Size_Sub_Key)),
374 Directory_Operations.Expand_Path
375 (Value (1 .. Integer (Size_Value) - 1),
376 Directory_Operations.DOS),
377 Quit);
378
379 elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then
380 Action
381 (Natural (Index) + 1,
382 Sub_Key (1 .. Integer (Size_Sub_Key)),
383 Value (1 .. Integer (Size_Value) - 1),
384 Quit);
385 end if;
386
387 exit when Quit;
388
389 Index := Index + 1;
390 end loop;
391 end For_Every_Key_Value;
392
393 ----------------
394 -- Key_Exists --
395 ----------------
396
397 function Key_Exists
398 (From_Key : HKEY;
399 Sub_Key : String) return Boolean
400 is
401 New_Key : HKEY;
402
403 begin
404 New_Key := Open_Key (From_Key, Sub_Key);
405 Close_Key (New_Key);
406
407 -- We have been able to open the key so it exists
408
409 return True;
410
411 exception
412 when Registry_Error =>
413
414 -- An error occurred, the key was not found
415
416 return False;
417 end Key_Exists;
418
419 --------------
420 -- Open_Key --
421 --------------
422
423 function Open_Key
424 (From_Key : HKEY;
425 Sub_Key : String;
426 Mode : Key_Mode := Read_Only) return HKEY
427 is
428 use type REGSAM;
429
430 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
431 C_Mode : constant REGSAM := To_C_Mode (Mode);
432
433 New_Key : aliased HKEY;
434 Result : LONG;
435
436 begin
437 Result :=
438 RegOpenKeyEx
439 (From_Key,
440 C_Sub_Key (C_Sub_Key'First)'Address,
441 0,
442 C_Mode,
443 New_Key'Unchecked_Access);
444
445 Check_Result (Result, "Open_Key " & Sub_Key);
446 return New_Key;
447 end Open_Key;
448
449 -----------------
450 -- Query_Value --
451 -----------------
452
453 function Query_Value
454 (From_Key : HKEY;
455 Sub_Key : String;
456 Expand : Boolean := False) return String
457 is
458 use GNAT.Directory_Operations;
459 use type LONG;
460 use type ULONG;
461
462 Value : String (1 .. Max_Value_Size);
463 pragma Warnings (Off, Value);
464
465 Size_Value : aliased ULONG;
466 Type_Value : aliased DWORD;
467
468 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
469 Result : LONG;
470
471 begin
472 Size_Value := Value'Length;
473
474 Result :=
475 RegQueryValueEx
476 (From_Key,
477 C_Sub_Key (C_Sub_Key'First)'Address,
478 null,
479 Type_Value'Unchecked_Access,
480 Value (Value'First)'Address,
481 Size_Value'Unchecked_Access);
482
483 Check_Result (Result, "Query_Value " & Sub_Key & " key");
484
485 if Type_Value = REG_EXPAND_SZ and then Expand then
486 return Directory_Operations.Expand_Path
487 (Value (1 .. Integer (Size_Value - 1)),
488 Directory_Operations.DOS);
489 else
490 return Value (1 .. Integer (Size_Value - 1));
491 end if;
492 end Query_Value;
493
494 ---------------
495 -- Set_Value --
496 ---------------
497
498 procedure Set_Value
499 (From_Key : HKEY;
500 Sub_Key : String;
501 Value : String;
502 Expand : Boolean := False)
503 is
504 C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
505 C_Value : constant String := Value & ASCII.NUL;
506
507 Value_Type : DWORD;
508 Result : LONG;
509
510 begin
511 Value_Type := (if Expand then REG_EXPAND_SZ else REG_SZ);
512
513 Result :=
514 RegSetValueEx
515 (From_Key,
516 C_Sub_Key (C_Sub_Key'First)'Address,
517 0,
518 Value_Type,
519 C_Value (C_Value'First)'Address,
520 C_Value'Length);
521
522 Check_Result (Result, "Set_Value " & Sub_Key & " key");
523 end Set_Value;
524
525 ---------------
526 -- To_C_Mode --
527 ---------------
528
529 function To_C_Mode (Mode : Key_Mode) return REGSAM is
530 use type REGSAM;
531
532 KEY_READ : constant := 16#20019#;
533 KEY_WRITE : constant := 16#20006#;
534 KEY_WOW64_64KEY : constant := 16#00100#;
535 KEY_WOW64_32KEY : constant := 16#00200#;
536
537 begin
538 case Mode is
539 when Read_Only =>
540 return KEY_READ + KEY_WOW64_32KEY;
541
542 when Read_Write =>
543 return KEY_READ + KEY_WRITE + KEY_WOW64_32KEY;
544
545 when Read_Only_64 =>
546 return KEY_READ + KEY_WOW64_64KEY;
547
548 when Read_Write_64 =>
549 return KEY_READ + KEY_WRITE + KEY_WOW64_64KEY;
550 end case;
551 end To_C_Mode;
552
553 end GNAT.Registry;