1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . R E G I S T R Y --
9 -- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
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. --
29 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 ------------------------------------------------------------------------------
35 with GNAT
.Directory_Operations
;
37 package body GNAT
.Registry
is
41 ------------------------------
42 -- Binding to the Win32 API --
43 ------------------------------
45 subtype LONG
is Interfaces
.C
.long
;
46 subtype ULONG
is Interfaces
.C
.unsigned_long
;
47 subtype DWORD
is ULONG
;
49 type PULONG
is access all ULONG
;
50 subtype PDWORD
is PULONG
;
51 subtype LPDWORD
is PDWORD
;
53 subtype Error_Code
is LONG
;
55 subtype REGSAM
is LONG
;
57 type PHKEY
is access all HKEY
;
59 ERROR_SUCCESS
: constant Error_Code
:= 0;
61 REG_SZ
: constant := 1;
62 REG_EXPAND_SZ
: constant := 2;
64 function RegCloseKey
(Key
: HKEY
) return LONG
;
65 pragma Import
(Stdcall
, RegCloseKey
, "RegCloseKey");
67 function RegCreateKeyEx
74 lpSecurityAttributes
: Address
;
76 lpdwDisposition
: LPDWORD
)
78 pragma Import
(Stdcall
, RegCreateKeyEx
, "RegCreateKeyExA");
82 lpSubKey
: Address
) return LONG
;
83 pragma Import
(Stdcall
, RegDeleteKey
, "RegDeleteKeyA");
85 function RegDeleteValue
87 lpValueName
: Address
) return LONG
;
88 pragma Import
(Stdcall
, RegDeleteValue
, "RegDeleteValueA");
93 lpValueName
: Address
;
94 lpcbValueName
: LPDWORD
;
98 lpcbData
: LPDWORD
) return LONG
;
99 pragma Import
(Stdcall
, RegEnumValue
, "RegEnumValueA");
101 function RegOpenKeyEx
106 phkResult
: PHKEY
) return LONG
;
107 pragma Import
(Stdcall
, RegOpenKeyEx
, "RegOpenKeyExA");
109 function RegQueryValueEx
111 lpValueName
: Address
;
112 lpReserved
: LPDWORD
;
115 lpcbData
: LPDWORD
) return LONG
;
116 pragma Import
(Stdcall
, RegQueryValueEx
, "RegQueryValueExA");
118 function RegSetValueEx
120 lpValueName
: Address
;
124 cbData
: DWORD
) return LONG
;
125 pragma Import
(Stdcall
, RegSetValueEx
, "RegSetValueExA");
127 ---------------------
128 -- Local Constants --
129 ---------------------
131 Max_Key_Size
: constant := 1_024
;
132 -- Maximum number of characters for a registry key
134 Max_Value_Size
: constant := 2_048
;
135 -- Maximum number of characters for a key's value
137 -----------------------
138 -- Local Subprograms --
139 -----------------------
141 function To_C_Mode
(Mode
: Key_Mode
) return REGSAM
;
142 -- Returns the Win32 mode value for the Key_Mode value
144 procedure Check_Result
(Result
: LONG
; Message
: String);
145 -- Checks value Result and raise the exception Registry_Error if it is not
146 -- equal to ERROR_SUCCESS. Message and the error value (Result) is added
147 -- to the exception message.
153 procedure Check_Result
(Result
: LONG
; Message
: String) is
156 if Result
/= ERROR_SUCCESS
then
157 raise Registry_Error
with
158 Message
& " (" & LONG
'Image (Result
) & ')';
166 procedure Close_Key
(Key
: HKEY
) is
169 Result
:= RegCloseKey
(Key
);
170 Check_Result
(Result
, "Close_Key");
180 Mode
: Key_Mode
:= Read_Write
) return HKEY
185 REG_OPTION_NON_VOLATILE
: constant := 16#
0#
;
187 C_Sub_Key
: constant String := Sub_Key
& ASCII
.NUL
;
188 C_Class
: constant String := "" & ASCII
.NUL
;
189 C_Mode
: constant REGSAM
:= To_C_Mode
(Mode
);
191 New_Key
: aliased HKEY
;
193 Dispos
: aliased DWORD
;
199 C_Sub_Key
(C_Sub_Key
'First)'Address,
201 C_Class
(C_Class
'First)'Address,
202 REG_OPTION_NON_VOLATILE
,
205 New_Key
'Unchecked_Access,
206 Dispos
'Unchecked_Access);
208 Check_Result
(Result
, "Create_Key " & Sub_Key
);
216 procedure Delete_Key
(From_Key
: HKEY
; Sub_Key
: String) is
217 C_Sub_Key
: constant String := Sub_Key
& ASCII
.NUL
;
220 Result
:= RegDeleteKey
(From_Key
, C_Sub_Key
(C_Sub_Key
'First)'Address);
221 Check_Result
(Result
, "Delete_Key " & Sub_Key
);
228 procedure Delete_Value
(From_Key
: HKEY
; Sub_Key
: String) is
229 C_Sub_Key
: constant String := Sub_Key
& ASCII
.NUL
;
232 Result
:= RegDeleteValue
(From_Key
, C_Sub_Key
(C_Sub_Key
'First)'Address);
233 Check_Result
(Result
, "Delete_Value " & Sub_Key
);
236 -------------------------
237 -- For_Every_Key_Value --
238 -------------------------
240 procedure For_Every_Key_Value
242 Expand
: Boolean := False)
244 use GNAT
.Directory_Operations
;
251 Sub_Key
: String (1 .. Max_Key_Size
);
252 pragma Warnings
(Off
, Sub_Key
);
254 Value
: String (1 .. Max_Value_Size
);
255 pragma Warnings
(Off
, Value
);
257 Size_Sub_Key
: aliased ULONG
;
258 Size_Value
: aliased ULONG
;
259 Type_Sub_Key
: aliased DWORD
;
265 Size_Sub_Key
:= Sub_Key
'Length;
266 Size_Value
:= Value
'Length;
272 Size_Sub_Key
'Unchecked_Access,
274 Type_Sub_Key
'Unchecked_Access,
276 Size_Value
'Unchecked_Access);
278 exit when not (Result
= ERROR_SUCCESS
);
282 if Type_Sub_Key
= REG_EXPAND_SZ
and then Expand
then
284 (Natural (Index
) + 1,
285 Sub_Key
(1 .. Integer (Size_Sub_Key
)),
286 Directory_Operations
.Expand_Path
287 (Value
(1 .. Integer (Size_Value
) - 1),
288 Directory_Operations
.DOS
),
291 elsif Type_Sub_Key
= REG_SZ
or else Type_Sub_Key
= REG_EXPAND_SZ
then
293 (Natural (Index
) + 1,
294 Sub_Key
(1 .. Integer (Size_Sub_Key
)),
295 Value
(1 .. Integer (Size_Value
) - 1),
303 end For_Every_Key_Value
;
311 Sub_Key
: String) return Boolean
316 New_Key
:= Open_Key
(From_Key
, Sub_Key
);
319 -- We have been able to open the key so it exists
324 when Registry_Error
=>
326 -- An error occurred, the key was not found
338 Mode
: Key_Mode
:= Read_Only
) return HKEY
342 C_Sub_Key
: constant String := Sub_Key
& ASCII
.NUL
;
343 C_Mode
: constant REGSAM
:= To_C_Mode
(Mode
);
345 New_Key
: aliased HKEY
;
352 C_Sub_Key
(C_Sub_Key
'First)'Address,
355 New_Key
'Unchecked_Access);
357 Check_Result
(Result
, "Open_Key " & Sub_Key
);
368 Expand
: Boolean := False) return String
370 use GNAT
.Directory_Operations
;
374 Value
: String (1 .. Max_Value_Size
);
375 pragma Warnings
(Off
, Value
);
377 Size_Value
: aliased ULONG
;
378 Type_Value
: aliased DWORD
;
380 C_Sub_Key
: constant String := Sub_Key
& ASCII
.NUL
;
384 Size_Value
:= Value
'Length;
389 C_Sub_Key
(C_Sub_Key
'First)'Address,
391 Type_Value
'Unchecked_Access,
392 Value
(Value
'First)'Address,
393 Size_Value
'Unchecked_Access);
395 Check_Result
(Result
, "Query_Value " & Sub_Key
& " key");
397 if Type_Value
= REG_EXPAND_SZ
and then Expand
then
398 return Directory_Operations
.Expand_Path
399 (Value
(1 .. Integer (Size_Value
- 1)), Directory_Operations
.DOS
);
401 return Value
(1 .. Integer (Size_Value
- 1));
413 Expand
: Boolean := False)
415 C_Sub_Key
: constant String := Sub_Key
& ASCII
.NUL
;
416 C_Value
: constant String := Value
& ASCII
.NUL
;
423 Value_Type
:= REG_EXPAND_SZ
;
425 Value_Type
:= REG_SZ
;
431 C_Sub_Key
(C_Sub_Key
'First)'Address,
434 C_Value
(C_Value
'First)'Address,
437 Check_Result
(Result
, "Set_Value " & Sub_Key
& " key");
444 function To_C_Mode
(Mode
: Key_Mode
) return REGSAM
is
447 KEY_READ
: constant := 16#
20019#
;
448 KEY_WRITE
: constant := 16#
20006#
;
456 return KEY_READ
+ KEY_WRITE
;