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