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