1------------------------------------------------------------------------------ 2-- -- 3-- Matreshka Project -- 4-- -- 5-- Localization, Internationalization, Globalization for Ada -- 6-- -- 7-- Runtime Library Component -- 8-- -- 9------------------------------------------------------------------------------ 10-- -- 11-- Copyright © 2011, Vadim Godunko <vgodunko@gmail.com> -- 12-- All rights reserved. -- 13-- -- 14-- Redistribution and use in source and binary forms, with or without -- 15-- modification, are permitted provided that the following conditions -- 16-- are met: -- 17-- -- 18-- * Redistributions of source code must retain the above copyright -- 19-- notice, this list of conditions and the following disclaimer. -- 20-- -- 21-- * Redistributions in binary form must reproduce the above copyright -- 22-- notice, this list of conditions and the following disclaimer in the -- 23-- documentation and/or other materials provided with the distribution. -- 24-- -- 25-- * Neither the name of the Vadim Godunko, IE nor the names of its -- 26-- contributors may be used to endorse or promote products derived from -- 27-- this software without specific prior written permission. -- 28-- -- 29-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- 30-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- 31-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- 32-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- 33-- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- 34-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- 35-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- 36-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- 37-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- 38-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- 39-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- 40-- -- 41------------------------------------------------------------------------------ 42-- $Revision: 2043 $ $Date: 2011-07-27 20:39:43 +0400 (Wed, 27 Jul 2011) $ 43------------------------------------------------------------------------------ 44with Ada.Unchecked_Conversion; 45with Interfaces.C; 46 47with League.Characters; 48with League.Strings.Internals; 49with Matreshka.Internals.Strings.C; 50with Matreshka.Internals.Utf16; 51with Matreshka.Internals.Windows; 52 53package body Matreshka.Internals.Settings.Registry is 54 55 use Matreshka.Internals.Windows; 56 use type League.Characters.Universal_Character; 57 58 ----------------- 59 -- Windows API -- 60 ----------------- 61 62 type ACCESS_MASK is new Interfaces.C.unsigned_long; 63 64 type REGSAM is new ACCESS_MASK; 65 66 type PHKEY is access all HKEY; 67 68 type SECURITY_ATTRIBUTES is null record; 69 type LPSECURITY_ATTRIBUTES is access all SECURITY_ATTRIBUTES; 70 pragma Convention (C, LPSECURITY_ATTRIBUTES); 71 72 KEY_WRITE : constant REGSAM := 16#20006#; 73 KEY_READ : constant REGSAM := 16#20019#; 74 75 use type LONG; 76 77 type LPDWORD is access all DWORD; 78 79 REG_OPTION_NON_VOLATILE : constant DWORD := 0; 80 81 REG_SZ : constant DWORD := 1; 82 83 function To_HKEY is 84 new Ada.Unchecked_Conversion (Interfaces.C.unsigned, HKEY); 85 86 No_HKEY : constant HKEY := HKEY (System.Null_Address); 87 88 HKEY_CLASSES_ROOT : constant HKEY := To_HKEY (16#8000_0000#); 89 HKEY_CURRENT_USER : constant HKEY := To_HKEY (16#8000_0001#); 90 HKEY_LOCAL_MACHINE : constant HKEY := To_HKEY (16#8000_0002#); 91 HKEY_USERS : constant HKEY := To_HKEY (16#8000_0003#); 92 93 function RegOpenKeyEx 94 (hKey : Registry.HKEY; 95 lpSubKey : Windows.LPCWSTR; 96 ulOptions : Interfaces.C.unsigned_long; 97 samDesired : REGSAM; 98 phkResult : PHKEY) return LONG; 99 pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExW"); 100 101 function RegCreateKeyEx 102 (hKey : Registry.HKEY; 103 lpSubKey : Windows.LPCWSTR; 104 Reserved : Interfaces.C.unsigned_long; 105 lpClass : Windows.LPWSTR; 106 dwOptions : DWORD; 107 samDesired : REGSAM; 108 lpSecurityAttributes : LPSECURITY_ATTRIBUTES; 109 phkResult : PHKEY; 110 lpdwDisposition : LPDWORD) return LONG; 111 pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExW"); 112 113 -- function RegCloseKey (hKey : Registry.HKEY) return LONG; 114 procedure RegCloseKey (hKey : Registry.HKEY); 115 pragma Import (Stdcall, RegCloseKey, "RegCloseKey"); 116 117 -- function RegFlushKey (hKey : Registry.HKEY) return LONG; 118 procedure RegFlushKey (hKey : Registry.HKEY); 119 pragma Import (Stdcall, RegFlushKey, "RegFlushKey"); 120 121 function RegSetValueEx 122 (hKey : Registry.HKEY; 123 lpSubKey : Windows.LPCWSTR; 124 Reserved : DWORD; 125 dwType : DWORD; 126 lpData : System.Address; 127 cbData : DWORD) return LONG; 128 pragma Import (Stdcall, RegSetValueEx, "RegSetValueExW"); 129 130 function RegQueryValueEx 131 (hKey : Registry.HKEY; 132 lpSubKey : Windows.LPCWSTR; 133 Reserved : LPDWORD; 134 lpType : LPDWORD; 135 lpData : System.Address; 136 lpcbData : LPDWORD) return LONG; 137 pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExW"); 138 139 function Create 140 (Manager : not null access Abstract_Manager'Class; 141 Name : League.Strings.Universal_String; 142 Root : HKEY; 143 Key : League.Strings.Universal_String; 144 Read_Only : Boolean) return not null Settings_Access; 145 -- Creates storage pointing to specified root and key. Read_Only means 146 -- that subtree is opened for reading only. 147 148 procedure Split_Path_Name 149 (Key : League.Strings.Universal_String; 150 Path : out League.Strings.Universal_String; 151 Name : out League.Strings.Universal_String); 152 -- Split key into path and name parts. 153 154 function Open_Or_Create 155 (Parent : HKEY; 156 Path : League.Strings.Universal_String) return HKEY; 157 -- Opens existing path or create new path and returns its handler. 158 159 function Open 160 (Parent : HKEY; 161 Path : League.Strings.Universal_String) return HKEY; 162 -- Opens existing path in read-only mode and returns its handler. 163 164 HKEY_CURRENT_USER_Name : constant League.Strings.Universal_String 165 := League.Strings.To_Universal_String ("HKEY_CURRENT_USER"); 166 HKEY_LOCAL_MACHINE_Name : constant League.Strings.Universal_String 167 := League.Strings.To_Universal_String ("HKEY_LOCAL_MACHINE"); 168 HKEY_CLASSES_ROOT_Name : constant League.Strings.Universal_String 169 := League.Strings.To_Universal_String ("HKEY_CLASSES_ROOT"); 170 HKEY_USERS_Name : constant League.Strings.Universal_String 171 := League.Strings.To_Universal_String ("HKEY_USERS"); 172 173 -------------- 174 -- Contains -- 175 -------------- 176 177 overriding function Contains 178 (Self : Registry_Settings; 179 Key : League.Strings.Universal_String) return Boolean 180 is 181 Handler : HKEY; 182 Path : League.Strings.Universal_String; 183 Name : League.Strings.Universal_String; 184 Found : Boolean := True; 185 186 begin 187 -- Compute path to open 188 189 Split_Path_Name (Key, Path, Name); 190 191 -- Try to open path 192 193 Handler := Open (Self.Handler, Path); 194 195 if Handler /= No_HKEY then 196 -- Try to retrieve value 197 198 if RegQueryValueEx 199 (Handler, 200 League.Strings.Internals.Internal (Name).Value (0)'Access, 201 null, 202 null, 203 System.Null_Address, 204 null) /= 0 205 then 206 Found := False; 207 end if; 208 209 RegCloseKey (Handler); 210 211 else 212 Found := False; 213 end if; 214 215 return Found; 216 end Contains; 217 218 ------------ 219 -- Create -- 220 ------------ 221 222 function Create 223 (Manager : not null access Abstract_Manager'Class; 224 Key : League.Strings.Universal_String; 225 Read_Only : Boolean) return not null Settings_Access 226 is 227 use type League.Strings.Universal_String; 228 229 Path : League.Strings.Universal_String := Key; 230 Separator : Natural; 231 232 begin 233 -- Remove leading backslash if any. 234 235 if Path.Element (1) = '\' then 236 Path := Path.Slice (2, Path.Length); 237 end if; 238 239 Separator := Path.Index ('\'); 240 241 if Separator = 0 then 242 Separator := Path.Length + 1; 243 end if; 244 245 if Path.Slice (1, Separator - 1) = HKEY_CURRENT_USER_Name then 246 return 247 Create 248 (Manager, 249 '\' & Path, 250 HKEY_CURRENT_USER, 251 Path.Slice (Separator + 1, Path.Length), 252 Read_Only); 253 254 elsif Path.Slice (1, Separator - 1) = HKEY_LOCAL_MACHINE_Name then 255 return 256 Create 257 (Manager, 258 '\' & Path, 259 HKEY_LOCAL_MACHINE, 260 Path.Slice (Separator + 1, Path.Length), 261 Read_Only); 262 263 elsif Path.Slice (1, Separator - 1) = HKEY_CLASSES_ROOT_Name then 264 return 265 Create 266 (Manager, 267 '\' & Path, 268 HKEY_CLASSES_ROOT, 269 Path.Slice (Separator + 1, Path.Length), 270 Read_Only); 271 272 elsif Path.Slice (1, Separator - 1) = HKEY_USERS_Name then 273 return 274 Create 275 (Manager, 276 '\' & Path, 277 HKEY_USERS, 278 Path.Slice (Separator + 1, Path.Length), 279 Read_Only); 280 281 else 282 return 283 Create 284 (Manager, 285 '\' & HKEY_LOCAL_MACHINE_Name & '\' & Path, 286 HKEY_LOCAL_MACHINE, 287 Path, 288 Read_Only); 289 end if; 290 end Create; 291 292 ------------ 293 -- Create -- 294 ------------ 295 296 function Create 297 (Manager : not null access Abstract_Manager'Class; 298 Name : League.Strings.Universal_String; 299 Root : HKEY; 300 Key : League.Strings.Universal_String; 301 Read_Only : Boolean) return not null Settings_Access is 302 begin 303 return Aux : constant not null Settings_Access 304 := new Registry_Settings' 305 (Counter => <>, 306 Manager => Manager, 307 Name => Name, 308 Handler => <>, 309 Read_Only => Read_Only) 310 do 311 declare 312 Self : Registry_Settings'Class 313 renames Registry_Settings'Class (Aux.all); 314 315 begin 316 if Self.Read_Only then 317 -- Open registry to read when Read_Only mode is specified. 318 319 Self.Handler := Open (Root, Key); 320 321 else 322 -- In Read_Write mode, try to open first. 323 324 Self.Handler := Open_Or_Create (Root, Key); 325 326 if Self.Handler = No_HKEY then 327 -- Fallback to read-only mode and try to open it to read. 328 329 Self.Read_Only := True; 330 Self.Handler := Open (Root, Key); 331 end if; 332 end if; 333 end; 334 end return; 335 end Create; 336 337 -------------- 338 -- Finalize -- 339 -------------- 340 341 overriding procedure Finalize 342 (Self : not null access Registry_Settings) is 343 begin 344 if Self.Handler /= No_HKEY then 345 RegCloseKey (Self.Handler); 346 Self.Handler := No_HKEY; 347 end if; 348 end Finalize; 349 350 ---------- 351 -- Name -- 352 ---------- 353 354 overriding function Name 355 (Self : not null access Registry_Settings) 356 return League.Strings.Universal_String is 357 begin 358 return Self.Name; 359 end Name; 360 361 ---------- 362 -- Open -- 363 ---------- 364 365 function Open 366 (Parent : HKEY; 367 Path : League.Strings.Universal_String) return HKEY 368 is 369 Handler : aliased HKEY; 370 371 begin 372 if RegOpenKeyEx 373 (Parent, 374 League.Strings.Internals.Internal (Path).Value (0)'Access, 375 0, 376 KEY_READ, 377 Handler'Unchecked_Access) /= 0 378 then 379 Handler := No_HKEY; 380 end if; 381 382 return Handler; 383 end Open; 384 385 -------------------- 386 -- Open_Or_Create -- 387 -------------------- 388 389 function Open_Or_Create 390 (Parent : HKEY; 391 Path : League.Strings.Universal_String) return HKEY 392 is 393 Handler : aliased HKEY; 394 395 begin 396 if RegOpenKeyEx 397 (Parent, 398 League.Strings.Internals.Internal (Path).Value (0)'Access, 399 0, 400 KEY_READ or KEY_WRITE, 401 Handler'Unchecked_Access) /= 0 402 then 403 -- Try to create path 404 405 if RegCreateKeyEx 406 (Parent, 407 League.Strings.Internals.Internal (Path).Value (0)'Access, 408 0, 409 null, 410 REG_OPTION_NON_VOLATILE, 411 KEY_READ or KEY_WRITE, 412 null, 413 Handler'Unchecked_Access, 414 null) /= 0 415 then 416 -- Operation failed. 417 418 Handler := No_HKEY; 419 end if; 420 end if; 421 422 return Handler; 423 end Open_Or_Create; 424 425 ------------ 426 -- Remove -- 427 ------------ 428 429 overriding procedure Remove 430 (Self : in out Registry_Settings; 431 Key : League.Strings.Universal_String) is 432 begin 433 null; 434 end Remove; 435 436 --------------- 437 -- Set_Value -- 438 --------------- 439 440 overriding procedure Set_Value 441 (Self : in out Registry_Settings; 442 Key : League.Strings.Universal_String; 443 Value : League.Holders.Holder) 444 is 445 use type Matreshka.Internals.Utf16.Utf16_String_Index; 446 447 Handler : aliased HKEY; 448 Path : League.Strings.Universal_String; 449 Name : League.Strings.Universal_String; 450 V : League.Strings.Universal_String; 451 452 begin 453 if Self.Handler = No_HKEY or Self.Read_Only then 454 -- Registry can't be modified in read-only mode. 455 456 return; 457 end if; 458 459 -- Compute path to open 460 461 Split_Path_Name (Key, Path, Name); 462 463 -- Try to open path 464 465 Handler := Open_Or_Create (Self.Handler, Path); 466 467 if Handler = No_HKEY then 468 -- Operation failed, return. 469 470 return; 471 end if; 472 473 -- Extract value. 474 475 V := League.Holders.Element (Value); 476 477 -- Store string. 478 479 if RegSetValueEx 480 (Handler, 481 League.Strings.Internals.Internal (Name).Value (0)'Access, 482 0, 483 REG_SZ, 484 League.Strings.Internals.Internal (V).Value (0)'Address, 485 DWORD ((League.Strings.Internals.Internal (V).Unused + 1) * 2)) /= 0 486 then 487 null; 488 end if; 489 490 RegCloseKey (Handler); 491 end Set_Value; 492 493 --------------------- 494 -- Split_Path_Name -- 495 --------------------- 496 497 procedure Split_Path_Name 498 (Key : League.Strings.Universal_String; 499 Path : out League.Strings.Universal_String; 500 Name : out League.Strings.Universal_String) is 501 begin 502 Path := League.Strings.Empty_Universal_String; 503 Name := Key; 504 505 for J in 1 .. Key.Length loop 506 if Key.Element (J) = '\' then 507 Path := Key.Slice (1, J - 1); 508 Name := Key.Slice (J + 1, Key.Length); 509 510 exit; 511 end if; 512 end loop; 513 end Split_Path_Name; 514 515 ---------- 516 -- Sync -- 517 ---------- 518 519 overriding procedure Sync (Self : in out Registry_Settings) is 520 begin 521 if Self.Handler /= No_HKEY and not Self.Read_Only then 522 -- RegFlushKey requires KEY_QUERY_VALUE access right, this right is 523 -- part of KEY_READ. 524 525 RegFlushKey (Self.Handler); 526 end if; 527 end Sync; 528 529 ----------- 530 -- Value -- 531 ----------- 532 533 overriding function Value 534 (Self : Registry_Settings; 535 Key : League.Strings.Universal_String) 536 return League.Holders.Holder 537 is 538 use Matreshka.Internals.Utf16; 539 use type DWORD; 540 541 Handler : HKEY; 542 Path : League.Strings.Universal_String; 543 Name : League.Strings.Universal_String; 544 V_Type : aliased DWORD; 545 V_Size : aliased DWORD; 546 Value : League.Holders.Holder; 547 548 begin 549 -- Compute path to open 550 551 Split_Path_Name (Key, Path, Name); 552 553 -- Try to open path 554 555 Handler := Open (Self.Handler, Path); 556 557 if Handler = No_HKEY then 558 return Value; 559 end if; 560 561 -- Try to retrieve value 562 563 if RegQueryValueEx 564 (Handler, 565 League.Strings.Internals.Internal (Name).Value (0)'Access, 566 null, 567 V_Type'Unchecked_Access, 568 System.Null_Address, 569 V_Size'Unchecked_Access) = 0 570 then 571 if V_Type = REG_SZ then 572 declare 573 V : Matreshka.Internals.Utf16.Utf16_String 574 (0 575 .. Matreshka.Internals.Utf16.Utf16_String_Index 576 (V_Size / 2)); 577 578 begin 579 if RegQueryValueEx 580 (Handler, 581 League.Strings.Internals.Internal (Name).Value (0)'Access, 582 null, 583 V_Type'Unchecked_Access, 584 V'Address, 585 V_Size'Unchecked_Access) = 0 586 then 587 V (V'Last) := 0; 588 League.Holders.Replace_Element 589 (Value, 590 Matreshka.Internals.Strings.C.To_Valid_Universal_String 591 (V (0)'Unchecked_Access)); 592 end if; 593 end; 594 end if; 595 end if; 596 597 RegCloseKey (Handler); 598 599 return Value; 600 end Value; 601 602end Matreshka.Internals.Settings.Registry; 603