gcc/ada/libgnat/g-regist.adb

   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-2017, 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
  31 with Interfaces.C;
  32 with System;
  33 with GNAT.Directory_Operations;
  34
  35 package 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
 547 end GNAT.Registry;