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    ---------------------
 126    -- Local Constants --
 127    ---------------------
 128
 129    Max_Key_Size : constant := 1_024;
 130    --  Maximum number of characters for a registry key
 131
 132    Max_Value_Size : constant := 2_048;
 133    --  Maximum number of characters for a key's value
 134
 135    -----------------------
 136    -- Local Subprograms --
 137    -----------------------
 138
 139    function To_C_Mode (Mode : Key_Mode) return REGSAM;
 140    --  Returns the Win32 mode value for the Key_Mode value
 141
 142    procedure Check_Result (Result : LONG; Message : String);
 143    --  Checks value Result and raise the exception Registry_Error if it is not
 144    --  equal to ERROR_SUCCESS. Message and the error value (Result) is added
 145    --  to the exception message.
 146
 147    ------------------
 148    -- Check_Result --
 149    ------------------
 150
 151    procedure Check_Result (Result : LONG; Message : String) is
 152       use type LONG;
 153    begin
 154       if Result /= ERROR_SUCCESS then
 155          raise Registry_Error with
 156            Message & " (" & LONG'Image (Result) & ')';
 157       end if;
 158    end Check_Result;
 159
 160    ---------------
 161    -- Close_Key --
 162    ---------------
 163
 164    procedure Close_Key (Key : HKEY) is
 165       Result : LONG;
 166    begin
 167       Result := RegCloseKey (Key);
 168       Check_Result (Result, "Close_Key");
 169    end Close_Key;
 170
 171    ----------------
 172    -- Create_Key --
 173    ----------------
 174
 175    function Create_Key
 176      (From_Key : HKEY;
 177       Sub_Key  : String;
 178       Mode     : Key_Mode := Read_Write) return HKEY
 179    is
 180       use type REGSAM;
 181       use type DWORD;
 182
 183       REG_OPTION_NON_VOLATILE : constant := 16#0#;
 184
 185       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 186       C_Class   : constant String := "" & ASCII.NUL;
 187       C_Mode    : constant REGSAM := To_C_Mode (Mode);
 188
 189       New_Key : aliased HKEY;
 190       Result  : LONG;
 191       Dispos  : aliased DWORD;
 192
 193    begin
 194       Result :=
 195         RegCreateKeyEx
 196           (From_Key,
 197            C_Sub_Key (C_Sub_Key'First)'Address,
 198            0,
 199            C_Class (C_Class'First)'Address,
 200            REG_OPTION_NON_VOLATILE,
 201            C_Mode,
 202            Null_Address,
 203            New_Key'Unchecked_Access,
 204            Dispos'Unchecked_Access);
 205
 206       Check_Result (Result, "Create_Key " & Sub_Key);
 207       return New_Key;
 208    end Create_Key;
 209
 210    ----------------
 211    -- Delete_Key --
 212    ----------------
 213
 214    procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
 215       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 216       Result    : LONG;
 217    begin
 218       Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
 219       Check_Result (Result, "Delete_Key " & Sub_Key);
 220    end Delete_Key;
 221
 222    ------------------
 223    -- Delete_Value --
 224    ------------------
 225
 226    procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
 227       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 228       Result    : LONG;
 229    begin
 230       Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
 231       Check_Result (Result, "Delete_Value " & Sub_Key);
 232    end Delete_Value;
 233
 234    -------------------------
 235    -- For_Every_Key_Value --
 236    -------------------------
 237
 238    procedure For_Every_Key_Value
 239      (From_Key : HKEY;
 240       Expand   : Boolean := False)
 241    is
 242       use GNAT.Directory_Operations;
 243       use type LONG;
 244       use type ULONG;
 245
 246       Index  : ULONG := 0;
 247       Result : LONG;
 248
 249       Sub_Key : String (1 .. Max_Key_Size);
 250       pragma Warnings (Off, Sub_Key);
 251
 252       Value : String (1 .. Max_Value_Size);
 253       pragma Warnings (Off, Value);
 254
 255       Size_Sub_Key : aliased ULONG;
 256       Size_Value   : aliased ULONG;
 257       Type_Sub_Key : aliased DWORD;
 258
 259       Quit : Boolean;
 260
 261    begin
 262       loop
 263          Size_Sub_Key := Sub_Key'Length;
 264          Size_Value   := Value'Length;
 265
 266          Result :=
 267            RegEnumValue
 268              (From_Key, Index,
 269               Sub_Key (1)'Address,
 270               Size_Sub_Key'Unchecked_Access,
 271               null,
 272               Type_Sub_Key'Unchecked_Access,
 273               Value (1)'Address,
 274               Size_Value'Unchecked_Access);
 275
 276          exit when not (Result = ERROR_SUCCESS);
 277
 278          Quit := False;
 279
 280          if Type_Sub_Key = REG_EXPAND_SZ and then Expand then
 281             Action
 282               (Natural (Index) + 1,
 283                Sub_Key (1 .. Integer (Size_Sub_Key)),
 284                Directory_Operations.Expand_Path
 285                  (Value (1 .. Integer (Size_Value) - 1),
 286                   Directory_Operations.DOS),
 287                Quit);
 288
 289          elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then
 290             Action
 291               (Natural (Index) + 1,
 292                Sub_Key (1 .. Integer (Size_Sub_Key)),
 293                Value (1 .. Integer (Size_Value) - 1),
 294                Quit);
 295          end if;
 296
 297          exit when Quit;
 298
 299          Index := Index + 1;
 300       end loop;
 301    end For_Every_Key_Value;
 302
 303    ----------------
 304    -- Key_Exists --
 305    ----------------
 306
 307    function Key_Exists
 308      (From_Key : HKEY;
 309       Sub_Key  : String) return Boolean
 310    is
 311       New_Key : HKEY;
 312
 313    begin
 314       New_Key := Open_Key (From_Key, Sub_Key);
 315       Close_Key (New_Key);
 316
 317       --  We have been able to open the key so it exists
 318
 319       return True;
 320
 321    exception
 322       when Registry_Error =>
 323
 324          --  An error occurred, the key was not found
 325
 326          return False;
 327    end Key_Exists;
 328
 329    --------------
 330    -- Open_Key --
 331    --------------
 332
 333    function Open_Key
 334      (From_Key : HKEY;
 335       Sub_Key  : String;
 336       Mode     : Key_Mode := Read_Only) return HKEY
 337    is
 338       use type REGSAM;
 339
 340       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 341       C_Mode    : constant REGSAM := To_C_Mode (Mode);
 342
 343       New_Key : aliased HKEY;
 344       Result  : LONG;
 345
 346    begin
 347       Result :=
 348         RegOpenKeyEx
 349           (From_Key,
 350            C_Sub_Key (C_Sub_Key'First)'Address,
 351            0,
 352            C_Mode,
 353            New_Key'Unchecked_Access);
 354
 355       Check_Result (Result, "Open_Key " & Sub_Key);
 356       return New_Key;
 357    end Open_Key;
 358
 359    -----------------
 360    -- Query_Value --
 361    -----------------
 362
 363    function Query_Value
 364      (From_Key : HKEY;
 365       Sub_Key  : String;
 366       Expand   : Boolean := False) return String
 367    is
 368       use GNAT.Directory_Operations;
 369       use type LONG;
 370       use type ULONG;
 371
 372       Value : String (1 .. Max_Value_Size);
 373       pragma Warnings (Off, Value);
 374
 375       Size_Value : aliased ULONG;
 376       Type_Value : aliased DWORD;
 377
 378       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 379       Result    : LONG;
 380
 381    begin
 382       Size_Value := Value'Length;
 383
 384       Result :=
 385         RegQueryValueEx
 386           (From_Key,
 387            C_Sub_Key (C_Sub_Key'First)'Address,
 388            null,
 389            Type_Value'Unchecked_Access,
 390            Value (Value'First)'Address,
 391            Size_Value'Unchecked_Access);
 392
 393       Check_Result (Result, "Query_Value " & Sub_Key & " key");
 394
 395       if Type_Value = REG_EXPAND_SZ and then Expand then
 396          return Directory_Operations.Expand_Path
 397            (Value (1 .. Integer (Size_Value - 1)), Directory_Operations.DOS);
 398       else
 399          return Value (1 .. Integer (Size_Value - 1));
 400       end if;
 401    end Query_Value;
 402
 403    ---------------
 404    -- Set_Value --
 405    ---------------
 406
 407    procedure Set_Value
 408       (From_Key : HKEY;
 409        Sub_Key  : String;
 410        Value    : String;
 411        Expand   : Boolean := False)
 412    is
 413       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 414       C_Value   : constant String := Value & ASCII.NUL;
 415
 416       Value_Type : DWORD;
 417       Result     : LONG;
 418
 419    begin
 420       if Expand then
 421          Value_Type := REG_EXPAND_SZ;
 422       else
 423          Value_Type := REG_SZ;
 424       end if;
 425
 426       Result :=
 427         RegSetValueEx
 428           (From_Key,
 429            C_Sub_Key (C_Sub_Key'First)'Address,
 430            0,
 431            Value_Type,
 432            C_Value (C_Value'First)'Address,
 433            C_Value'Length);
 434
 435       Check_Result (Result, "Set_Value " & Sub_Key & " key");
 436    end Set_Value;
 437
 438    ---------------
 439    -- To_C_Mode --
 440    ---------------
 441
 442    function To_C_Mode (Mode : Key_Mode) return REGSAM is
 443       use type REGSAM;
 444
 445       KEY_READ  : constant :=  16#20019#;
 446       KEY_WRITE : constant :=  16#20006#;
 447
 448    begin
 449       case Mode is
 450          when Read_Only =>
 451             return KEY_READ;
 452
 453          when Read_Write =>
 454             return KEY_READ + KEY_WRITE;
 455       end case;
 456    end To_C_Mode;
 457
 458 end GNAT.Registry;