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 --                                                                          --
  10 --              Copyright (C) 2001 Free Software Foundation, Inc.           --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Exceptions;
  35 with Interfaces.C;
  36 with System;
  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
  65    function RegCloseKey (Key : HKEY) return LONG;
  66    pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
  67
  68    function RegCreateKeyEx
  69      (Key                  : HKEY;
  70       lpSubKey             : Address;
  71       Reserved             : DWORD;
  72       lpClass              : Address;
  73       dwOptions            : DWORD;
  74       samDesired           : REGSAM;
  75       lpSecurityAttributes : Address;
  76       phkResult            : PHKEY;
  77       lpdwDisposition      : LPDWORD)
  78       return                 LONG;
  79    pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
  80
  81    function RegDeleteKey
  82      (Key      : HKEY;
  83       lpSubKey : Address)
  84       return     LONG;
  85    pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
  86
  87    function RegDeleteValue
  88      (Key         : HKEY;
  89       lpValueName : Address)
  90       return        LONG;
  91    pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
  92
  93    function RegEnumValue
  94      (Key           : HKEY;
  95       dwIndex       : DWORD;
  96       lpValueName   : Address;
  97       lpcbValueName : LPDWORD;
  98       lpReserved    : LPDWORD;
  99       lpType        : LPDWORD;
 100       lpData        : Address;
 101       lpcbData      : LPDWORD)
 102       return          LONG;
 103    pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
 104
 105    function RegOpenKeyEx
 106      (Key        : HKEY;
 107       lpSubKey   : Address;
 108       ulOptions  : DWORD;
 109       samDesired : REGSAM;
 110       phkResult  : PHKEY)
 111       return       LONG;
 112    pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
 113
 114    function RegQueryValueEx
 115      (Key         : HKEY;
 116       lpValueName : Address;
 117       lpReserved  : LPDWORD;
 118       lpType      : LPDWORD;
 119       lpData      : Address;
 120       lpcbData    : LPDWORD)
 121       return        LONG;
 122    pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
 123
 124    function RegSetValueEx
 125      (Key         : HKEY;
 126       lpValueName : Address;
 127       Reserved    : DWORD;
 128       dwType      : DWORD;
 129       lpData      : Address;
 130       cbData      : DWORD)
 131       return        LONG;
 132    pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
 133
 134    -----------------------
 135    -- Local Subprograms --
 136    -----------------------
 137
 138    function To_C_Mode (Mode : Key_Mode) return REGSAM;
 139    --  Returns the Win32 mode value for the Key_Mode value.
 140
 141    procedure Check_Result (Result : LONG; Message : String);
 142    --  Checks value Result and raise the exception Registry_Error if it is not
 143    --  equal to ERROR_SUCCESS. Message and the error value (Result) is added
 144    --  to the exception message.
 145
 146    ------------------
 147    -- Check_Result --
 148    ------------------
 149
 150    procedure Check_Result (Result : LONG; Message : String) is
 151       use type LONG;
 152
 153    begin
 154       if Result /= ERROR_SUCCESS then
 155          Exceptions.Raise_Exception
 156            (Registry_Error'Identity,
 157             Message & " (" & LONG'Image (Result) & ')');
 158       end if;
 159    end Check_Result;
 160
 161    ---------------
 162    -- Close_Key --
 163    ---------------
 164
 165    procedure Close_Key (Key : HKEY) is
 166       Result : LONG;
 167
 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)
 181       return     HKEY
 182    is
 183       use type REGSAM;
 184       use type DWORD;
 185
 186       REG_OPTION_NON_VOLATILE : constant := 16#0#;
 187
 188       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 189       C_Class   : constant String := "" & ASCII.Nul;
 190       C_Mode    : constant REGSAM := To_C_Mode (Mode);
 191
 192       New_Key : aliased HKEY;
 193       Result  : LONG;
 194       Dispos  : aliased DWORD;
 195
 196    begin
 197       Result := 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
 220    begin
 221       Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
 222       Check_Result (Result, "Delete_Key " & Sub_Key);
 223    end Delete_Key;
 224
 225    ------------------
 226    -- Delete_Value --
 227    ------------------
 228
 229    procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
 230       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 231       Result    : LONG;
 232
 233    begin
 234       Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
 235       Check_Result (Result, "Delete_Value " & Sub_Key);
 236    end Delete_Value;
 237
 238    -------------------------
 239    -- For_Every_Key_Value --
 240    -------------------------
 241
 242    procedure For_Every_Key_Value (From_Key : HKEY) is
 243       use type LONG;
 244       use type ULONG;
 245
 246       Index  : ULONG := 0;
 247       Result : LONG;
 248
 249       Sub_Key : String (1 .. 100);
 250       pragma Warnings (Off, Sub_Key);
 251
 252       Value : String (1 .. 100);
 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 := RegEnumValue
 267            (From_Key, Index,
 268             Sub_Key (1)'Address,
 269             Size_Sub_Key'Unchecked_Access,
 270             null,
 271             Type_Sub_Key'Unchecked_Access,
 272             Value (1)'Address,
 273             Size_Value'Unchecked_Access);
 274
 275          exit when not (Result = ERROR_SUCCESS);
 276
 277          if Type_Sub_Key = REG_SZ then
 278             Quit := False;
 279
 280             Action (Natural (Index) + 1,
 281                     Sub_Key (1 .. Integer (Size_Sub_Key)),
 282                     Value (1 .. Integer (Size_Value) - 1),
 283                     Quit);
 284
 285             exit when Quit;
 286
 287             Index := Index + 1;
 288          end if;
 289
 290       end loop;
 291    end For_Every_Key_Value;
 292
 293    ----------------
 294    -- Key_Exists --
 295    ----------------
 296
 297    function Key_Exists
 298      (From_Key : HKEY;
 299       Sub_Key  : String)
 300       return     Boolean
 301    is
 302       New_Key : HKEY;
 303
 304    begin
 305       New_Key := Open_Key (From_Key, Sub_Key);
 306       Close_Key (New_Key);
 307
 308       --  We have been able to open the key so it exists
 309
 310       return True;
 311
 312    exception
 313       when Registry_Error =>
 314
 315          --  An error occurred, the key was not found
 316
 317          return False;
 318    end Key_Exists;
 319
 320    --------------
 321    -- Open_Key --
 322    --------------
 323
 324    function Open_Key
 325      (From_Key : HKEY;
 326       Sub_Key  : String;
 327       Mode     : Key_Mode := Read_Only)
 328       return     HKEY
 329    is
 330       use type REGSAM;
 331
 332       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 333       C_Mode    : constant REGSAM := To_C_Mode (Mode);
 334
 335       New_Key   : aliased HKEY;
 336       Result    : LONG;
 337
 338    begin
 339       Result := RegOpenKeyEx
 340         (From_Key,
 341          C_Sub_Key (C_Sub_Key'First)'Address,
 342          0,
 343          C_Mode,
 344          New_Key'Unchecked_Access);
 345
 346       Check_Result (Result, "Open_Key " & Sub_Key);
 347       return New_Key;
 348    end Open_Key;
 349
 350    -----------------
 351    -- Query_Value --
 352    -----------------
 353
 354    function Query_Value
 355      (From_Key : HKEY;
 356       Sub_Key  : String)
 357       return     String
 358    is
 359       use type LONG;
 360       use type ULONG;
 361
 362       Value : String (1 .. 100);
 363       pragma Warnings (Off, Value);
 364
 365       Size_Value : aliased ULONG;
 366       Type_Value : aliased DWORD;
 367
 368       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 369       Result    : LONG;
 370
 371    begin
 372       Size_Value := Value'Length;
 373
 374       Result := RegQueryValueEx
 375         (From_Key,
 376          C_Sub_Key (C_Sub_Key'First)'Address,
 377          null,
 378          Type_Value'Unchecked_Access,
 379          Value (Value'First)'Address,
 380          Size_Value'Unchecked_Access);
 381
 382       Check_Result (Result, "Query_Value " & Sub_Key & " key");
 383
 384       return Value (1 .. Integer (Size_Value - 1));
 385    end Query_Value;
 386
 387    ---------------
 388    -- Set_Value --
 389    ---------------
 390
 391    procedure Set_Value
 392      (From_Key : HKEY;
 393       Sub_Key  : String;
 394       Value    : String)
 395    is
 396       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 397       C_Value   : constant String := Value & ASCII.Nul;
 398
 399       Result : LONG;
 400
 401    begin
 402       Result := RegSetValueEx
 403         (From_Key,
 404          C_Sub_Key (C_Sub_Key'First)'Address,
 405          0,
 406          REG_SZ,
 407          C_Value (C_Value'First)'Address,
 408          C_Value'Length);
 409
 410       Check_Result (Result, "Set_Value " & Sub_Key & " key");
 411    end Set_Value;
 412
 413    ---------------
 414    -- To_C_Mode --
 415    ---------------
 416
 417    function To_C_Mode (Mode : Key_Mode) return REGSAM is
 418       use type REGSAM;
 419
 420       KEY_READ  : constant :=  16#20019#;
 421       KEY_WRITE : constant :=  16#20006#;
 422
 423    begin
 424       case Mode is
 425          when Read_Only =>
 426             return KEY_READ;
 427
 428          when Read_Write =>
 429             return KEY_READ + KEY_WRITE;
 430       end case;
 431    end To_C_Mode;
 432
 433 end GNAT.Registry;