Subversion Repositories openrisc

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                         G N A T . R E G I S T R Y                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--           Copyright (C) 2001-2009, Free Software Foundation, Inc.        --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Interfaces.C;
with System;
with GNAT.Directory_Operations;
 
package body GNAT.Registry is
 
   use System;
 
   ------------------------------
   -- Binding to the Win32 API --
   ------------------------------
 
   subtype LONG is Interfaces.C.long;
   subtype ULONG is Interfaces.C.unsigned_long;
   subtype DWORD is ULONG;
 
   type    PULONG is access all ULONG;
   subtype PDWORD is PULONG;
   subtype LPDWORD is PDWORD;
 
   subtype Error_Code is LONG;
 
   subtype REGSAM is LONG;
 
   type PHKEY is access all HKEY;
 
   ERROR_SUCCESS : constant Error_Code := 0;
 
   REG_SZ        : constant := 1;
   REG_EXPAND_SZ : constant := 2;
 
   function RegCloseKey (Key : HKEY) return LONG;
   pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
 
   function RegCreateKeyEx
     (Key                  : HKEY;
      lpSubKey             : Address;
      Reserved             : DWORD;
      lpClass              : Address;
      dwOptions            : DWORD;
      samDesired           : REGSAM;
      lpSecurityAttributes : Address;
      phkResult            : PHKEY;
      lpdwDisposition      : LPDWORD)
      return                 LONG;
   pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");
 
   function RegDeleteKey
     (Key      : HKEY;
      lpSubKey : Address) return LONG;
   pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");
 
   function RegDeleteValue
     (Key         : HKEY;
      lpValueName : Address) return LONG;
   pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");
 
   function RegEnumValue
     (Key           : HKEY;
      dwIndex       : DWORD;
      lpValueName   : Address;
      lpcbValueName : LPDWORD;
      lpReserved    : LPDWORD;
      lpType        : LPDWORD;
      lpData        : Address;
      lpcbData      : LPDWORD) return LONG;
   pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");
 
   function RegOpenKeyEx
     (Key        : HKEY;
      lpSubKey   : Address;
      ulOptions  : DWORD;
      samDesired : REGSAM;
      phkResult  : PHKEY) return LONG;
   pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");
 
   function RegQueryValueEx
     (Key         : HKEY;
      lpValueName : Address;
      lpReserved  : LPDWORD;
      lpType      : LPDWORD;
      lpData      : Address;
      lpcbData    : LPDWORD) return LONG;
   pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");
 
   function RegSetValueEx
     (Key         : HKEY;
      lpValueName : Address;
      Reserved    : DWORD;
      dwType      : DWORD;
      lpData      : Address;
      cbData      : DWORD) return LONG;
   pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
 
   function RegEnumKey
     (Key         : HKEY;
      dwIndex     : DWORD;
      lpName      : Address;
      cchName     : DWORD) return LONG;
   pragma Import (Stdcall, RegEnumKey, "RegEnumKeyA");
 
   ---------------------
   -- Local Constants --
   ---------------------
 
   Max_Key_Size : constant := 1_024;
   --  Maximum number of characters for a registry key
 
   Max_Value_Size : constant := 2_048;
   --  Maximum number of characters for a key's value
 
   -----------------------
   -- Local Subprograms --
   -----------------------
 
   function To_C_Mode (Mode : Key_Mode) return REGSAM;
   --  Returns the Win32 mode value for the Key_Mode value
 
   procedure Check_Result (Result : LONG; Message : String);
   --  Checks value Result and raise the exception Registry_Error if it is not
   --  equal to ERROR_SUCCESS. Message and the error value (Result) is added
   --  to the exception message.
 
   ------------------
   -- Check_Result --
   ------------------
 
   procedure Check_Result (Result : LONG; Message : String) is
      use type LONG;
   begin
      if Result /= ERROR_SUCCESS then
         raise Registry_Error with
           Message & " (" & LONG'Image (Result) & ')';
      end if;
   end Check_Result;
 
   ---------------
   -- Close_Key --
   ---------------
 
   procedure Close_Key (Key : HKEY) is
      Result : LONG;
   begin
      Result := RegCloseKey (Key);
      Check_Result (Result, "Close_Key");
   end Close_Key;
 
   ----------------
   -- Create_Key --
   ----------------
 
   function Create_Key
     (From_Key : HKEY;
      Sub_Key  : String;
      Mode     : Key_Mode := Read_Write) return HKEY
   is
      use type REGSAM;
      use type DWORD;
 
      REG_OPTION_NON_VOLATILE : constant := 16#0#;
 
      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
      C_Class   : constant String := "" & ASCII.NUL;
      C_Mode    : constant REGSAM := To_C_Mode (Mode);
 
      New_Key : aliased HKEY;
      Result  : LONG;
      Dispos  : aliased DWORD;
 
   begin
      Result :=
        RegCreateKeyEx
          (From_Key,
           C_Sub_Key (C_Sub_Key'First)'Address,
           0,
           C_Class (C_Class'First)'Address,
           REG_OPTION_NON_VOLATILE,
           C_Mode,
           Null_Address,
           New_Key'Unchecked_Access,
           Dispos'Unchecked_Access);
 
      Check_Result (Result, "Create_Key " & Sub_Key);
      return New_Key;
   end Create_Key;
 
   ----------------
   -- Delete_Key --
   ----------------
 
   procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is
      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
      Result    : LONG;
   begin
      Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
      Check_Result (Result, "Delete_Key " & Sub_Key);
   end Delete_Key;
 
   ------------------
   -- Delete_Value --
   ------------------
 
   procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is
      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
      Result    : LONG;
   begin
      Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);
      Check_Result (Result, "Delete_Value " & Sub_Key);
   end Delete_Value;
 
   -------------------
   -- For_Every_Key --
   -------------------
 
   procedure For_Every_Key
     (From_Key  : HKEY;
      Recursive : Boolean := False)
   is
      procedure Recursive_For_Every_Key
        (From_Key  : HKEY;
         Recursive : Boolean := False;
         Quit      : in out Boolean);
 
      -----------------------------
      -- Recursive_For_Every_Key --
      -----------------------------
 
      procedure Recursive_For_Every_Key
        (From_Key : HKEY;
         Recursive : Boolean := False;
         Quit      : in out Boolean)
      is
         use type LONG;
         use type ULONG;
 
         Index  : ULONG := 0;
         Result : LONG;
 
         Sub_Key : Interfaces.C.char_array (1 .. Max_Key_Size);
         pragma Warnings (Off, Sub_Key);
 
         Size_Sub_Key : aliased ULONG;
         Sub_Hkey     : HKEY;
 
         function Current_Name return String;
 
         ------------------
         -- Current_Name --
         ------------------
 
         function Current_Name return String is
         begin
            return Interfaces.C.To_Ada (Sub_Key);
         end Current_Name;
 
      --  Start of processing for Recursive_For_Every_Key
 
      begin
         loop
            Size_Sub_Key := Sub_Key'Length;
 
            Result :=
              RegEnumKey
                (From_Key, Index, Sub_Key (1)'Address, Size_Sub_Key);
 
            exit when not (Result = ERROR_SUCCESS);
 
            Sub_Hkey := Open_Key (From_Key, Interfaces.C.To_Ada (Sub_Key));
 
            Action (Natural (Index) + 1, Sub_Hkey, Current_Name, Quit);
 
            if not Quit and then Recursive then
               Recursive_For_Every_Key (Sub_Hkey, True, Quit);
            end if;
 
            Close_Key (Sub_Hkey);
 
            exit when Quit;
 
            Index := Index + 1;
         end loop;
      end Recursive_For_Every_Key;
 
      --  Local Variables
 
      Quit : Boolean := False;
 
   --  Start of processing for For_Every_Key
 
   begin
      Recursive_For_Every_Key (From_Key, Recursive, Quit);
   end For_Every_Key;
 
   -------------------------
   -- For_Every_Key_Value --
   -------------------------
 
   procedure For_Every_Key_Value
     (From_Key : HKEY;
      Expand   : Boolean := False)
   is
      use GNAT.Directory_Operations;
      use type LONG;
      use type ULONG;
 
      Index  : ULONG := 0;
      Result : LONG;
 
      Sub_Key : String (1 .. Max_Key_Size);
      pragma Warnings (Off, Sub_Key);
 
      Value : String (1 .. Max_Value_Size);
      pragma Warnings (Off, Value);
 
      Size_Sub_Key : aliased ULONG;
      Size_Value   : aliased ULONG;
      Type_Sub_Key : aliased DWORD;
 
      Quit : Boolean;
 
   begin
      loop
         Size_Sub_Key := Sub_Key'Length;
         Size_Value   := Value'Length;
 
         Result :=
           RegEnumValue
             (From_Key, Index,
              Sub_Key (1)'Address,
              Size_Sub_Key'Unchecked_Access,
              null,
              Type_Sub_Key'Unchecked_Access,
              Value (1)'Address,
              Size_Value'Unchecked_Access);
 
         exit when not (Result = ERROR_SUCCESS);
 
         Quit := False;
 
         if Type_Sub_Key = REG_EXPAND_SZ and then Expand then
            Action
              (Natural (Index) + 1,
               Sub_Key (1 .. Integer (Size_Sub_Key)),
               Directory_Operations.Expand_Path
                 (Value (1 .. Integer (Size_Value) - 1),
                  Directory_Operations.DOS),
               Quit);
 
         elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then
            Action
              (Natural (Index) + 1,
               Sub_Key (1 .. Integer (Size_Sub_Key)),
               Value (1 .. Integer (Size_Value) - 1),
               Quit);
         end if;
 
         exit when Quit;
 
         Index := Index + 1;
      end loop;
   end For_Every_Key_Value;
 
   ----------------
   -- Key_Exists --
   ----------------
 
   function Key_Exists
     (From_Key : HKEY;
      Sub_Key  : String) return Boolean
   is
      New_Key : HKEY;
 
   begin
      New_Key := Open_Key (From_Key, Sub_Key);
      Close_Key (New_Key);
 
      --  We have been able to open the key so it exists
 
      return True;
 
   exception
      when Registry_Error =>
 
         --  An error occurred, the key was not found
 
         return False;
   end Key_Exists;
 
   --------------
   -- Open_Key --
   --------------
 
   function Open_Key
     (From_Key : HKEY;
      Sub_Key  : String;
      Mode     : Key_Mode := Read_Only) return HKEY
   is
      use type REGSAM;
 
      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
      C_Mode    : constant REGSAM := To_C_Mode (Mode);
 
      New_Key : aliased HKEY;
      Result  : LONG;
 
   begin
      Result :=
        RegOpenKeyEx
          (From_Key,
           C_Sub_Key (C_Sub_Key'First)'Address,
           0,
           C_Mode,
           New_Key'Unchecked_Access);
 
      Check_Result (Result, "Open_Key " & Sub_Key);
      return New_Key;
   end Open_Key;
 
   -----------------
   -- Query_Value --
   -----------------
 
   function Query_Value
     (From_Key : HKEY;
      Sub_Key  : String;
      Expand   : Boolean := False) return String
   is
      use GNAT.Directory_Operations;
      use type LONG;
      use type ULONG;
 
      Value : String (1 .. Max_Value_Size);
      pragma Warnings (Off, Value);
 
      Size_Value : aliased ULONG;
      Type_Value : aliased DWORD;
 
      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
      Result    : LONG;
 
   begin
      Size_Value := Value'Length;
 
      Result :=
        RegQueryValueEx
          (From_Key,
           C_Sub_Key (C_Sub_Key'First)'Address,
           null,
           Type_Value'Unchecked_Access,
           Value (Value'First)'Address,
           Size_Value'Unchecked_Access);
 
      Check_Result (Result, "Query_Value " & Sub_Key & " key");
 
      if Type_Value = REG_EXPAND_SZ and then Expand then
         return Directory_Operations.Expand_Path
           (Value (1 .. Integer (Size_Value - 1)),
            Directory_Operations.DOS);
      else
         return Value (1 .. Integer (Size_Value - 1));
      end if;
   end Query_Value;
 
   ---------------
   -- Set_Value --
   ---------------
 
   procedure Set_Value
      (From_Key : HKEY;
       Sub_Key  : String;
       Value    : String;
       Expand   : Boolean := False)
   is
      C_Sub_Key : constant String := Sub_Key & ASCII.NUL;
      C_Value   : constant String := Value & ASCII.NUL;
 
      Value_Type : DWORD;
      Result     : LONG;
 
   begin
      Value_Type := (if Expand then REG_EXPAND_SZ else REG_SZ);
 
      Result :=
        RegSetValueEx
          (From_Key,
           C_Sub_Key (C_Sub_Key'First)'Address,
           0,
           Value_Type,
           C_Value (C_Value'First)'Address,
           C_Value'Length);
 
      Check_Result (Result, "Set_Value " & Sub_Key & " key");
   end Set_Value;
 
   ---------------
   -- To_C_Mode --
   ---------------
 
   function To_C_Mode (Mode : Key_Mode) return REGSAM is
      use type REGSAM;
 
      KEY_READ  : constant :=  16#20019#;
      KEY_WRITE : constant :=  16#20006#;
 
   begin
      case Mode is
         when Read_Only =>
            return KEY_READ;
 
         when Read_Write =>
            return KEY_READ + KEY_WRITE;
      end case;
   end To_C_Mode;
 
end GNAT.Registry;