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