URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [g-regist.adb] - Blame information for rev 308

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         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;

Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [g-regist.adb] - Blame information for rev 308

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
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-2009, 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 3, 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. --`
17			`-- --`
18			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
19			`-- additional permissions described in the GCC Runtime Library Exception, --`
20			`-- version 3.1, as published by the Free Software Foundation. --`
21			`-- --`
22			`-- You should have received a copy of the GNU General Public License and --`
23			`-- a copy of the GCC Runtime Library Exception along with this program; --`
24			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
25			`-- <http://www.gnu.org/licenses/>. --`
26			`-- --`
27			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
28			`-- --`
29			`------------------------------------------------------------------------------`
30
31			`with Interfaces.C;`
32			`with System;`
33			`with GNAT.Directory_Operations;`
34
35			`package body GNAT.Registry is`
36
37			`use System;`
38
39			`------------------------------`
40			`-- Binding to the Win32 API --`
41			`------------------------------`
42
43			`subtype LONG is Interfaces.C.long;`
44			`subtype ULONG is Interfaces.C.unsigned_long;`
45			`subtype DWORD is ULONG;`
46
47			`type PULONG is access all ULONG;`
48			`subtype PDWORD is PULONG;`
49			`subtype LPDWORD is PDWORD;`
50
51			`subtype Error_Code is LONG;`
52
53			`subtype REGSAM is LONG;`
54
55			`type PHKEY is access all HKEY;`
56
57			`ERROR_SUCCESS : constant Error_Code := 0;`
58
59			`REG_SZ : constant := 1;`
60			`REG_EXPAND_SZ : constant := 2;`
61
62			`function RegCloseKey (Key : HKEY) return LONG;`
63			`pragma Import (Stdcall, RegCloseKey, "RegCloseKey");`
64
65			`function RegCreateKeyEx`
66			`(Key : HKEY;`
67			`lpSubKey : Address;`
68			`Reserved : DWORD;`
69			`lpClass : Address;`
70			`dwOptions : DWORD;`
71			`samDesired : REGSAM;`
72			`lpSecurityAttributes : Address;`
73			`phkResult : PHKEY;`
74			`lpdwDisposition : LPDWORD)`
75			`return LONG;`
76			`pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA");`
77
78			`function RegDeleteKey`
79			`(Key : HKEY;`
80			`lpSubKey : Address) return LONG;`
81			`pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA");`
82
83			`function RegDeleteValue`
84			`(Key : HKEY;`
85			`lpValueName : Address) return LONG;`
86			`pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA");`
87
88			`function RegEnumValue`
89			`(Key : HKEY;`
90			`dwIndex : DWORD;`
91			`lpValueName : Address;`
92			`lpcbValueName : LPDWORD;`
93			`lpReserved : LPDWORD;`
94			`lpType : LPDWORD;`
95			`lpData : Address;`
96			`lpcbData : LPDWORD) return LONG;`
97			`pragma Import (Stdcall, RegEnumValue, "RegEnumValueA");`
98
99			`function RegOpenKeyEx`
100			`(Key : HKEY;`
101			`lpSubKey : Address;`
102			`ulOptions : DWORD;`
103			`samDesired : REGSAM;`
104			`phkResult : PHKEY) return LONG;`
105			`pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA");`
106
107			`function RegQueryValueEx`
108			`(Key : HKEY;`
109			`lpValueName : Address;`
110			`lpReserved : LPDWORD;`
111			`lpType : LPDWORD;`
112			`lpData : Address;`
113			`lpcbData : LPDWORD) return LONG;`
114			`pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA");`
115
116			`function RegSetValueEx`
117			`(Key : HKEY;`
118			`lpValueName : Address;`
119			`Reserved : DWORD;`
120			`dwType : DWORD;`
121			`lpData : Address;`
122			`cbData : DWORD) return LONG;`
123			`pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");`
124
125			`function RegEnumKey`
126			`(Key : HKEY;`
127			`dwIndex : DWORD;`
128			`lpName : Address;`
129			`cchName : DWORD) return LONG;`
130			`pragma Import (Stdcall, RegEnumKey, "RegEnumKeyA");`
131
132			`---------------------`
133			`-- Local Constants --`
134			`---------------------`
135
136			`Max_Key_Size : constant := 1_024;`
137			`-- Maximum number of characters for a registry key`
138
139			`Max_Value_Size : constant := 2_048;`
140			`-- Maximum number of characters for a key's value`
141
142			`-----------------------`
143			`-- Local Subprograms --`
144			`-----------------------`
145
146			`function To_C_Mode (Mode : Key_Mode) return REGSAM;`
147			`-- Returns the Win32 mode value for the Key_Mode value`
148
149			`procedure Check_Result (Result : LONG; Message : String);`
150			`-- Checks value Result and raise the exception Registry_Error if it is not`
151			`-- equal to ERROR_SUCCESS. Message and the error value (Result) is added`
152			`-- to the exception message.`
153
154			`------------------`
155			`-- Check_Result --`
156			`------------------`
157
158			`procedure Check_Result (Result : LONG; Message : String) is`
159			`use type LONG;`
160			`begin`
161			`if Result /= ERROR_SUCCESS then`
162			`raise Registry_Error with`
163			`Message & " (" & LONG'Image (Result) & ')';`
164			`end if;`
165			`end Check_Result;`
166
167			`---------------`
168			`-- Close_Key --`
169			`---------------`
170
171			`procedure Close_Key (Key : HKEY) is`
172			`Result : LONG;`
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 :=`
202			`RegCreateKeyEx`
203			`(From_Key,`
204			`C_Sub_Key (C_Sub_Key'First)'Address,`
205			`0,`
206			`C_Class (C_Class'First)'Address,`
207			`REG_OPTION_NON_VOLATILE,`
208			`C_Mode,`
209			`Null_Address,`
210			`New_Key'Unchecked_Access,`
211			`Dispos'Unchecked_Access);`
212
213			`Check_Result (Result, "Create_Key " & Sub_Key);`
214			`return New_Key;`
215			`end Create_Key;`
216
217			`----------------`
218			`-- Delete_Key --`
219			`----------------`
220
221			`procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is`
222			`C_Sub_Key : constant String := Sub_Key & ASCII.NUL;`
223			`Result : LONG;`
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			`begin`
237			`Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address);`
238			`Check_Result (Result, "Delete_Value " & Sub_Key);`
239			`end Delete_Value;`
240
241			`-------------------`
242			`-- For_Every_Key --`
243			`-------------------`
244
245			`procedure For_Every_Key`
246			`(From_Key : HKEY;`
247			`Recursive : Boolean := False)`
248			`is`
249			`procedure Recursive_For_Every_Key`
250			`(From_Key : HKEY;`
251			`Recursive : Boolean := False;`
252			`Quit : in out Boolean);`
253
254			`-----------------------------`
255			`-- Recursive_For_Every_Key --`
256			`-----------------------------`
257
258			`procedure Recursive_For_Every_Key`
259			`(From_Key : HKEY;`
260			`Recursive : Boolean := False;`
261			`Quit : in out Boolean)`
262			`is`
263			`use type LONG;`
264			`use type ULONG;`
265
266			`Index : ULONG := 0;`
267			`Result : LONG;`
268
269			`Sub_Key : Interfaces.C.char_array (1 .. Max_Key_Size);`
270			`pragma Warnings (Off, Sub_Key);`
271
272			`Size_Sub_Key : aliased ULONG;`
273			`Sub_Hkey : HKEY;`
274
275			`function Current_Name return String;`
276
277			`------------------`
278			`-- Current_Name --`
279			`------------------`
280
281			`function Current_Name return String is`
282			`begin`
283			`return Interfaces.C.To_Ada (Sub_Key);`
284			`end Current_Name;`
285
286			`-- Start of processing for Recursive_For_Every_Key`
287
288			`begin`
289			`loop`
290			`Size_Sub_Key := Sub_Key'Length;`
291
292			`Result :=`
293			`RegEnumKey`
294			`(From_Key, Index, Sub_Key (1)'Address, Size_Sub_Key);`
295
296			`exit when not (Result = ERROR_SUCCESS);`
297
298			`Sub_Hkey := Open_Key (From_Key, Interfaces.C.To_Ada (Sub_Key));`
299
300			`Action (Natural (Index) + 1, Sub_Hkey, Current_Name, Quit);`
301
302			`if not Quit and then Recursive then`
303			`Recursive_For_Every_Key (Sub_Hkey, True, Quit);`
304			`end if;`
305
306			`Close_Key (Sub_Hkey);`
307
308			`exit when Quit;`
309
310			`Index := Index + 1;`
311			`end loop;`
312			`end Recursive_For_Every_Key;`
313
314			`-- Local Variables`
315
316			`Quit : Boolean := False;`
317
318			`-- Start of processing for For_Every_Key`
319
320			`begin`
321			`Recursive_For_Every_Key (From_Key, Recursive, Quit);`
322			`end For_Every_Key;`
323
324			`-------------------------`
325			`-- For_Every_Key_Value --`
326			`-------------------------`
327
328			`procedure For_Every_Key_Value`
329			`(From_Key : HKEY;`
330			`Expand : Boolean := False)`
331			`is`
332			`use GNAT.Directory_Operations;`
333			`use type LONG;`
334			`use type ULONG;`
335
336			`Index : ULONG := 0;`
337			`Result : LONG;`
338
339			`Sub_Key : String (1 .. Max_Key_Size);`
340			`pragma Warnings (Off, Sub_Key);`
341
342			`Value : String (1 .. Max_Value_Size);`
343			`pragma Warnings (Off, Value);`
344
345			`Size_Sub_Key : aliased ULONG;`
346			`Size_Value : aliased ULONG;`
347			`Type_Sub_Key : aliased DWORD;`
348
349			`Quit : Boolean;`
350
351			`begin`
352			`loop`
353			`Size_Sub_Key := Sub_Key'Length;`
354			`Size_Value := Value'Length;`
355
356			`Result :=`
357			`RegEnumValue`
358			`(From_Key, Index,`
359			`Sub_Key (1)'Address,`
360			`Size_Sub_Key'Unchecked_Access,`
361			`null,`
362			`Type_Sub_Key'Unchecked_Access,`
363			`Value (1)'Address,`
364			`Size_Value'Unchecked_Access);`
365
366			`exit when not (Result = ERROR_SUCCESS);`
367
368			`Quit := False;`
369
370			`if Type_Sub_Key = REG_EXPAND_SZ and then Expand then`
371			`Action`
372			`(Natural (Index) + 1,`
373			`Sub_Key (1 .. Integer (Size_Sub_Key)),`
374			`Directory_Operations.Expand_Path`
375			`(Value (1 .. Integer (Size_Value) - 1),`
376			`Directory_Operations.DOS),`
377			`Quit);`
378
379			`elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then`
380			`Action`
381			`(Natural (Index) + 1,`
382			`Sub_Key (1 .. Integer (Size_Sub_Key)),`
383			`Value (1 .. Integer (Size_Value) - 1),`
384			`Quit);`
385			`end if;`
386
387			`exit when Quit;`
388
389			`Index := Index + 1;`
390			`end loop;`
391			`end For_Every_Key_Value;`
392
393			`----------------`
394			`-- Key_Exists --`
395			`----------------`
396
397			`function Key_Exists`
398			`(From_Key : HKEY;`
399			`Sub_Key : String) return Boolean`
400			`is`
401			`New_Key : HKEY;`
402
403			`begin`
404			`New_Key := Open_Key (From_Key, Sub_Key);`
405			`Close_Key (New_Key);`
406
407			`-- We have been able to open the key so it exists`
408
409			`return True;`
410
411			`exception`
412			`when Registry_Error =>`
413
414			`-- An error occurred, the key was not found`
415
416			`return False;`
417			`end Key_Exists;`
418
419			`--------------`
420			`-- Open_Key --`
421			`--------------`
422
423			`function Open_Key`
424			`(From_Key : HKEY;`
425			`Sub_Key : String;`
426			`Mode : Key_Mode := Read_Only) return HKEY`
427			`is`
428			`use type REGSAM;`
429
430			`C_Sub_Key : constant String := Sub_Key & ASCII.NUL;`
431			`C_Mode : constant REGSAM := To_C_Mode (Mode);`
432
433			`New_Key : aliased HKEY;`
434			`Result : LONG;`
435
436			`begin`
437			`Result :=`
438			`RegOpenKeyEx`
439			`(From_Key,`
440			`C_Sub_Key (C_Sub_Key'First)'Address,`
441			`0,`
442			`C_Mode,`
443			`New_Key'Unchecked_Access);`
444
445			`Check_Result (Result, "Open_Key " & Sub_Key);`
446			`return New_Key;`
447			`end Open_Key;`
448
449			`-----------------`
450			`-- Query_Value --`
451			`-----------------`
452
453			`function Query_Value`
454			`(From_Key : HKEY;`
455			`Sub_Key : String;`
456			`Expand : Boolean := False) return String`
457			`is`
458			`use GNAT.Directory_Operations;`
459			`use type LONG;`
460			`use type ULONG;`
461
462			`Value : String (1 .. Max_Value_Size);`
463			`pragma Warnings (Off, Value);`
464
465			`Size_Value : aliased ULONG;`
466			`Type_Value : aliased DWORD;`
467
468			`C_Sub_Key : constant String := Sub_Key & ASCII.NUL;`
469			`Result : LONG;`
470
471			`begin`
472			`Size_Value := Value'Length;`
473
474			`Result :=`
475			`RegQueryValueEx`
476			`(From_Key,`
477			`C_Sub_Key (C_Sub_Key'First)'Address,`
478			`null,`
479			`Type_Value'Unchecked_Access,`
480			`Value (Value'First)'Address,`
481			`Size_Value'Unchecked_Access);`
482
483			`Check_Result (Result, "Query_Value " & Sub_Key & " key");`
484
485			`if Type_Value = REG_EXPAND_SZ and then Expand then`
486			`return Directory_Operations.Expand_Path`
487			`(Value (1 .. Integer (Size_Value - 1)),`
488			`Directory_Operations.DOS);`
489			`else`
490			`return Value (1 .. Integer (Size_Value - 1));`
491			`end if;`
492			`end Query_Value;`
493
494			`---------------`
495			`-- Set_Value --`
496			`---------------`
497
498			`procedure Set_Value`
499			`(From_Key : HKEY;`
500			`Sub_Key : String;`
501			`Value : String;`
502			`Expand : Boolean := False)`
503			`is`
504			`C_Sub_Key : constant String := Sub_Key & ASCII.NUL;`
505			`C_Value : constant String := Value & ASCII.NUL;`
506
507			`Value_Type : DWORD;`
508			`Result : LONG;`
509
510			`begin`
511			`Value_Type := (if Expand then REG_EXPAND_SZ else REG_SZ);`
512
513			`Result :=`
514			`RegSetValueEx`
515			`(From_Key,`
516			`C_Sub_Key (C_Sub_Key'First)'Address,`
517			`0,`
518			`Value_Type,`
519			`C_Value (C_Value'First)'Address,`
520			`C_Value'Length);`
521
522			`Check_Result (Result, "Set_Value " & Sub_Key & " key");`
523			`end Set_Value;`
524
525			`---------------`
526			`-- To_C_Mode --`
527			`---------------`
528
529			`function To_C_Mode (Mode : Key_Mode) return REGSAM is`
530			`use type REGSAM;`
531
532			`KEY_READ : constant := 16#20019#;`
533			`KEY_WRITE : constant := 16#20006#;`
534
535			`begin`
536			`case Mode is`
537			`when Read_Only =>`
538			`return KEY_READ;`
539
540			`when Read_Write =>`
541			`return KEY_READ + KEY_WRITE;`
542			`end case;`
543			`end To_C_Mode;`
544
545			`end GNAT.Registry;`