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