old-autovect-branch/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-2005, 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
 158    begin
 159       if Result /= ERROR_SUCCESS then
 160          Exceptions.Raise_Exception
 161            (Registry_Error'Identity,
 162             Message & " (" & LONG'Image (Result) & ')');
 163       end if;
 164    end Check_Result;
 165
 166    ---------------
 167    -- Close_Key --
 168    ---------------
 169
 170    procedure Close_Key (Key : HKEY) is
 171       Result : LONG;
 172
 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 := RegCreateKeyEx
 202         (From_Key,
 203          C_Sub_Key (C_Sub_Key'First)'Address,
 204          0,
 205          C_Class (C_Class'First)'Address,
 206          REG_OPTION_NON_VOLATILE,
 207          C_Mode,
 208          Null_Address,
 209          New_Key'Unchecked_Access,
 210          Dispos'Unchecked_Access);
 211
 212       Check_Result (Result, "Create_Key " & Sub_Key);
 213       return New_Key;
 214    end Create_Key;
 215
 216    ----------------
 217    -- Delete_Key --
 218    ----------------
 219
 220    procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
 221       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 222       Result    : LONG;
 223
 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
 237    begin
 238       Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
 239       Check_Result (Result, "Delete_Value " & Sub_Key);
 240    end Delete_Value;
 241
 242    -------------------------
 243    -- For_Every_Key_Value --
 244    -------------------------
 245
 246    procedure For_Every_Key_Value
 247      (From_Key : HKEY;
 248       Expand   : Boolean := False)
 249    is
 250       use GNAT.Directory_Operations;
 251       use type LONG;
 252       use type ULONG;
 253
 254       Index  : ULONG := 0;
 255       Result : LONG;
 256
 257       Sub_Key : String (1 .. Max_Key_Size);
 258       pragma Warnings (Off, Sub_Key);
 259
 260       Value : String (1 .. Max_Value_Size);
 261       pragma Warnings (Off, Value);
 262
 263       Size_Sub_Key : aliased ULONG;
 264       Size_Value   : aliased ULONG;
 265       Type_Sub_Key : aliased DWORD;
 266
 267       Quit : Boolean;
 268
 269    begin
 270       loop
 271          Size_Sub_Key := Sub_Key'Length;
 272          Size_Value   := Value'Length;
 273
 274          Result := RegEnumValue
 275            (From_Key, Index,
 276             Sub_Key (1)'Address,
 277             Size_Sub_Key'Unchecked_Access,
 278             null,
 279             Type_Sub_Key'Unchecked_Access,
 280             Value (1)'Address,
 281             Size_Value'Unchecked_Access);
 282
 283          exit when not (Result = ERROR_SUCCESS);
 284
 285          Quit := False;
 286
 287          if Type_Sub_Key = REG_EXPAND_SZ and then Expand then
 288                Action (Natural (Index) + 1,
 289                        Sub_Key (1 .. Integer (Size_Sub_Key)),
 290                        Directory_Operations.Expand_Path
 291                          (Value (1 .. Integer (Size_Value) - 1),
 292                           Directory_Operations.DOS),
 293                        Quit);
 294
 295          elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then
 296             Action (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 := RegOpenKeyEx
 353         (From_Key,
 354          C_Sub_Key (C_Sub_Key'First)'Address,
 355          0,
 356          C_Mode,
 357          New_Key'Unchecked_Access);
 358
 359       Check_Result (Result, "Open_Key " & Sub_Key);
 360       return New_Key;
 361    end Open_Key;
 362
 363    -----------------
 364    -- Query_Value --
 365    -----------------
 366
 367    function Query_Value
 368      (From_Key : HKEY;
 369       Sub_Key  : String;
 370       Expand   : Boolean := False) return String
 371    is
 372       use GNAT.Directory_Operations;
 373       use type LONG;
 374       use type ULONG;
 375
 376       Value : String (1 .. Max_Value_Size);
 377       pragma Warnings (Off, Value);
 378
 379       Size_Value : aliased ULONG;
 380       Type_Value : aliased DWORD;
 381
 382       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 383       Result    : LONG;
 384
 385    begin
 386       Size_Value := Value'Length;
 387
 388       Result := RegQueryValueEx
 389         (From_Key,
 390          C_Sub_Key (C_Sub_Key'First)'Address,
 391          null,
 392          Type_Value'Unchecked_Access,
 393          Value (Value'First)'Address,
 394          Size_Value'Unchecked_Access);
 395
 396       Check_Result (Result, "Query_Value " & Sub_Key & " key");
 397
 398       if Type_Value = REG_EXPAND_SZ and then Expand then
 399          return Directory_Operations.Expand_Path
 400            (Value (1 .. Integer (Size_Value - 1)), Directory_Operations.DOS);
 401       else
 402          return Value (1 .. Integer (Size_Value - 1));
 403       end if;
 404    end Query_Value;
 405
 406    ---------------
 407    -- Set_Value --
 408    ---------------
 409
 410    procedure Set_Value
 411      (From_Key : HKEY;
 412       Sub_Key  : String;
 413       Value    : String)
 414    is
 415       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 416       C_Value   : constant String := Value & ASCII.Nul;
 417
 418       Result : LONG;
 419
 420    begin
 421       Result := RegSetValueEx
 422         (From_Key,
 423          C_Sub_Key (C_Sub_Key'First)'Address,
 424          0,
 425          REG_SZ,
 426          C_Value (C_Value'First)'Address,
 427          C_Value'Length);
 428
 429       Check_Result (Result, "Set_Value " & Sub_Key & " key");
 430    end Set_Value;
 431
 432    ---------------
 433    -- To_C_Mode --
 434    ---------------
 435
 436    function To_C_Mode (Mode : Key_Mode) return REGSAM is
 437       use type REGSAM;
 438
 439       KEY_READ  : constant :=  16#20019#;
 440       KEY_WRITE : constant :=  16#20006#;
 441
 442    begin
 443       case Mode is
 444          when Read_Only =>
 445             return KEY_READ;
 446
 447          when Read_Write =>
 448             return KEY_READ + KEY_WRITE;
 449       end case;
 450    end To_C_Mode;
 451
 452 end GNAT.Registry;