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 --                            $Revision: 1.2 $
  10 --                                                                          --
  11 --              Copyright (C) 2001 Free Software Foundation, Inc.           --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.   --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with Ada.Exceptions;
  36 with Interfaces.C;
  37 with System;
  38
  39 package body GNAT.Registry is
  40
  41    use Ada;
  42    use System;
  43
  44    ------------------------------
  45    -- Binding to the Win32 API --
  46    ------------------------------
  47
  48    subtype LONG is Interfaces.C.long;
  49    subtype ULONG is Interfaces.C.unsigned_long;
  50    subtype DWORD is ULONG;
  51
  52    type    PULONG is access all ULONG;
  53    subtype PDWORD is PULONG;
  54    subtype LPDWORD is PDWORD;
  55
  56    subtype Error_Code is LONG;
  57
  58    subtype REGSAM is LONG;
  59
  60    type PHKEY is access all HKEY;
  61
  62    ERROR_SUCCESS : constant Error_Code := 0;
  63
  64    REG_SZ : constant := 1;
  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 Subprograms --
 137    -----------------------
 138
 139    function To_C_Mode (Mode : Key_Mode) return REGSAM;
 140    --  Returns the Win32 mode value for the Key_Mode value.
 141
 142    procedure Check_Result (Result : LONG; Message : String);
 143    --  Checks value Result and raise the exception Registry_Error if it is not
 144    --  equal to ERROR_SUCCESS. Message and the error value (Result) is added
 145    --  to the exception message.
 146
 147    ------------------
 148    -- Check_Result --
 149    ------------------
 150
 151    procedure Check_Result (Result : LONG; Message : String) is
 152       use type LONG;
 153
 154    begin
 155       if Result /= ERROR_SUCCESS then
 156          Exceptions.Raise_Exception
 157            (Registry_Error'Identity,
 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
 169    begin
 170       Result := RegCloseKey (Key);
 171       Check_Result (Result, "Close_Key");
 172    end Close_Key;
 173
 174    ----------------
 175    -- Create_Key --
 176    ----------------
 177
 178    function Create_Key
 179      (From_Key : HKEY;
 180       Sub_Key  : String;
 181       Mode     : Key_Mode := Read_Write)
 182       return     HKEY
 183    is
 184       use type REGSAM;
 185       use type DWORD;
 186
 187       REG_OPTION_NON_VOLATILE : constant := 16#0#;
 188
 189       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 190       C_Class   : constant String := "" & ASCII.Nul;
 191       C_Mode    : constant REGSAM := To_C_Mode (Mode);
 192
 193       New_Key : aliased HKEY;
 194       Result  : LONG;
 195       Dispos  : aliased DWORD;
 196
 197    begin
 198       Result := RegCreateKeyEx
 199         (From_Key,
 200          C_Sub_Key (C_Sub_Key'First)'Address,
 201          0,
 202          C_Class (C_Class'First)'Address,
 203          REG_OPTION_NON_VOLATILE,
 204          C_Mode,
 205          Null_Address,
 206          New_Key'Unchecked_Access,
 207          Dispos'Unchecked_Access);
 208
 209       Check_Result (Result, "Create_Key " & Sub_Key);
 210       return New_Key;
 211    end Create_Key;
 212
 213    ----------------
 214    -- Delete_Key --
 215    ----------------
 216
 217    procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
 218       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 219       Result    : LONG;
 220
 221    begin
 222       Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
 223       Check_Result (Result, "Delete_Key " & Sub_Key);
 224    end Delete_Key;
 225
 226    ------------------
 227    -- Delete_Value --
 228    ------------------
 229
 230    procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
 231       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 232       Result    : LONG;
 233
 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 (From_Key : HKEY) is
 244       use type LONG;
 245       use type ULONG;
 246
 247       Index  : ULONG := 0;
 248       Result : LONG;
 249
 250       Sub_Key : String (1 .. 100);
 251       pragma Warnings (Off, Sub_Key);
 252
 253       Value : String (1 .. 100);
 254       pragma Warnings (Off, Value);
 255
 256       Size_Sub_Key : aliased ULONG;
 257       Size_Value   : aliased ULONG;
 258       Type_Sub_Key : aliased DWORD;
 259
 260       Quit : Boolean;
 261
 262    begin
 263       loop
 264          Size_Sub_Key := Sub_Key'Length;
 265          Size_Value   := Value'Length;
 266
 267          Result := RegEnumValue
 268            (From_Key, Index,
 269             Sub_Key (1)'Address,
 270             Size_Sub_Key'Unchecked_Access,
 271             null,
 272             Type_Sub_Key'Unchecked_Access,
 273             Value (1)'Address,
 274             Size_Value'Unchecked_Access);
 275
 276          exit when not (Result = ERROR_SUCCESS);
 277
 278          if Type_Sub_Key = REG_SZ then
 279             Quit := False;
 280
 281             Action (Natural (Index) + 1,
 282                     Sub_Key (1 .. Integer (Size_Sub_Key)),
 283                     Value (1 .. Integer (Size_Value) - 1),
 284                     Quit);
 285
 286             exit when Quit;
 287
 288             Index := Index + 1;
 289          end if;
 290
 291       end loop;
 292    end For_Every_Key_Value;
 293
 294    ----------------
 295    -- Key_Exists --
 296    ----------------
 297
 298    function Key_Exists
 299      (From_Key : HKEY;
 300       Sub_Key  : String)
 301       return     Boolean
 302    is
 303       New_Key : HKEY;
 304
 305    begin
 306       New_Key := Open_Key (From_Key, Sub_Key);
 307       Close_Key (New_Key);
 308
 309       --  We have been able to open the key so it exists
 310
 311       return True;
 312
 313    exception
 314       when Registry_Error =>
 315
 316          --  An error occurred, the key was not found
 317
 318          return False;
 319    end Key_Exists;
 320
 321    --------------
 322    -- Open_Key --
 323    --------------
 324
 325    function Open_Key
 326      (From_Key : HKEY;
 327       Sub_Key  : String;
 328       Mode     : Key_Mode := Read_Only)
 329       return     HKEY
 330    is
 331       use type REGSAM;
 332
 333       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 334       C_Mode    : constant REGSAM := To_C_Mode (Mode);
 335
 336       New_Key   : aliased HKEY;
 337       Result    : LONG;
 338
 339    begin
 340       Result := RegOpenKeyEx
 341         (From_Key,
 342          C_Sub_Key (C_Sub_Key'First)'Address,
 343          0,
 344          C_Mode,
 345          New_Key'Unchecked_Access);
 346
 347       Check_Result (Result, "Open_Key " & Sub_Key);
 348       return New_Key;
 349    end Open_Key;
 350
 351    -----------------
 352    -- Query_Value --
 353    -----------------
 354
 355    function Query_Value
 356      (From_Key : HKEY;
 357       Sub_Key  : String)
 358       return     String
 359    is
 360       use type LONG;
 361       use type ULONG;
 362
 363       Value : String (1 .. 100);
 364       pragma Warnings (Off, Value);
 365
 366       Size_Value : aliased ULONG;
 367       Type_Value : aliased DWORD;
 368
 369       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 370       Result    : LONG;
 371
 372    begin
 373       Size_Value := Value'Length;
 374
 375       Result := RegQueryValueEx
 376         (From_Key,
 377          C_Sub_Key (C_Sub_Key'First)'Address,
 378          null,
 379          Type_Value'Unchecked_Access,
 380          Value (Value'First)'Address,
 381          Size_Value'Unchecked_Access);
 382
 383       Check_Result (Result, "Query_Value " & Sub_Key & " key");
 384
 385       return Value (1 .. Integer (Size_Value - 1));
 386    end Query_Value;
 387
 388    ---------------
 389    -- Set_Value --
 390    ---------------
 391
 392    procedure Set_Value
 393      (From_Key : HKEY;
 394       Sub_Key  : String;
 395       Value    : String)
 396    is
 397       C_Sub_Key : constant String := Sub_Key & ASCII.Nul;
 398       C_Value   : constant String := Value & ASCII.Nul;
 399
 400       Result : LONG;
 401
 402    begin
 403       Result := RegSetValueEx
 404         (From_Key,
 405          C_Sub_Key (C_Sub_Key'First)'Address,
 406          0,
 407          REG_SZ,
 408          C_Value (C_Value'First)'Address,
 409          C_Value'Length);
 410
 411       Check_Result (Result, "Set_Value " & Sub_Key & " key");
 412    end Set_Value;
 413
 414    ---------------
 415    -- To_C_Mode --
 416    ---------------
 417
 418    function To_C_Mode (Mode : Key_Mode) return REGSAM is
 419       use type REGSAM;
 420
 421       KEY_READ  : constant :=  16#20019#;
 422       KEY_WRITE : constant :=  16#20006#;
 423
 424    begin
 425       case Mode is
 426          when Read_Only =>
 427             return KEY_READ;
 428
 429          when Read_Write =>
 430             return KEY_READ + KEY_WRITE;
 431       end case;
 432    end To_C_Mode;
 433
 434 end GNAT.Registry;