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-2009, 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-- 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.               --
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
31with Interfaces.C;
32with System;
33with GNAT.Directory_Operations;
34
35package 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
535   begin
536      case Mode is
537         when Read_Only =>
538            return KEY_READ;
539
540         when Read_Write =>
541            return KEY_READ + KEY_WRITE;
542      end case;
543   end To_C_Mode;
544
545end GNAT.Registry;
546