Mark ChangeLog
[official-gcc.git] / gcc / ada / g-regist.adb
blobf63a7a97837b716d2260d71a6d4bc0e69a4f7302
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 ------------------------------------------------------------------------------
33 with Ada.Exceptions;
34 with Interfaces.C;
35 with System;
36 with GNAT.Directory_Operations;
38 package body GNAT.Registry is
40 use Ada;
41 use System;
43 ------------------------------
44 -- Binding to the Win32 API --
45 ------------------------------
47 subtype LONG is Interfaces.C.long;
48 subtype ULONG is Interfaces.C.unsigned_long;
49 subtype DWORD is ULONG;
51 type PULONG is access all ULONG;
52 subtype PDWORD is PULONG;
53 subtype LPDWORD is PDWORD;
55 subtype Error_Code is LONG;
57 subtype REGSAM is LONG;
59 type PHKEY is access all HKEY;
61 ERROR_SUCCESS : constant Error_Code := 0;
63 REG_SZ : constant := 1;
64 REG_EXPAND_SZ : constant := 2;
66 function RegCloseKey (Key : HKEY) return LONG;
67 pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
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");
82 function RegDeleteKey
83 (Key : HKEY;
84 lpSubKey : Address)
85 return LONG;
86 pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
88 function RegDeleteValue
89 (Key : HKEY;
90 lpValueName : Address)
91 return LONG;
92 pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
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");
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");
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");
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");
135 ---------------------
136 -- Local Constants --
137 ---------------------
139 Max_Key_Size : constant := 1_024;
140 -- Maximum number of characters for a registry key
142 Max_Value_Size : constant := 2_048;
143 -- Maximum number of characters for a key's value
145 -----------------------
146 -- Local Subprograms --
147 -----------------------
149 function To_C_Mode (Mode : Key_Mode) return REGSAM;
150 -- Returns the Win32 mode value for the Key_Mode value.
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.
157 ------------------
158 -- Check_Result --
159 ------------------
161 procedure Check_Result (Result : LONG; Message : String) is
162 use type LONG;
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;
172 ---------------
173 -- Close_Key --
174 ---------------
176 procedure Close_Key (Key : HKEY) is
177 Result : LONG;
179 begin
180 Result := RegCloseKey (Key);
181 Check_Result (Result, "Close_Key");
182 end Close_Key;
184 ----------------
185 -- Create_Key --
186 ----------------
188 function Create_Key
189 (From_Key : HKEY;
190 Sub_Key : String;
191 Mode : Key_Mode := Read_Write)
192 return HKEY
194 use type REGSAM;
195 use type DWORD;
197 REG_OPTION_NON_VOLATILE : constant := 16#0#;
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);
203 New_Key : aliased HKEY;
204 Result : LONG;
205 Dispos : aliased DWORD;
207 begin
208 Result := RegCreateKeyEx
209 (From_Key,
210 C_Sub_Key (C_Sub_Key'First)'Address,
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);
219 Check_Result (Result, "Create_Key " & Sub_Key);
220 return New_Key;
221 end Create_Key;
223 ----------------
224 -- Delete_Key --
225 ----------------
227 procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
228 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
229 Result : LONG;
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;
236 ------------------
237 -- Delete_Value --
238 ------------------
240 procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
241 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
242 Result : LONG;
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;
249 -------------------------
250 -- For_Every_Key_Value --
251 -------------------------
253 procedure For_Every_Key_Value
254 (From_Key : HKEY;
255 Expand : Boolean := False)
257 use GNAT.Directory_Operations;
258 use type LONG;
259 use type ULONG;
261 Index : ULONG := 0;
262 Result : LONG;
264 Sub_Key : String (1 .. Max_Key_Size);
265 pragma Warnings (Off, Sub_Key);
267 Value : String (1 .. Max_Value_Size);
268 pragma Warnings (Off, Value);
270 Size_Sub_Key : aliased ULONG;
271 Size_Value : aliased ULONG;
272 Type_Sub_Key : aliased DWORD;
274 Quit : Boolean;
276 begin
277 loop
278 Size_Sub_Key := Sub_Key'Length;
279 Size_Value := Value'Length;
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);
290 exit when not (Result = ERROR_SUCCESS);
292 Quit := False;
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);
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;
309 exit when Quit;
311 Index := Index + 1;
312 end loop;
313 end For_Every_Key_Value;
315 ----------------
316 -- Key_Exists --
317 ----------------
319 function Key_Exists
320 (From_Key : HKEY;
321 Sub_Key : String)
322 return Boolean
324 New_Key : HKEY;
326 begin
327 New_Key := Open_Key (From_Key, Sub_Key);
328 Close_Key (New_Key);
330 -- We have been able to open the key so it exists
332 return True;
334 exception
335 when Registry_Error =>
337 -- An error occurred, the key was not found
339 return False;
340 end Key_Exists;
342 --------------
343 -- Open_Key --
344 --------------
346 function Open_Key
347 (From_Key : HKEY;
348 Sub_Key : String;
349 Mode : Key_Mode := Read_Only)
350 return HKEY
352 use type REGSAM;
354 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
355 C_Mode : constant REGSAM := To_C_Mode (Mode);
357 New_Key : aliased HKEY;
358 Result : LONG;
360 begin
361 Result := RegOpenKeyEx
362 (From_Key,
363 C_Sub_Key (C_Sub_Key'First)'Address,
365 C_Mode,
366 New_Key'Unchecked_Access);
368 Check_Result (Result, "Open_Key " & Sub_Key);
369 return New_Key;
370 end Open_Key;
372 -----------------
373 -- Query_Value --
374 -----------------
376 function Query_Value
377 (From_Key : HKEY;
378 Sub_Key : String;
379 Expand : Boolean := False)
380 return String
382 use GNAT.Directory_Operations;
383 use type LONG;
384 use type ULONG;
386 Value : String (1 .. Max_Value_Size);
387 pragma Warnings (Off, Value);
389 Size_Value : aliased ULONG;
390 Type_Value : aliased DWORD;
392 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
393 Result : LONG;
395 begin
396 Size_Value := Value'Length;
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);
406 Check_Result (Result, "Query_Value " & Sub_Key & " key");
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;
416 ---------------
417 -- Set_Value --
418 ---------------
420 procedure Set_Value
421 (From_Key : HKEY;
422 Sub_Key : String;
423 Value : String)
425 C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
426 C_Value : constant String := Value & ASCII.Nul;
428 Result : LONG;
430 begin
431 Result := RegSetValueEx
432 (From_Key,
433 C_Sub_Key (C_Sub_Key'First)'Address,
435 REG_SZ,
436 C_Value (C_Value'First)'Address,
437 C_Value'Length);
439 Check_Result (Result, "Set_Value " & Sub_Key & " key");
440 end Set_Value;
442 ---------------
443 -- To_C_Mode --
444 ---------------
446 function To_C_Mode (Mode : Key_Mode) return REGSAM is
447 use type REGSAM;
449 KEY_READ : constant := 16#20019#;
450 KEY_WRITE : constant := 16#20006#;
452 begin
453 case Mode is
454 when Read_Only =>
455 return KEY_READ;
457 when Read_Write =>
458 return KEY_READ + KEY_WRITE;
459 end case;
460 end To_C_Mode;
462 end GNAT.Registry;