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-2018, 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      REG_OPTION_NON_VOLATILE : constant := 16#0#;
188
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);
192
193      New_Key : aliased HKEY;
194      Result  : LONG;
195      Dispos  : aliased DWORD;
196
197   begin
198      Result :=
199        RegCreateKeyEx
200          (From_Key,
201           C_Sub_Key (C_Sub_Key'First)'Address,
202           0,
203           C_Class (C_Class'First)'Address,
204           REG_OPTION_NON_VOLATILE,
205           C_Mode,
206           Null_Address,
207           New_Key'Unchecked_Access,
208           Dispos'Unchecked_Access);
209
210      Check_Result (Result, "Create_Key " & Sub_Key);
211      return New_Key;
212   end Create_Key;
213
214   ----------------
215   -- Delete_Key --
216   ----------------
217
218   procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
219      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
220      Result    : LONG;
221   begin
222      Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
223      Check_Result (Result, "Delete_Key " & Sub_Key);
224   end Delete_Key;
225
226   ------------------
227   -- Delete_Value --
228   ------------------
229
230   procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
231      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
232      Result    : LONG;
233   begin
234      Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
235      Check_Result (Result, "Delete_Value " & Sub_Key);
236   end Delete_Value;
237
238   -------------------
239   -- For_Every_Key --
240   -------------------
241
242   procedure For_Every_Key
243     (From_Key  : HKEY;
244      Recursive : Boolean := False)
245   is
246      procedure Recursive_For_Every_Key
247        (From_Key  : HKEY;
248         Recursive : Boolean := False;
249         Quit      : in out Boolean);
250
251      -----------------------------
252      -- Recursive_For_Every_Key --
253      -----------------------------
254
255      procedure Recursive_For_Every_Key
256        (From_Key : HKEY;
257         Recursive : Boolean := False;
258         Quit      : in out Boolean)
259      is
260         use type LONG;
261         use type ULONG;
262
263         Index  : ULONG := 0;
264         Result : LONG;
265
266         Sub_Key : Interfaces.C.char_array (1 .. Max_Key_Size);
267         pragma Warnings (Off, Sub_Key);
268
269         Size_Sub_Key : aliased ULONG;
270         Sub_Hkey     : HKEY;
271
272         function Current_Name return String;
273
274         ------------------
275         -- Current_Name --
276         ------------------
277
278         function Current_Name return String is
279         begin
280            return Interfaces.C.To_Ada (Sub_Key);
281         end Current_Name;
282
283      --  Start of processing for Recursive_For_Every_Key
284
285      begin
286         loop
287            Size_Sub_Key := Sub_Key'Length;
288
289            Result :=
290              RegEnumKey
291                (From_Key, Index, Sub_Key (1)'Address, Size_Sub_Key);
292
293            exit when not (Result = ERROR_SUCCESS);
294
295            Sub_Hkey := Open_Key (From_Key, Interfaces.C.To_Ada (Sub_Key));
296
297            Action (Natural (Index) + 1, Sub_Hkey, Current_Name, Quit);
298
299            if not Quit and then Recursive then
300               Recursive_For_Every_Key (Sub_Hkey, True, Quit);
301            end if;
302
303            Close_Key (Sub_Hkey);
304
305            exit when Quit;
306
307            Index := Index + 1;
308         end loop;
309      end Recursive_For_Every_Key;
310
311      --  Local Variables
312
313      Quit : Boolean := False;
314
315   --  Start of processing for For_Every_Key
316
317   begin
318      Recursive_For_Every_Key (From_Key, Recursive, Quit);
319   end For_Every_Key;
320
321   -------------------------
322   -- For_Every_Key_Value --
323   -------------------------
324
325   procedure For_Every_Key_Value
326     (From_Key : HKEY;
327      Expand   : Boolean := False)
328   is
329      use GNAT.Directory_Operations;
330      use type LONG;
331      use type ULONG;
332
333      Index  : ULONG := 0;
334      Result : LONG;
335
336      Sub_Key : String (1 .. Max_Key_Size);
337      pragma Warnings (Off, Sub_Key);
338
339      Value : String (1 .. Max_Value_Size);
340      pragma Warnings (Off, Value);
341
342      Size_Sub_Key : aliased ULONG;
343      Size_Value   : aliased ULONG;
344      Type_Sub_Key : aliased DWORD;
345
346      Quit : Boolean;
347
348   begin
349      loop
350         Size_Sub_Key := Sub_Key'Length;
351         Size_Value   := Value'Length;
352
353         Result :=
354           RegEnumValue
355             (From_Key, Index,
356              Sub_Key (1)'Address,
357              Size_Sub_Key'Unchecked_Access,
358              null,
359              Type_Sub_Key'Unchecked_Access,
360              Value (1)'Address,
361              Size_Value'Unchecked_Access);
362
363         exit when not (Result = ERROR_SUCCESS);
364
365         Quit := False;
366
367         if Type_Sub_Key = REG_EXPAND_SZ and then Expand then
368            Action
369              (Natural (Index) + 1,
370               Sub_Key (1 .. Integer (Size_Sub_Key)),
371               Directory_Operations.Expand_Path
372                 (Value (1 .. Integer (Size_Value) - 1),
373                  Directory_Operations.DOS),
374               Quit);
375
376         elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then
377            Action
378              (Natural (Index) + 1,
379               Sub_Key (1 .. Integer (Size_Sub_Key)),
380               Value (1 .. Integer (Size_Value) - 1),
381               Quit);
382         end if;
383
384         exit when Quit;
385
386         Index := Index + 1;
387      end loop;
388   end For_Every_Key_Value;
389
390   ----------------
391   -- Key_Exists --
392   ----------------
393
394   function Key_Exists
395     (From_Key : HKEY;
396      Sub_Key  : String) return Boolean
397   is
398      New_Key : HKEY;
399
400   begin
401      New_Key := Open_Key (From_Key, Sub_Key);
402      Close_Key (New_Key);
403
404      --  We have been able to open the key so it exists
405
406      return True;
407
408   exception
409      when Registry_Error =>
410
411         --  An error occurred, the key was not found
412
413         return False;
414   end Key_Exists;
415
416   --------------
417   -- Open_Key --
418   --------------
419
420   function Open_Key
421     (From_Key : HKEY;
422      Sub_Key  : String;
423      Mode     : Key_Mode := Read_Only) return HKEY
424   is
425      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
426      C_Mode    : constant REGSAM := To_C_Mode (Mode);
427
428      New_Key : aliased HKEY;
429      Result  : LONG;
430
431   begin
432      Result :=
433        RegOpenKeyEx
434          (From_Key,
435           C_Sub_Key (C_Sub_Key'First)'Address,
436           0,
437           C_Mode,
438           New_Key'Unchecked_Access);
439
440      Check_Result (Result, "Open_Key " & Sub_Key);
441      return New_Key;
442   end Open_Key;
443
444   -----------------
445   -- Query_Value --
446   -----------------
447
448   function Query_Value
449     (From_Key : HKEY;
450      Sub_Key  : String;
451      Expand   : Boolean := False) return String
452   is
453      use GNAT.Directory_Operations;
454      use type ULONG;
455
456      Value : String (1 .. Max_Value_Size);
457      pragma Warnings (Off, Value);
458
459      Size_Value : aliased ULONG;
460      Type_Value : aliased DWORD;
461
462      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
463      Result    : LONG;
464
465   begin
466      Size_Value := Value'Length;
467
468      Result :=
469        RegQueryValueEx
470          (From_Key,
471           C_Sub_Key (C_Sub_Key'First)'Address,
472           null,
473           Type_Value'Unchecked_Access,
474           Value (Value'First)'Address,
475           Size_Value'Unchecked_Access);
476
477      Check_Result (Result, "Query_Value " & Sub_Key & " key");
478
479      if Type_Value = REG_EXPAND_SZ and then Expand then
480         return Directory_Operations.Expand_Path
481           (Value (1 .. Integer (Size_Value - 1)),
482            Directory_Operations.DOS);
483      else
484         return Value (1 .. Integer (Size_Value - 1));
485      end if;
486   end Query_Value;
487
488   ---------------
489   -- Set_Value --
490   ---------------
491
492   procedure Set_Value
493      (From_Key : HKEY;
494       Sub_Key  : String;
495       Value    : String;
496       Expand   : Boolean := False)
497   is
498      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
499      C_Value   : constant String := Value & ASCII.NUL;
500
501      Value_Type : DWORD;
502      Result     : LONG;
503
504   begin
505      Value_Type := (if Expand then REG_EXPAND_SZ else REG_SZ);
506
507      Result :=
508        RegSetValueEx
509          (From_Key,
510           C_Sub_Key (C_Sub_Key'First)'Address,
511           0,
512           Value_Type,
513           C_Value (C_Value'First)'Address,
514           C_Value'Length);
515
516      Check_Result (Result, "Set_Value " & Sub_Key & " key");
517   end Set_Value;
518
519   ---------------
520   -- To_C_Mode --
521   ---------------
522
523   function To_C_Mode (Mode : Key_Mode) return REGSAM is
524      use type REGSAM;
525
526      KEY_READ        : constant := 16#20019#;
527      KEY_WRITE       : constant := 16#20006#;
528      KEY_WOW64_64KEY : constant := 16#00100#;
529      KEY_WOW64_32KEY : constant := 16#00200#;
530
531   begin
532      case Mode is
533         when Read_Only =>
534            return KEY_READ + KEY_WOW64_32KEY;
535
536         when Read_Write =>
537            return KEY_READ + KEY_WRITE + KEY_WOW64_32KEY;
538
539         when Read_Only_64 =>
540            return KEY_READ + KEY_WOW64_64KEY;
541
542         when Read_Write_64 =>
543            return KEY_READ + KEY_WRITE + KEY_WOW64_64KEY;
544      end case;
545   end To_C_Mode;
546
547end GNAT.Registry;
548