1------------------------------------------------------------------------------
2--                                                                          --
3--                            Matreshka Project                             --
4--                                                                          --
5--         Localization, Internationalization, Globalization for Ada        --
6--                                                                          --
7--                        Runtime Library Component                         --
8--                                                                          --
9------------------------------------------------------------------------------
10--                                                                          --
11-- Copyright © 2011, Vadim Godunko <vgodunko@gmail.com>                     --
12-- All rights reserved.                                                     --
13--                                                                          --
14-- Redistribution and use in source and binary forms, with or without       --
15-- modification, are permitted provided that the following conditions       --
16-- are met:                                                                 --
17--                                                                          --
18--  * Redistributions of source code must retain the above copyright        --
19--    notice, this list of conditions and the following disclaimer.         --
20--                                                                          --
21--  * Redistributions in binary form must reproduce the above copyright     --
22--    notice, this list of conditions and the following disclaimer in the   --
23--    documentation and/or other materials provided with the distribution.  --
24--                                                                          --
25--  * Neither the name of the Vadim Godunko, IE nor the names of its        --
26--    contributors may be used to endorse or promote products derived from  --
27--    this software without specific prior written permission.              --
28--                                                                          --
29-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS      --
30-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT        --
31-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR    --
32-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT     --
33-- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,   --
34-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED --
35-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR   --
36-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF   --
37-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING     --
38-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS       --
39-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.             --
40--                                                                          --
41------------------------------------------------------------------------------
42--  $Revision: 2043 $ $Date: 2011-07-27 20:39:43 +0400 (Wed, 27 Jul 2011) $
43------------------------------------------------------------------------------
44with Ada.Unchecked_Conversion;
45with Interfaces.C;
46
47with League.Characters;
48with League.Strings.Internals;
49with Matreshka.Internals.Strings.C;
50with Matreshka.Internals.Utf16;
51with Matreshka.Internals.Windows;
52
53package body Matreshka.Internals.Settings.Registry is
54
55   use Matreshka.Internals.Windows;
56   use type League.Characters.Universal_Character;
57
58   -----------------
59   -- Windows API --
60   -----------------
61
62   type ACCESS_MASK is new Interfaces.C.unsigned_long;
63
64   type REGSAM is new ACCESS_MASK;
65
66   type PHKEY is access all HKEY;
67
68   type SECURITY_ATTRIBUTES is null record;
69   type LPSECURITY_ATTRIBUTES is access all SECURITY_ATTRIBUTES;
70   pragma Convention (C, LPSECURITY_ATTRIBUTES);
71
72   KEY_WRITE : constant REGSAM := 16#20006#;
73   KEY_READ  : constant REGSAM := 16#20019#;
74
75   use type LONG;
76
77   type LPDWORD is access all DWORD;
78
79   REG_OPTION_NON_VOLATILE : constant DWORD := 0;
80
81   REG_SZ : constant DWORD := 1;
82
83   function To_HKEY is
84     new Ada.Unchecked_Conversion (Interfaces.C.unsigned, HKEY);
85
86   No_HKEY : constant HKEY := HKEY (System.Null_Address);
87
88   HKEY_CLASSES_ROOT  : constant HKEY := To_HKEY (16#8000_0000#);
89   HKEY_CURRENT_USER  : constant HKEY := To_HKEY (16#8000_0001#);
90   HKEY_LOCAL_MACHINE : constant HKEY := To_HKEY (16#8000_0002#);
91   HKEY_USERS         : constant HKEY := To_HKEY (16#8000_0003#);
92
93   function RegOpenKeyEx
94    (hKey       : Registry.HKEY;
95     lpSubKey   : Windows.LPCWSTR;
96     ulOptions  : Interfaces.C.unsigned_long;
97     samDesired : REGSAM;
98     phkResult  : PHKEY) return LONG;
99   pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExW");
100
101   function RegCreateKeyEx
102    (hKey                 : Registry.HKEY;
103     lpSubKey             : Windows.LPCWSTR;
104     Reserved             : Interfaces.C.unsigned_long;
105     lpClass              : Windows.LPWSTR;
106     dwOptions            : DWORD;
107     samDesired           : REGSAM;
108     lpSecurityAttributes : LPSECURITY_ATTRIBUTES;
109     phkResult            : PHKEY;
110     lpdwDisposition      : LPDWORD) return LONG;
111   pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExW");
112
113   --  function RegCloseKey (hKey : Registry.HKEY) return LONG;
114   procedure RegCloseKey (hKey : Registry.HKEY);
115   pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
116
117   --  function RegFlushKey (hKey : Registry.HKEY) return LONG;
118   procedure RegFlushKey (hKey : Registry.HKEY);
119   pragma Import (Stdcall, RegFlushKey, "RegFlushKey");
120
121   function RegSetValueEx
122    (hKey     : Registry.HKEY;
123     lpSubKey : Windows.LPCWSTR;
124     Reserved : DWORD;
125     dwType   : DWORD;
126     lpData   : System.Address;
127     cbData   : DWORD) return LONG;
128   pragma Import (Stdcall, RegSetValueEx, "RegSetValueExW");
129
130   function RegQueryValueEx
131    (hKey     : Registry.HKEY;
132     lpSubKey : Windows.LPCWSTR;
133     Reserved : LPDWORD;
134     lpType   : LPDWORD;
135     lpData   : System.Address;
136     lpcbData : LPDWORD) return LONG;
137   pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExW");
138
139   function Create
140    (Manager   : not null access Abstract_Manager'Class;
141     Name      : League.Strings.Universal_String;
142     Root      : HKEY;
143     Key       : League.Strings.Universal_String;
144     Read_Only : Boolean) return not null Settings_Access;
145   --  Creates storage pointing to specified root and key. Read_Only means
146   --  that subtree is opened for reading only.
147
148   procedure Split_Path_Name
149    (Key  : League.Strings.Universal_String;
150     Path : out League.Strings.Universal_String;
151     Name : out League.Strings.Universal_String);
152   --  Split key into path and name parts.
153
154   function Open_Or_Create
155    (Parent : HKEY;
156     Path   : League.Strings.Universal_String) return HKEY;
157   --  Opens existing path or create new path and returns its handler.
158
159   function Open
160    (Parent : HKEY;
161     Path   : League.Strings.Universal_String) return HKEY;
162   --  Opens existing path in read-only mode and returns its handler.
163
164   HKEY_CURRENT_USER_Name  : constant League.Strings.Universal_String
165     := League.Strings.To_Universal_String ("HKEY_CURRENT_USER");
166   HKEY_LOCAL_MACHINE_Name : constant League.Strings.Universal_String
167     := League.Strings.To_Universal_String ("HKEY_LOCAL_MACHINE");
168   HKEY_CLASSES_ROOT_Name  : constant League.Strings.Universal_String
169     := League.Strings.To_Universal_String ("HKEY_CLASSES_ROOT");
170   HKEY_USERS_Name         : constant League.Strings.Universal_String
171     := League.Strings.To_Universal_String ("HKEY_USERS");
172
173   --------------
174   -- Contains --
175   --------------
176
177   overriding function Contains
178    (Self : Registry_Settings;
179     Key  : League.Strings.Universal_String) return Boolean
180   is
181      Handler : HKEY;
182      Path    : League.Strings.Universal_String;
183      Name    : League.Strings.Universal_String;
184      Found   : Boolean := True;
185
186   begin
187      --  Compute path to open
188
189      Split_Path_Name (Key, Path, Name);
190
191      --  Try to open path
192
193      Handler := Open (Self.Handler, Path);
194
195      if Handler /= No_HKEY then
196         --  Try to retrieve value
197
198         if RegQueryValueEx
199             (Handler,
200              League.Strings.Internals.Internal (Name).Value (0)'Access,
201              null,
202              null,
203              System.Null_Address,
204              null) /= 0
205         then
206            Found := False;
207         end if;
208
209         RegCloseKey (Handler);
210
211      else
212         Found := False;
213      end if;
214
215      return Found;
216   end Contains;
217
218   ------------
219   -- Create --
220   ------------
221
222   function Create
223    (Manager   : not null access Abstract_Manager'Class;
224     Key       : League.Strings.Universal_String;
225     Read_Only : Boolean) return not null Settings_Access
226   is
227      use type League.Strings.Universal_String;
228
229      Path      : League.Strings.Universal_String := Key;
230      Separator : Natural;
231
232   begin
233      --  Remove leading backslash if any.
234
235      if Path.Element (1) = '\' then
236         Path := Path.Slice (2, Path.Length);
237      end if;
238
239      Separator := Path.Index ('\');
240
241      if Separator = 0 then
242         Separator := Path.Length + 1;
243      end if;
244
245      if Path.Slice (1, Separator - 1) = HKEY_CURRENT_USER_Name then
246         return
247           Create
248            (Manager,
249             '\' & Path,
250             HKEY_CURRENT_USER,
251             Path.Slice (Separator + 1, Path.Length),
252             Read_Only);
253
254      elsif Path.Slice (1, Separator - 1) = HKEY_LOCAL_MACHINE_Name then
255         return
256           Create
257            (Manager,
258             '\' & Path,
259             HKEY_LOCAL_MACHINE,
260             Path.Slice (Separator + 1, Path.Length),
261             Read_Only);
262
263      elsif Path.Slice (1, Separator - 1) = HKEY_CLASSES_ROOT_Name then
264         return
265           Create
266            (Manager,
267             '\' & Path,
268             HKEY_CLASSES_ROOT,
269             Path.Slice (Separator + 1, Path.Length),
270             Read_Only);
271
272      elsif Path.Slice (1, Separator - 1) = HKEY_USERS_Name then
273         return
274           Create
275            (Manager,
276             '\' & Path,
277             HKEY_USERS,
278             Path.Slice (Separator + 1, Path.Length),
279             Read_Only);
280
281      else
282         return
283           Create
284            (Manager,
285             '\' & HKEY_LOCAL_MACHINE_Name & '\' & Path,
286             HKEY_LOCAL_MACHINE,
287             Path,
288             Read_Only);
289      end if;
290   end Create;
291
292   ------------
293   -- Create --
294   ------------
295
296   function Create
297    (Manager   : not null access Abstract_Manager'Class;
298     Name      : League.Strings.Universal_String;
299     Root      : HKEY;
300     Key       : League.Strings.Universal_String;
301     Read_Only : Boolean) return not null Settings_Access is
302   begin
303      return Aux : constant not null Settings_Access
304        := new Registry_Settings'
305                (Counter   => <>,
306                 Manager   => Manager,
307                 Name      => Name,
308                 Handler   => <>,
309                 Read_Only => Read_Only)
310      do
311         declare
312            Self : Registry_Settings'Class
313              renames Registry_Settings'Class (Aux.all);
314
315         begin
316            if Self.Read_Only then
317               --  Open registry to read when Read_Only mode is specified.
318
319               Self.Handler := Open (Root, Key);
320
321            else
322               --  In Read_Write mode, try to open first.
323
324               Self.Handler := Open_Or_Create (Root, Key);
325
326               if Self.Handler = No_HKEY then
327                  --  Fallback to read-only mode and try to open it to read.
328
329                  Self.Read_Only := True;
330                  Self.Handler := Open (Root, Key);
331               end if;
332            end if;
333         end;
334      end return;
335   end Create;
336
337   --------------
338   -- Finalize --
339   --------------
340
341   overriding procedure Finalize
342    (Self : not null access Registry_Settings) is
343   begin
344      if Self.Handler /= No_HKEY then
345         RegCloseKey (Self.Handler);
346         Self.Handler := No_HKEY;
347      end if;
348   end Finalize;
349
350   ----------
351   -- Name --
352   ----------
353
354   overriding function Name
355    (Self : not null access Registry_Settings)
356       return League.Strings.Universal_String is
357   begin
358      return Self.Name;
359   end Name;
360
361   ----------
362   -- Open --
363   ----------
364
365   function Open
366    (Parent : HKEY;
367     Path   : League.Strings.Universal_String) return HKEY
368   is
369      Handler : aliased HKEY;
370
371   begin
372      if RegOpenKeyEx
373          (Parent,
374           League.Strings.Internals.Internal (Path).Value (0)'Access,
375           0,
376           KEY_READ,
377           Handler'Unchecked_Access) /= 0
378      then
379         Handler := No_HKEY;
380      end if;
381
382      return Handler;
383   end Open;
384
385   --------------------
386   -- Open_Or_Create --
387   --------------------
388
389   function Open_Or_Create
390    (Parent : HKEY;
391     Path   : League.Strings.Universal_String) return HKEY
392   is
393      Handler : aliased HKEY;
394
395   begin
396      if RegOpenKeyEx
397          (Parent,
398           League.Strings.Internals.Internal (Path).Value (0)'Access,
399           0,
400           KEY_READ or KEY_WRITE,
401           Handler'Unchecked_Access) /= 0
402      then
403         --  Try to create path
404
405         if RegCreateKeyEx
406             (Parent,
407              League.Strings.Internals.Internal (Path).Value (0)'Access,
408              0,
409              null,
410              REG_OPTION_NON_VOLATILE,
411              KEY_READ or KEY_WRITE,
412              null,
413              Handler'Unchecked_Access,
414              null) /= 0
415         then
416            --  Operation failed.
417
418            Handler := No_HKEY;
419         end if;
420      end if;
421
422      return Handler;
423   end Open_Or_Create;
424
425   ------------
426   -- Remove --
427   ------------
428
429   overriding procedure Remove
430    (Self : in out Registry_Settings;
431     Key  : League.Strings.Universal_String) is
432   begin
433      null;
434   end Remove;
435
436   ---------------
437   -- Set_Value --
438   ---------------
439
440   overriding procedure Set_Value
441    (Self  : in out Registry_Settings;
442     Key   : League.Strings.Universal_String;
443     Value : League.Holders.Holder)
444   is
445      use type Matreshka.Internals.Utf16.Utf16_String_Index;
446
447      Handler : aliased HKEY;
448      Path    : League.Strings.Universal_String;
449      Name    : League.Strings.Universal_String;
450      V       : League.Strings.Universal_String;
451
452   begin
453      if Self.Handler = No_HKEY or Self.Read_Only then
454         --  Registry can't be modified in read-only mode.
455
456         return;
457      end if;
458
459      --  Compute path to open
460
461      Split_Path_Name (Key, Path, Name);
462
463      --  Try to open path
464
465      Handler := Open_Or_Create (Self.Handler, Path);
466
467      if Handler = No_HKEY then
468         --  Operation failed, return.
469
470         return;
471      end if;
472
473      --  Extract value.
474
475      V := League.Holders.Element (Value);
476
477      --  Store string.
478
479      if RegSetValueEx
480          (Handler,
481           League.Strings.Internals.Internal (Name).Value (0)'Access,
482           0,
483           REG_SZ,
484           League.Strings.Internals.Internal (V).Value (0)'Address,
485           DWORD ((League.Strings.Internals.Internal (V).Unused + 1) * 2)) /= 0
486      then
487         null;
488      end if;
489
490      RegCloseKey (Handler);
491   end Set_Value;
492
493   ---------------------
494   -- Split_Path_Name --
495   ---------------------
496
497   procedure Split_Path_Name
498    (Key  : League.Strings.Universal_String;
499     Path : out League.Strings.Universal_String;
500     Name : out League.Strings.Universal_String) is
501   begin
502      Path := League.Strings.Empty_Universal_String;
503      Name := Key;
504
505      for J in 1 .. Key.Length loop
506         if Key.Element (J) = '\' then
507            Path := Key.Slice (1, J - 1);
508            Name := Key.Slice (J + 1, Key.Length);
509
510            exit;
511         end if;
512      end loop;
513   end Split_Path_Name;
514
515   ----------
516   -- Sync --
517   ----------
518
519   overriding procedure Sync (Self : in out Registry_Settings) is
520   begin
521      if Self.Handler /= No_HKEY and not Self.Read_Only then
522         --  RegFlushKey requires KEY_QUERY_VALUE access right, this right is
523         --  part of KEY_READ.
524
525         RegFlushKey (Self.Handler);
526      end if;
527   end Sync;
528
529   -----------
530   -- Value --
531   -----------
532
533   overriding function Value
534    (Self : Registry_Settings;
535     Key  : League.Strings.Universal_String)
536       return League.Holders.Holder
537   is
538      use Matreshka.Internals.Utf16;
539      use type DWORD;
540
541      Handler : HKEY;
542      Path    : League.Strings.Universal_String;
543      Name    : League.Strings.Universal_String;
544      V_Type  : aliased DWORD;
545      V_Size  : aliased DWORD;
546      Value   : League.Holders.Holder;
547
548   begin
549      --  Compute path to open
550
551      Split_Path_Name (Key, Path, Name);
552
553      --  Try to open path
554
555      Handler := Open (Self.Handler, Path);
556
557      if Handler = No_HKEY then
558         return Value;
559      end if;
560
561      --  Try to retrieve value
562
563      if RegQueryValueEx
564          (Handler,
565           League.Strings.Internals.Internal (Name).Value (0)'Access,
566           null,
567           V_Type'Unchecked_Access,
568           System.Null_Address,
569           V_Size'Unchecked_Access) = 0
570      then
571         if V_Type = REG_SZ then
572            declare
573               V : Matreshka.Internals.Utf16.Utf16_String
574                    (0
575                       .. Matreshka.Internals.Utf16.Utf16_String_Index
576                           (V_Size / 2));
577
578            begin
579               if RegQueryValueEx
580                   (Handler,
581                    League.Strings.Internals.Internal (Name).Value (0)'Access,
582                    null,
583                    V_Type'Unchecked_Access,
584                    V'Address,
585                    V_Size'Unchecked_Access) = 0
586               then
587                  V (V'Last) := 0;
588                  League.Holders.Replace_Element
589                   (Value,
590                    Matreshka.Internals.Strings.C.To_Valid_Universal_String
591                     (V (0)'Unchecked_Access));
592               end if;
593            end;
594         end if;
595      end if;
596
597      RegCloseKey (Handler);
598
599      return Value;
600   end Value;
601
602end Matreshka.Internals.Settings.Registry;
603