OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-regist.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.