1/*  Part of SWI-Prolog
2
3    Author:        Jan Wielemaker
4    E-mail:        J.Wielemaker@vu.nl
5    WWW:           http://www.swi-prolog.org
6    Copyright (c)  2011-2020, University of Amsterdam
7                              CWI, Amsterdam
8    All rights reserved.
9
10    Redistribution and use in source and binary forms, with or without
11    modification, are permitted provided that the following conditions
12    are met:
13
14    1. Redistributions of source code must retain the above copyright
15       notice, this list of conditions and the following disclaimer.
16
17    2. Redistributions in binary form must reproduce the above copyright
18       notice, this list of conditions and the following disclaimer in
19       the documentation and/or other materials provided with the
20       distribution.
21
22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33    POSSIBILITY OF SUCH DAMAGE.
34*/
35
36/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
37This module requires plregtry.ddl, for  which   the  sources  are in the
38dlldemo directory.
39- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
40
41:- module(win_registry,
42          [ registry_get_key/2,         % +Path, -Value
43            registry_get_key/3,         % +Path, +Name, -Value
44            registry_set_key/2,         % +Path, +Value
45            registry_set_key/3,         % +Path, +Name, +Value
46            registry_delete_key/1,      % +Path
47            registry_lookup_key/3,      % +Path, +Access, -Key
48            win_flush_filetypes/0,      % Flush changes filetypes to shell
49
50            shell_register_file_type/4, % +Ext, +Type, +Name, +Open
51            shell_register_file_type/5, % +Ext, +Type, +Name, +Open, +Icon
52            shell_register_dde/6,       % +Type, +Action,
53                                        % +Service, Topic, +DDECommand
54                                        % +IfNotRunning
55            shell_register_prolog/1     % +Extension
56          ]).
57:- autoload(library(lists),[member/2]).
58
59:- use_foreign_library(foreign(plregtry)).      % load plregtry.ddl
60
61                 /*******************************
62                 *       REGISTER PROLOG        *
63                 *******************************/
64
65shell_register_prolog(Ext) :-
66    current_prolog_flag(executable, Me),
67    atomic_list_concat(['"', Me, '" "%1"'], OpenCommand),
68    atom_concat(Me, ',0', Icon),
69    shell_register_file_type(Ext, 'prolog.type', 'Prolog Source',
70                             OpenCommand, Icon),
71    shell_register_dde('prolog.type', consult,
72                       prolog, control, 'consult(''%1'')', Me),
73    shell_register_dde('prolog.type', edit,
74                       prolog, control, 'edit(''%1'')', Me),
75    win_flush_filetypes.
76
77
78                 /*******************************
79                 *     WINDOWS SHELL STUFF      *
80                 *******************************/
81
82%!  shell_register_file_type(+Ext, +Type, +Name, +Open) is det.
83%!  shell_register_file_type(+Ext, +Type, +Name, +Open, +Icon) is det.
84%
85%   Register an extension to a type.  The open command for the type
86%   is defined and files with this extension will be given Name as
87%   their description in the explorer.  For example:
88%
89%   ==
90%   ?- shell_register_file_type(pl, 'prolog.type', 'Prolog Source',
91%                               '"c:\\pl\\bin\\plwin.exe" "%1"').
92%   ==
93%
94%   The icon command is of the form File.exe,N or File.ico,0
95
96shell_register_file_type(Ext, Type, Name, Open) :-
97    ensure_dot(Ext, DExt),
98    registry_set_key(classes_root/DExt, Type),
99    registry_set_key(classes_root/Type, Name),
100    registry_set_key(classes_root/Type/shell/open/command, Open),
101    win_flush_filetypes.
102shell_register_file_type(Ext, Type, Name, Open, Icon) :-
103    shell_register_file_type(Ext, Type, Name, Open),
104    registry_set_key(classes_root/Type/'DefaultIcon', Icon),
105    win_flush_filetypes.
106
107ensure_dot(Ext, Ext) :-
108    atom_concat('.', _, Ext),
109    !.
110ensure_dot(Ext, DExt) :-
111    atom_concat('.', Ext, DExt).
112
113%!  shell_register_dde(+Type, +Action, +Service,
114%!                     +Topic, +DDECommand, +IfNotRunning) is det.
115%
116%   Register a DDE command for the type.  The example below will
117%   send DDE_EXECUTE command `consult('<File>') to the service
118%   prolog, given the topic control.
119%
120%   ==
121%   shell_register_dde('prolog.type', consult,
122%                      prolog, control, 'consult(''%1'')',
123%                      'c:\\pl\\bin\\plwin.exe -g "edit(''%1'')"').
124%   ==
125
126shell_register_dde(Type, Action, Service, Topic, DDECommand, IfNotRunning) :-
127    registry_make_key(classes_root/Type/shell/Action/ddeexec,
128                      all_access, EKey),
129    registry_set_key(classes_root/Type/shell/Action/command, IfNotRunning),
130    reg_set_value(EKey, '', DDECommand),
131    registry_set_key(EKey/'Application', Service),
132    registry_set_key(EKey/ifexec, ''),
133    registry_set_key(EKey/topic, Topic),
134    reg_close_key(EKey).
135
136                 /*******************************
137                 *        REGISTRY STUFF        *
138                 *******************************/
139
140/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
141In the commands below, Path refers to   the path-name of the registry. A
142path is a '/' separated description, where   the / should be interpreted
143as a Prolog operator. For example, classes_root/'prolog.type'/shell. The
144components should be atoms.
145- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
146
147%!  registry_set_key(+Path, +Value) is det.
148%!  registry_set_key(+Path, +Name, +Value) is det.
149%
150%   Associate a (string) value with the key described by Path.  If
151%   part of the path does not exist, the required keys will be created.
152
153registry_set_key(Path, Value) :-
154    registry_set_key(Path, '', Value).
155registry_set_key(Path, Name, Value) :-
156    registry_make_key(Path, write, Key, Close),
157    reg_set_value(Key, Name, Value),
158    Close.
159
160%!  registry_get_key(+Path, -Value) is semidet.
161%!  registry_get_key(+Path, +Name, -Value) is semidet.
162%
163%   Get the value associated with the given key.  If the key does not
164%   exists, the predicate fails silently.
165
166registry_get_key(Path, Value) :-
167    registry_get_key(Path, '', Value).
168registry_get_key(Path, Name, Value) :-
169    registry_lookup_key(Path, read, Key, Close),
170    (   reg_value(Key, Name, RawVal)
171    ->  Close,
172        Value = RawVal
173    ;   Close,
174        fail
175    ).
176
177%!  registry_delete_key(+Path)
178%
179%   Delete the gven key and all its subkeys and values.  Note that
180%   the root-keys cannot be deleted.
181
182registry_delete_key(Parent/Node) :-
183    !,
184    registry_lookup_key(Parent, all_access, PKey),
185    (   reg_open_key(PKey, Node, all_access, Key)
186    ->  delete_subkeys(Key),
187        reg_close_key(Key),
188        reg_delete_key(PKey, Node)
189    ),
190    reg_close_key(PKey).
191
192delete_subkeys(Parent) :-
193    reg_subkeys(Parent, Subs),
194    forall(member(Sub, Subs),
195           delete_subkey(Parent, Sub)).
196
197delete_subkey(Parent, Sub) :-
198    reg_open_key(Parent, Sub, all_access, Key),
199    delete_subkeys(Key),
200    reg_close_key(Key),
201    reg_delete_key(Parent, Sub).
202
203%!  registry_make_key(+Path, +Access, -Key)
204%
205%   Open the given key and create required keys if the path does not
206%   exist.
207
208registry_make_key(Path, Access, Key) :-
209    registry_make_key(Path, Access, Key, _).
210
211registry_make_key(A/B, Access, Key, Close) :-
212    !,
213    registry_make_key(A, Access, Parent, CloseParent),
214    (   reg_open_key(Parent, B, Access, RawKey)
215    ->  true
216    ;   reg_create_key(Parent, B, '', [], Access, RawKey)
217    ),
218    CloseParent,
219    Close = reg_close_key(RawKey),
220    Key = RawKey.
221registry_make_key(Key, _, Key, true).
222
223%!  registry_lookup_key(+Path, +Access, -Key)
224%
225%   Open the given key, fail silently if the key doesn't
226%   exist.
227
228registry_lookup_key(Path, Access, Key) :-
229    registry_lookup_key(Path, Access, Key, _).
230
231registry_lookup_key(A/B, Access, Key, Close) :-
232    !,
233    registry_lookup_key(A, Access, Parent, CloseParent),
234    reg_open_key(Parent, B, Access, RawKey),
235    CloseParent,
236    Close = reg_close_key(RawKey),
237    Key = RawKey.
238registry_lookup_key(Key, _, Key, true).
239
240