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-2008, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  30 --                                                                          --
  31 ------------------------------------------------------------------------------
  32
  33 with Interfaces.C;
  34 with System;
  35 with GNAT.Directory_Operations;
  36
  37 package body GNAT.Registry is
  38
  39    use System;
  40
  41    ------------------------------
  42    -- Binding to the Win32 API --
  43    ------------------------------
  44
  45    subtype LONG is Interfaces.C.long;
  46    subtype ULONG is Interfaces.C.unsigned_long;
  47    subtype DWORD is ULONG;
  48
  49    type    PULONG is access all ULONG;
  50    subtype PDWORD is PULONG;
  51    subtype LPDWORD is PDWORD;
  52
  53    subtype Error_Code is LONG;
  54
  55    subtype REGSAM is LONG;
  56
  57    type PHKEY is access all HKEY;
  58
  59    ERROR_SUCCESS : constant Error_Code := 0;
  60
  61    REG_SZ        : constant := 1;
  62    REG_EXPAND_SZ : constant := 2;
  63
  64    function RegCloseKey (Key : HKEY) return LONG;
  65    pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
  66
  67    function RegCreateKeyEx
  68      (Key                  : HKEY;
  69       lpSubKey             : Address;
  70       Reserved             : DWORD;
  71       lpClass              : Address;
  72       dwOptions            : DWORD;
  73       samDesired           : REGSAM;
  74       lpSecurityAttributes : Address;
  75       phkResult            : PHKEY;
  76       lpdwDisposition      : LPDWORD)
  77       return                 LONG;
  78    pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
  79
  80    function RegDeleteKey
  81      (Key      : HKEY;
  82       lpSubKey : Address) return LONG;
  83    pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
  84
  85    function RegDeleteValue
  86      (Key         : HKEY;
  87       lpValueName : Address) return LONG;
  88    pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
  89
  90    function RegEnumValue
  91      (Key           : HKEY;
  92       dwIndex       : DWORD;
  93       lpValueName   : Address;
  94       lpcbValueName : LPDWORD;
  95       lpReserved    : LPDWORD;
  96       lpType        : LPDWORD;
  97       lpData        : Address;
  98       lpcbData      : LPDWORD) return LONG;
  99    pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
 100
 101    function RegOpenKeyEx
 102      (Key        : HKEY;
 103       lpSubKey   : Address;
 104       ulOptions  : DWORD;
 105       samDesired : REGSAM;
 106       phkResult  : PHKEY) return LONG;
 107    pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
 108
 109    function RegQueryValueEx
 110      (Key         : HKEY;
 111       lpValueName : Address;
 112       lpReserved  : LPDWORD;
 113       lpType      : LPDWORD;
 114       lpData      : Address;
 115       lpcbData    : LPDWORD) return LONG;
 116    pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
 117
 118    function RegSetValueEx
 119      (Key         : HKEY;
 120       lpValueName : Address;
 121       Reserved    : DWORD;
 122       dwType      : DWORD;
 123       lpData      : Address;
 124       cbData      : DWORD) return LONG;
 125    pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
 126
 127    ---------------------
 128    -- Local Constants --
 129    ---------------------
 130
 131    Max_Key_Size : constant := 1_024;
 132    --  Maximum number of characters for a registry key
 133
 134    Max_Value_Size : constant := 2_048;
 135    --  Maximum number of characters for a key's value
 136
 137    -----------------------
 138    -- Local Subprograms --
 139    -----------------------
 140
 141    function To_C_Mode (Mode : Key_Mode) return REGSAM;
 142    --  Returns the Win32 mode value for the Key_Mode value
 143
 144    procedure Check_Result (Result : LONG; Message : String);
 145    --  Checks value Result and raise the exception Registry_Error if it is not
 146    --  equal to ERROR_SUCCESS. Message and the error value (Result) is added
 147    --  to the exception message.
 148
 149    ------------------
 150    -- Check_Result --
 151    ------------------
 152
 153    procedure Check_Result (Result : LONG; Message : String) is
 154       use type LONG;
 155    begin
 156       if Result /= ERROR_SUCCESS then
 157          raise Registry_Error with
 158            Message & " (" & LONG'Image (Result) & ')';
 159       end if;
 160    end Check_Result;
 161
 162    ---------------
 163    -- Close_Key --
 164    ---------------
 165
 166    procedure Close_Key (Key : HKEY) is
 167       Result : LONG;
 168    begin
 169       Result := RegCloseKey (Key);
 170       Check_Result (Result, "Close_Key");
 171    end Close_Key;
 172
 173    ----------------
 174    -- Create_Key --
 175    ----------------
 176
 177    function Create_Key
 178      (From_Key : HKEY;
 179       Sub_Key  : String;
 180       Mode     : Key_Mode := Read_Write) return HKEY
 181    is
 182       use type REGSAM;
 183       use type DWORD;
 184
 185       REG_OPTION_NON_VOLATILE : constant := 16#0#;
 186
 187       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 188       C_Class   : constant String := "" & ASCII.NUL;
 189       C_Mode    : constant REGSAM := To_C_Mode (Mode);
 190
 191       New_Key : aliased HKEY;
 192       Result  : LONG;
 193       Dispos  : aliased DWORD;
 194
 195    begin
 196       Result :=
 197         RegCreateKeyEx
 198           (From_Key,
 199            C_Sub_Key (C_Sub_Key'First)'Address,
 200            0,
 201            C_Class (C_Class'First)'Address,
 202            REG_OPTION_NON_VOLATILE,
 203            C_Mode,
 204            Null_Address,
 205            New_Key'Unchecked_Access,
 206            Dispos'Unchecked_Access);
 207
 208       Check_Result (Result, "Create_Key " & Sub_Key);
 209       return New_Key;
 210    end Create_Key;
 211
 212    ----------------
 213    -- Delete_Key --
 214    ----------------
 215
 216    procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
 217       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 218       Result    : LONG;
 219    begin
 220       Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
 221       Check_Result (Result, "Delete_Key " & Sub_Key);
 222    end Delete_Key;
 223
 224    ------------------
 225    -- Delete_Value --
 226    ------------------
 227
 228    procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
 229       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 230       Result    : LONG;
 231    begin
 232       Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
 233       Check_Result (Result, "Delete_Value " & Sub_Key);
 234    end Delete_Value;
 235
 236    -------------------------
 237    -- For_Every_Key_Value --
 238    -------------------------
 239
 240    procedure For_Every_Key_Value
 241      (From_Key : HKEY;
 242       Expand   : Boolean := False)
 243    is
 244       use GNAT.Directory_Operations;
 245       use type LONG;
 246       use type ULONG;
 247
 248       Index  : ULONG := 0;
 249       Result : LONG;
 250
 251       Sub_Key : String (1 .. Max_Key_Size);
 252       pragma Warnings (Off, Sub_Key);
 253
 254       Value : String (1 .. Max_Value_Size);
 255       pragma Warnings (Off, Value);
 256
 257       Size_Sub_Key : aliased ULONG;
 258       Size_Value   : aliased ULONG;
 259       Type_Sub_Key : aliased DWORD;
 260
 261       Quit : Boolean;
 262
 263    begin
 264       loop
 265          Size_Sub_Key := Sub_Key'Length;
 266          Size_Value   := Value'Length;
 267
 268          Result :=
 269            RegEnumValue
 270              (From_Key, Index,
 271               Sub_Key (1)'Address,
 272               Size_Sub_Key'Unchecked_Access,
 273               null,
 274               Type_Sub_Key'Unchecked_Access,
 275               Value (1)'Address,
 276               Size_Value'Unchecked_Access);
 277
 278          exit when not (Result = ERROR_SUCCESS);
 279
 280          Quit := False;
 281
 282          if Type_Sub_Key = REG_EXPAND_SZ and then Expand then
 283             Action
 284               (Natural (Index) + 1,
 285                Sub_Key (1 .. Integer (Size_Sub_Key)),
 286                Directory_Operations.Expand_Path
 287                  (Value (1 .. Integer (Size_Value) - 1),
 288                   Directory_Operations.DOS),
 289                Quit);
 290
 291          elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then
 292             Action
 293               (Natural (Index) + 1,
 294                Sub_Key (1 .. Integer (Size_Sub_Key)),
 295                Value (1 .. Integer (Size_Value) - 1),
 296                Quit);
 297          end if;
 298
 299          exit when Quit;
 300
 301          Index := Index + 1;
 302       end loop;
 303    end For_Every_Key_Value;
 304
 305    ----------------
 306    -- Key_Exists --
 307    ----------------
 308
 309    function Key_Exists
 310      (From_Key : HKEY;
 311       Sub_Key  : String) return Boolean
 312    is
 313       New_Key : HKEY;
 314
 315    begin
 316       New_Key := Open_Key (From_Key, Sub_Key);
 317       Close_Key (New_Key);
 318
 319       --  We have been able to open the key so it exists
 320
 321       return True;
 322
 323    exception
 324       when Registry_Error =>
 325
 326          --  An error occurred, the key was not found
 327
 328          return False;
 329    end Key_Exists;
 330
 331    --------------
 332    -- Open_Key --
 333    --------------
 334
 335    function Open_Key
 336      (From_Key : HKEY;
 337       Sub_Key  : String;
 338       Mode     : Key_Mode := Read_Only) return HKEY
 339    is
 340       use type REGSAM;
 341
 342       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 343       C_Mode    : constant REGSAM := To_C_Mode (Mode);
 344
 345       New_Key : aliased HKEY;
 346       Result  : LONG;
 347
 348    begin
 349       Result :=
 350         RegOpenKeyEx
 351           (From_Key,
 352            C_Sub_Key (C_Sub_Key'First)'Address,
 353            0,
 354            C_Mode,
 355            New_Key'Unchecked_Access);
 356
 357       Check_Result (Result, "Open_Key " & Sub_Key);
 358       return New_Key;
 359    end Open_Key;
 360
 361    -----------------
 362    -- Query_Value --
 363    -----------------
 364
 365    function Query_Value
 366      (From_Key : HKEY;
 367       Sub_Key  : String;
 368       Expand   : Boolean := False) return String
 369    is
 370       use GNAT.Directory_Operations;
 371       use type LONG;
 372       use type ULONG;
 373
 374       Value : String (1 .. Max_Value_Size);
 375       pragma Warnings (Off, Value);
 376
 377       Size_Value : aliased ULONG;
 378       Type_Value : aliased DWORD;
 379
 380       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 381       Result    : LONG;
 382
 383    begin
 384       Size_Value := Value'Length;
 385
 386       Result :=
 387         RegQueryValueEx
 388           (From_Key,
 389            C_Sub_Key (C_Sub_Key'First)'Address,
 390            null,
 391            Type_Value'Unchecked_Access,
 392            Value (Value'First)'Address,
 393            Size_Value'Unchecked_Access);
 394
 395       Check_Result (Result, "Query_Value " & Sub_Key & " key");
 396
 397       if Type_Value = REG_EXPAND_SZ and then Expand then
 398          return Directory_Operations.Expand_Path
 399            (Value (1 .. Integer (Size_Value - 1)), Directory_Operations.DOS);
 400       else
 401          return Value (1 .. Integer (Size_Value - 1));
 402       end if;
 403    end Query_Value;
 404
 405    ---------------
 406    -- Set_Value --
 407    ---------------
 408
 409    procedure Set_Value
 410       (From_Key : HKEY;
 411        Sub_Key  : String;
 412        Value    : String;
 413        Expand   : Boolean := False)
 414    is
 415       C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
 416       C_Value   : constant String := Value & ASCII.NUL;
 417
 418       Value_Type : DWORD;
 419       Result     : LONG;
 420
 421    begin
 422       if Expand then
 423          Value_Type := REG_EXPAND_SZ;
 424       else
 425          Value_Type := REG_SZ;
 426       end if;
 427
 428       Result :=
 429         RegSetValueEx
 430           (From_Key,
 431            C_Sub_Key (C_Sub_Key'First)'Address,
 432            0,
 433            Value_Type,
 434            C_Value (C_Value'First)'Address,
 435            C_Value'Length);
 436
 437       Check_Result (Result, "Set_Value " & Sub_Key & " key");
 438    end Set_Value;
 439
 440    ---------------
 441    -- To_C_Mode --
 442    ---------------
 443
 444    function To_C_Mode (Mode : Key_Mode) return REGSAM is
 445       use type REGSAM;
 446
 447       KEY_READ  : constant :=  16#20019#;
 448       KEY_WRITE : constant :=  16#20006#;
 449
 450    begin
 451       case Mode is
 452          when Read_Only =>
 453             return KEY_READ;
 454
 455          when Read_Write =>
 456             return KEY_READ + KEY_WRITE;
 457       end case;
 458    end To_C_Mode;
 459
 460 end GNAT.Registry;