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-2003 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 2,  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.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- Extensive contributions were provided by Ada Core Technologies Inc.      --
30--                                                                          --
31------------------------------------------------------------------------------
32
33with Ada.Exceptions;
34with Interfaces.C;
35with System;
36with GNAT.Directory_Operations;
37
38package body GNAT.Registry is
39
40   use Ada;
41   use System;
42
43   ------------------------------
44   -- Binding to the Win32 API --
45   ------------------------------
46
47   subtype LONG is Interfaces.C.long;
48   subtype ULONG is Interfaces.C.unsigned_long;
49   subtype DWORD is ULONG;
50
51   type    PULONG is access all ULONG;
52   subtype PDWORD is PULONG;
53   subtype LPDWORD is PDWORD;
54
55   subtype Error_Code is LONG;
56
57   subtype REGSAM is LONG;
58
59   type PHKEY is access all HKEY;
60
61   ERROR_SUCCESS : constant Error_Code := 0;
62
63   REG_SZ        : constant := 1;
64   REG_EXPAND_SZ : constant := 2;
65
66   function RegCloseKey (Key : HKEY) return LONG;
67   pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
68
69   function RegCreateKeyEx
70     (Key                  : HKEY;
71      lpSubKey             : Address;
72      Reserved             : DWORD;
73      lpClass              : Address;
74      dwOptions            : DWORD;
75      samDesired           : REGSAM;
76      lpSecurityAttributes : Address;
77      phkResult            : PHKEY;
78      lpdwDisposition      : LPDWORD)
79      return                 LONG;
80   pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
81
82   function RegDeleteKey
83     (Key      : HKEY;
84      lpSubKey : Address)
85      return     LONG;
86   pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
87
88   function RegDeleteValue
89     (Key         : HKEY;
90      lpValueName : Address)
91      return        LONG;
92   pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
93
94   function RegEnumValue
95     (Key           : HKEY;
96      dwIndex       : DWORD;
97      lpValueName   : Address;
98      lpcbValueName : LPDWORD;
99      lpReserved    : LPDWORD;
100      lpType        : LPDWORD;
101      lpData        : Address;
102      lpcbData      : LPDWORD)
103      return          LONG;
104   pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
105
106   function RegOpenKeyEx
107     (Key        : HKEY;
108      lpSubKey   : Address;
109      ulOptions  : DWORD;
110      samDesired : REGSAM;
111      phkResult  : PHKEY)
112      return       LONG;
113   pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
114
115   function RegQueryValueEx
116     (Key         : HKEY;
117      lpValueName : Address;
118      lpReserved  : LPDWORD;
119      lpType      : LPDWORD;
120      lpData      : Address;
121      lpcbData    : LPDWORD)
122      return        LONG;
123   pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
124
125   function RegSetValueEx
126     (Key         : HKEY;
127      lpValueName : Address;
128      Reserved    : DWORD;
129      dwType      : DWORD;
130      lpData      : Address;
131      cbData      : DWORD)
132      return        LONG;
133   pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
134
135   ---------------------
136   -- Local Constants --
137   ---------------------
138
139   Max_Key_Size   : constant := 1_024;
140   --  Maximum number of characters for a registry key
141
142   Max_Value_Size : constant := 2_048;
143   --  Maximum number of characters for a key's value
144
145   -----------------------
146   -- Local Subprograms --
147   -----------------------
148
149   function To_C_Mode (Mode : Key_Mode) return REGSAM;
150   --  Returns the Win32 mode value for the Key_Mode value.
151
152   procedure Check_Result (Result : LONG; Message : String);
153   --  Checks value Result and raise the exception Registry_Error if it is not
154   --  equal to ERROR_SUCCESS. Message and the error value (Result) is added
155   --  to the exception message.
156
157   ------------------
158   -- Check_Result --
159   ------------------
160
161   procedure Check_Result (Result : LONG; Message : String) is
162      use type LONG;
163
164   begin
165      if Result /= ERROR_SUCCESS then
166         Exceptions.Raise_Exception
167           (Registry_Error'Identity,
168            Message & " (" & LONG'Image (Result) & ')');
169      end if;
170   end Check_Result;
171
172   ---------------
173   -- Close_Key --
174   ---------------
175
176   procedure Close_Key (Key : HKEY) is
177      Result : LONG;
178
179   begin
180      Result := RegCloseKey (Key);
181      Check_Result (Result, "Close_Key");
182   end Close_Key;
183
184   ----------------
185   -- Create_Key --
186   ----------------
187
188   function Create_Key
189     (From_Key : HKEY;
190      Sub_Key  : String;
191      Mode     : Key_Mode := Read_Write)
192      return     HKEY
193   is
194      use type REGSAM;
195      use type DWORD;
196
197      REG_OPTION_NON_VOLATILE : constant := 16#0#;
198
199      C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
200      C_Class   : constant String := "" & ASCII.Nul;
201      C_Mode    : constant REGSAM := To_C_Mode (Mode);
202
203      New_Key : aliased HKEY;
204      Result  : LONG;
205      Dispos  : aliased DWORD;
206
207   begin
208      Result := RegCreateKeyEx
209        (From_Key,
210         C_Sub_Key (C_Sub_Key'First)'Address,
211         0,
212         C_Class (C_Class'First)'Address,
213         REG_OPTION_NON_VOLATILE,
214         C_Mode,
215         Null_Address,
216         New_Key'Unchecked_Access,
217         Dispos'Unchecked_Access);
218
219      Check_Result (Result, "Create_Key " & Sub_Key);
220      return New_Key;
221   end Create_Key;
222
223   ----------------
224   -- Delete_Key --
225   ----------------
226
227   procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
228      C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
229      Result    : LONG;
230
231   begin
232      Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
233      Check_Result (Result, "Delete_Key " & Sub_Key);
234   end Delete_Key;
235
236   ------------------
237   -- Delete_Value --
238   ------------------
239
240   procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
241      C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
242      Result    : LONG;
243
244   begin
245      Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
246      Check_Result (Result, "Delete_Value " & Sub_Key);
247   end Delete_Value;
248
249   -------------------------
250   -- For_Every_Key_Value --
251   -------------------------
252
253   procedure For_Every_Key_Value
254     (From_Key : HKEY;
255      Expand   : Boolean := False)
256   is
257      use GNAT.Directory_Operations;
258      use type LONG;
259      use type ULONG;
260
261      Index  : ULONG := 0;
262      Result : LONG;
263
264      Sub_Key : String (1 .. Max_Key_Size);
265      pragma Warnings (Off, Sub_Key);
266
267      Value : String (1 .. Max_Value_Size);
268      pragma Warnings (Off, Value);
269
270      Size_Sub_Key : aliased ULONG;
271      Size_Value   : aliased ULONG;
272      Type_Sub_Key : aliased DWORD;
273
274      Quit : Boolean;
275
276   begin
277      loop
278         Size_Sub_Key := Sub_Key'Length;
279         Size_Value   := Value'Length;
280
281         Result := RegEnumValue
282           (From_Key, Index,
283            Sub_Key (1)'Address,
284            Size_Sub_Key'Unchecked_Access,
285            null,
286            Type_Sub_Key'Unchecked_Access,
287            Value (1)'Address,
288            Size_Value'Unchecked_Access);
289
290         exit when not (Result = ERROR_SUCCESS);
291
292         Quit := False;
293
294         if Type_Sub_Key = REG_EXPAND_SZ and then Expand then
295               Action (Natural (Index) + 1,
296                       Sub_Key (1 .. Integer (Size_Sub_Key)),
297                       Directory_Operations.Expand_Path
298                         (Value (1 .. Integer (Size_Value) - 1),
299                          Directory_Operations.DOS),
300                       Quit);
301
302         elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then
303            Action (Natural (Index) + 1,
304                    Sub_Key (1 .. Integer (Size_Sub_Key)),
305                    Value (1 .. Integer (Size_Value) - 1),
306                    Quit);
307         end if;
308
309         exit when Quit;
310
311         Index := Index + 1;
312      end loop;
313   end For_Every_Key_Value;
314
315   ----------------
316   -- Key_Exists --
317   ----------------
318
319   function Key_Exists
320     (From_Key : HKEY;
321      Sub_Key  : String)
322      return     Boolean
323   is
324      New_Key : HKEY;
325
326   begin
327      New_Key := Open_Key (From_Key, Sub_Key);
328      Close_Key (New_Key);
329
330      --  We have been able to open the key so it exists
331
332      return True;
333
334   exception
335      when Registry_Error =>
336
337         --  An error occurred, the key was not found
338
339         return False;
340   end Key_Exists;
341
342   --------------
343   -- Open_Key --
344   --------------
345
346   function Open_Key
347     (From_Key : HKEY;
348      Sub_Key  : String;
349      Mode     : Key_Mode := Read_Only)
350      return     HKEY
351   is
352      use type REGSAM;
353
354      C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
355      C_Mode    : constant REGSAM := To_C_Mode (Mode);
356
357      New_Key   : aliased HKEY;
358      Result    : LONG;
359
360   begin
361      Result := RegOpenKeyEx
362        (From_Key,
363         C_Sub_Key (C_Sub_Key'First)'Address,
364         0,
365         C_Mode,
366         New_Key'Unchecked_Access);
367
368      Check_Result (Result, "Open_Key " & Sub_Key);
369      return New_Key;
370   end Open_Key;
371
372   -----------------
373   -- Query_Value --
374   -----------------
375
376   function Query_Value
377     (From_Key : HKEY;
378      Sub_Key  : String;
379      Expand   : Boolean := False)
380      return     String
381   is
382      use GNAT.Directory_Operations;
383      use type LONG;
384      use type ULONG;
385
386      Value : String (1 .. Max_Value_Size);
387      pragma Warnings (Off, Value);
388
389      Size_Value : aliased ULONG;
390      Type_Value : aliased DWORD;
391
392      C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
393      Result    : LONG;
394
395   begin
396      Size_Value := Value'Length;
397
398      Result := RegQueryValueEx
399        (From_Key,
400         C_Sub_Key (C_Sub_Key'First)'Address,
401         null,
402         Type_Value'Unchecked_Access,
403         Value (Value'First)'Address,
404         Size_Value'Unchecked_Access);
405
406      Check_Result (Result, "Query_Value " & Sub_Key & " key");
407
408      if Type_Value = REG_EXPAND_SZ and then Expand then
409         return Directory_Operations.Expand_Path
410           (Value (1 .. Integer (Size_Value - 1)), Directory_Operations.DOS);
411      else
412         return Value (1 .. Integer (Size_Value - 1));
413      end if;
414   end Query_Value;
415
416   ---------------
417   -- Set_Value --
418   ---------------
419
420   procedure Set_Value
421     (From_Key : HKEY;
422      Sub_Key  : String;
423      Value    : String)
424   is
425      C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
426      C_Value   : constant String := Value & ASCII.Nul;
427
428      Result : LONG;
429
430   begin
431      Result := RegSetValueEx
432        (From_Key,
433         C_Sub_Key (C_Sub_Key'First)'Address,
434         0,
435         REG_SZ,
436         C_Value (C_Value'First)'Address,
437         C_Value'Length);
438
439      Check_Result (Result, "Set_Value " & Sub_Key & " key");
440   end Set_Value;
441
442   ---------------
443   -- To_C_Mode --
444   ---------------
445
446   function To_C_Mode (Mode : Key_Mode) return REGSAM is
447      use type REGSAM;
448
449      KEY_READ  : constant :=  16#20019#;
450      KEY_WRITE : constant :=  16#20006#;
451
452   begin
453      case Mode is
454         when Read_Only =>
455            return KEY_READ;
456
457         when Read_Write =>
458            return KEY_READ + KEY_WRITE;
459      end case;
460   end To_C_Mode;
461
462end GNAT.Registry;
463