gcc/ada/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-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
  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       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
 545 end GNAT.Registry;