1/* Part of XPCE --- The SWI-Prolog GUI toolkit 2 3 Author: Jan Wielemaker and Anjo Anjewierden 4 E-mail: J.Wielemaker@vu.nl 5 WWW: http://www.swi-prolog.org/packages/xpce/ 6 Copyright (c) 1997-2018, University of Amsterdam 7 VU University 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:- module(pce_config, 37 [ register_config/1, % +PredicateName 38 register_config_type/2, % +Type, +Attributes 39 % fetch/set 40 get_config/2, % +Key, -Value 41 set_config/2, % +Key, +Value 42 add_config/2, % +Key, +Value 43 del_config/2, % +Key, +Value 44 % edit/save/load 45 edit_config/1, % +Graphical 46 save_config/1, % +File 47 load_config/1, % +File 48 ensure_loaded_config/1, % +File 49 % Type conversion 50 config_term_to_object/2, % ?Term, ?Object 51 config_term_to_object/3, % +Type, ?Term, ?Object 52 % +Editor interface 53 config_attributes/2, % ?Key, -Attributes 54 current_config_type/3 % +Type, -DefModule, -Attributes 55 ]). 56 57:- meta_predicate 58 register_config(2), 59 register_config_type(:, +), 60 current_config_type(:, -, -), 61 get_config_type(:, -), 62 get_config_term(:, -, -), 63 get_config(:, -), 64 set_config(:, +), 65 add_config(:, +), 66 del_config(:, +), 67 save_config(:), 68 load_config(:), 69 ensure_loaded_config(:), 70 edit_config(:), 71 config_attributes(:, -). 72 73:- use_module(library(pce)). 74:- use_module(library(broadcast)). 75:- require([ is_absolute_file_name/1 76 , is_list/1 77 , chain_list/2 78 , file_directory_name/2 79 , forall/2 80 , list_to_set/2 81 , member/2 82 , memberchk/2 83 , absolute_file_name/3 84 , call/3 85 , delete/3 86 , maplist/3 87 , strip_module/3 88 ]). 89 90:- pce_autoload(pce_config_editor, library(pce_configeditor)). 91 92:- multifile user:file_search_path/2. 93:- dynamic user:file_search_path/2. 94 95user:file_search_path(config, Dir) :- 96 get(@pce, application_data, AppDir), 97 get(AppDir, path, Dir). 98 99config_version(1). % version of the config package 100 101/** <module> XPCE congifuration database 102 103This module deals with saving and loading application settings such as 104preferences and the layout of windows. 105 106@see library(settings) provides the Prolog equivalent 107*/ 108 109:- dynamic 110 config_type/3, % Type, Module, Attributes 111 config_db/2, % DB, Predicate 112 config_store/4. % DB, Path, Value, Type 113 114 115 /******************************* 116 * REGISTER * 117 *******************************/ 118 119%! register_config(:Pred) is det. 120% 121% Register Pred to provide metadata about the configuration 122% handled in the calling module. Pred is called as call(Pred, 123% Path, Attributes). 124 125register_config(Spec) :- 126 strip_module(Spec, Module, Pred), 127 ( config_db(Module, Pred) 128 -> true 129 ; asserta(config_db(Module, Pred)) 130 ). 131 132 133 /******************************* 134 * QUERY * 135 *******************************/ 136 137get_config_type(Key, Type) :- 138 strip_module(Key, DB, Path), 139 config_db(DB, Pred), 140 call(DB:Pred, Path, Attributes), 141 memberchk(type(Type), Attributes). 142 143%! get_config(:Key, -Value) is det. 144% 145% Get configuration for Key as Value. 146 147get_config(Key, Value) :- 148 strip_module(Key, DB, Path), 149 config_store(DB, Path, Value0, Type), 150 !, 151 config_term_to_object(Type, Value0, Value). 152get_config(Key, Value) :- 153 config_attribute(Key, default(Default)), 154 !, 155 ( config_attribute(Key, type(Type)) 156 -> strip_module(Key, DB, Path), 157 asserta(config_store(DB, Path, Default, Type)), 158 config_term_to_object(Type, Default, Value) 159 ; Value = Default 160 ). 161 162 163get_config_term(Key, Term, Type) :- 164 strip_module(Key, DB, Path), 165 config_store(DB, Path, Term, Type). 166 167 168 /******************************* 169 * MODIFY * 170 *******************************/ 171 172%! set_config(:Key, +Value) is det. 173% 174% Set the configuration parameter Key to Value. If the value is 175% modified, a broadcast message set_config(Key, Value) is issued. 176 177set_config(Key, Value) :- 178 get_config(Key, Current), 179 Value == Current, 180 !. 181set_config(Key, Value) :- 182 strip_module(Key, DB, Path), 183 set_config_(DB, Path, Value), 184 set_modified(DB), 185 broadcast(set_config(Key, Value)). 186 187set_config_(DB, Path, Value) :- % local version 188 ( retract(config_store(DB, Path, _, Type)) 189 -> true 190 ; get_config_type(DB:Path, Type) 191 ), 192 config_term_to_object(Type, TermValue, Value), 193 asserta(config_store(DB, Path, TermValue, Type)). 194 195set_config_term(DB, Path, Term, Type) :- % loaded keys 196 retractall(config_store(DB, Path, _, _)), 197 asserta(config_store(DB, Path, Term, Type)), 198 config_term_to_object(Type, Term, Value), % should we broadcast? 199 broadcast(set_config(DB:Path, Value)). 200 201set_config_(DB, Path, Value, Type) :- % local version 202 retractall(config_store(DB, Path, _, _)), 203 asserta(config_store(DB, Path, Value, Type)). 204 205add_config(Key, Value) :- 206 strip_module(Key, DB, Path), 207 ( retract(config_store(DB, Path, Set0, Type)), 208 is_list(Set0) 209 -> ( delete(Set0, Value, Set1) 210 -> Set = [Value|Set1] 211 ; Set = [Value|Set0] 212 ) 213 ; retractall(config_store(DB, Path, _, _)), % make sure 214 get_config_type(Key, Type), 215 Set = [Value] 216 ), 217 asserta(config_store(DB, Path, Set, Type)), 218 set_modified(DB). 219 220del_config(Key, Value) :- 221 strip_module(Key, DB, Path), 222 config_store(DB, Path, Set0, Type), 223 delete(Set0, Value, Set), 224 retract(config_store(DB, Path, Set0, Type)), 225 !, 226 asserta(config_store(DB, Path, Set, Type)), 227 set_modified(DB). 228 229set_modified(DB) :- 230 config_store(DB, '$modified', true, _), 231 !. 232set_modified(DB) :- 233 asserta(config_store(DB, '$modified', true, bool)). 234 235clear_modified(DB) :- 236 retractall(config_store(DB, '$modified', _, _)). 237 238 239 /******************************* 240 * META * 241 *******************************/ 242 243%! config_attributes(+Key, -Attributes) 244% 245% Fetch the (meta) attributes of the given config key. The special 246% path `config' returns information on the config database itself. 247% The path of the key may be partly instantiated. 248 249config_attributes(Key, Attributes) :- 250 strip_module(Key, DB, Path), 251 config_db(DB, Pred), 252 call(DB:Pred, Path, Attributes). 253 254config_attribute(Key, Attribute) :- 255 var(Attribute), 256 !, 257 config_attributes(Key, Attributes), 258 member(Attribute, Attributes). 259config_attribute(Key, Attribute) :- 260 config_attributes(Key, Attributes), 261 memberchk(Attribute, Attributes), 262 !. 263 264current_config_path(Key) :- 265 strip_module(Key, DB, Path), 266 findall(P, config_path(DB, P), Ps0), 267 list_to_set(Ps0, Ps), 268 member(Path, Ps). 269 270config_path(DB, Path) :- 271 config_db(DB, Pred), 272 call(DB:Pred, Path, Attributes), 273 memberchk(type(_), Attributes). 274 275 276 277 278 /******************************* 279 * SAVE * 280 *******************************/ 281 282save_file(Key, File) :- 283 is_absolute_file_name(Key), 284 !, 285 File = Key. 286save_file(Key, File) :- 287 absolute_file_name(config(Key), File, 288 [ access(write), 289 extensions([cnf]), 290 file_errors(fail) 291 ]), 292 !. 293save_file(Key, File) :- 294 absolute_file_name(config(Key), File, 295 [ extensions([cnf]) 296 ]), 297 !, 298 file_directory_name(File, Dir), 299 ( send(directory(Dir), exists) 300 -> send(@pce, report, error, 'Cannot write config directory %s', Dir), 301 fail 302 ; send(directory(Dir), make) 303 ). 304 305 306save_config(Spec) :- 307 strip_module(Spec, M, Key), 308 ( var(Key) 309 -> get_config(M:config/file, Key) 310 ; true 311 ), 312 save_file(Key, File), 313 save_config(File, M). 314 315save_config(File, M) :- 316 catch(do_save_config(File, M), E, 317 print_message(warning, E)). 318 319do_save_config(File, M) :- 320 setup_call_cleanup( 321 open(File, write, Fd, [encoding(utf8)]), 322 ( save_config_header(Fd, M), 323 save_config_body(Fd, M) 324 ), 325 close(Fd)). 326 327save_config_header(Fd, M) :- 328 get(@pce?date, value, Date), 329 get(@pce, user, User), 330 config_version(Version), 331 format(Fd, '/* XPCE configuration file for "~w"~n', [M]), 332 format(Fd, ' Saved ~w by ~w~n', [Date, User]), 333 format(Fd, '*/~n~n', []), 334 format(Fd, 'configversion(~q).~n', [Version]), 335 format(Fd, '[~q].~n~n', [M]), 336 format(Fd, '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%~n', []), 337 format(Fd, '% Option lines starting with a `%'' indicate %~n',[]), 338 format(Fd, '% the value is equal to the application default. %~n', []), 339 format(Fd, '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%~n', []). 340 341save_config_body(Fd, M) :- 342 forall(current_config_path(M:Path), 343 save_config_key(Fd, M:Path)). 344 345save_config_key(Fd, Key) :- 346 config_attribute(Key, comment(Comment)), 347 nl(Fd), 348 ( is_list(Comment) 349 -> format_comment(Comment, Fd) 350 ; format_comment([Comment], Fd) 351 ), 352 fail. 353save_config_key(Fd, Key) :- 354 strip_module(Key, _, Path), 355 Options = [quoted(true), module(pce)], 356 ( get_config_term(Key, Value, _Type), 357 ( ( config_attribute(Key, default(Value0)) 358 -> Value == Value0 359 ) 360 -> format(Fd, '%~q = ~t~32|~W.~n', [Path, Value, Options]) 361 ; format(Fd, '~q = ~t~32|~W.~n', [Path, Value, Options]) 362 ), 363 fail 364 ; true 365 ). 366 367format_comment([], _). 368format_comment([H|T], Fd) :- 369 format(Fd, '/* ~w */~n', [H]), 370 format_comment(T, Fd). 371 372save_modified_configs :- 373 config_db(DB, _Pred), 374 get_config(DB:'$modified', true), 375 clear_modified(DB), 376 get_config(DB:config/file, Key), 377 send(@pce, report, status, 'Saving config database %s', Key), 378 save_config(DB:_DefaultFile), 379 fail. 380save_modified_configs. 381 382:- initialization 383 send(@pce, exit_message, message(@prolog, save_modified_configs)). 384 385 386 /******************************* 387 * LOAD * 388 *******************************/ 389 390ensure_loaded_config(Spec) :- 391 strip_module(Spec, M, _Key), 392 config_store(M, _Path, _Value, _Type), 393 !. 394ensure_loaded_config(Spec) :- 395 load_config(Spec). 396 397load_file(Key, File) :- 398 is_absolute_file_name(Key), 399 !, 400 File = Key. 401load_file(Key, File) :- 402 absolute_file_name(config(Key), File, 403 [ access(read), 404 extensions([cnf]), 405 file_errors(fail) 406 ]). 407 408load_key(_DB, Key) :- 409 nonvar(Key), 410 !. 411load_key(DB, Key) :- 412 get_config(DB:config/file, Key), 413 !. 414 415 416load_config(Spec) :- 417 strip_module(Spec, M, Key), 418 catch(pce_config:load_config(M, Key), E, 419 print_message(warning, E)). 420 421load_config(M, Key) :- 422 load_key(M, Key), 423 load_file(Key, File), 424 !, 425 setup_call_cleanup( 426 ( '$push_input_context'(pce_config), 427 open(File, read, Fd, [encoding(utf8)]) 428 ), 429 read_config_file(Fd, _SaveVersion, _SaveModule, Bindings), 430 ( close(Fd), 431 '$pop_input_context' 432 )), 433 load_config_keys(M, Bindings), 434 set_config_(M, config/file, File, file), 435 clear_modified(M). 436load_config(M, Key) :- % no config file, use defaults 437 load_key(M, Key), 438 set_config_(M, config/file, Key, file), 439 clear_modified(M). % or not, so we save first time? 440 441 442read_config_file(Fd, SaveVersion, SaveModule, Bindings) :- 443 read(Fd, configversion(SaveVersion)), 444 read(Fd, [SaveModule]), 445 read_term(Fd, Term, [module(pce)]), 446 read_config_file(Term, Fd, Bindings). 447 448read_config_file(end_of_file, _, []) :- !. 449read_config_file(Binding, Fd, [Binding|T]) :- 450 read_term(Fd, Term, [module(pce)]), 451 read_config_file(Term, Fd, T). 452 453load_config_keys(DB, Bindings) :- 454 forall(current_config_path(DB:Path), 455 load_config_key(DB:Path, Bindings)). 456 457load_config_key(Key, Bindings) :- 458 strip_module(Key, DB, Path), 459 config_attribute(Key, type(Type)), 460 ( member(Path=Value, Bindings) 461 *-> set_config_term(DB, Path, Value, Type), 462 fail 463 ; config_attribute(Key, default(Value)) 464 -> set_config_term(DB, Path, Value, Type) 465 ), 466 !. 467load_config_key(_, _). 468 469 470 /******************************* 471 * EDIT * 472 *******************************/ 473 474edit_config(Spec) :- 475 strip_module(Spec, M, Graphical), 476 make_config_editor(M, Editor), 477 ( object(Graphical), 478 send(Graphical, instance_of, visual), 479 get(Graphical, frame, Frame) 480 -> send(Editor, transient_for, Frame), 481 send(Editor, modal, transient), 482 send(Editor, open_centered, Frame?area?center) 483 ; send(Editor, open_centered) 484 ). 485 486make_config_editor(M, Editor) :- 487 new(Editor, pce_config_editor(M)). 488 489 490 /******************************* 491 * TYPES * 492 *******************************/ 493 494resource(font, image, image('16x16/font.xpm')). 495resource(cpalette2, image, image('16x16/cpalette2.xpm')). 496 497builtin_config_type(bool, [ editor(config_bool_item), 498 term(map([@off=false, @on=true])) 499 ]). 500builtin_config_type(font, [ editor(font_item), 501 term([family, style, points]), 502 icon(font) 503 ]). 504builtin_config_type(colour, [ editor(colour_item), 505 term(if(@arg1?kind == named, name)), 506 term([@default, red, green, blue]) 507 ]). 508builtin_config_type(setof(colour), [ editor(colour_palette_item), 509 icon(cpalette2) 510 ]). 511builtin_config_type(image, [ editor(image_item), 512 term(if(@arg1?name \== @nil, name)), 513 term(@arg1?file?absolute_path) 514 ]). 515builtin_config_type(file, [ editor(file_item) 516 ]). 517builtin_config_type(directory, [ editor(directory_item) 518 ]). 519builtin_config_type({}(_), [ editor(config_one_of_item) 520 ]). 521builtin_config_type(_, [ editor(config_generic_item) 522 ]). 523 524register_config_type(TypeSpec, Attributes) :- 525 strip_module(TypeSpec, Module, Type), 526 ( config_type(Type, Module, Attributes) 527 -> true 528 ; asserta(config_type(Type, Module, Attributes)) 529 ). 530 531current_config_type(TypeSpec, DefModule, Attributes) :- 532 strip_module(TypeSpec, Module, Type), 533 ( config_type(Type, Module, Attributes) 534 -> DefModule = Module 535 ; config_type(Type, DefModule, Attributes) 536 ). 537current_config_type(TypeSpec, pce_config, Attributes) :- 538 strip_module(TypeSpec, _Module, Type), 539 builtin_config_type(Type, Attributes). 540 541%! pce_object_type(+Type) 542% 543% Succeed if Type denotes an XPCE type 544 545pce_object_type(Var) :- 546 var(Var), 547 !, 548 fail. 549pce_object_type(setof(Type)) :- 550 !, 551 pce_object_type(Type). 552pce_object_type(Type) :- 553 current_config_type(Type, _, Attributes), 554 memberchk(term(_), Attributes). 555 556 557 /******************************* 558 * TERM <-> OBJECT * 559 *******************************/ 560 561config_term_to_object(Type, Term, Object) :- 562 pce_object_type(Type), 563 !, 564 config_term_to_object(Term, Object). 565config_term_to_object(_, Value, Value). 566 567 568config_term_to_object(Term, Object) :- 569 nonvar(Object), 570 !, 571 config_object_to_term(Object, Term). 572config_term_to_object(Term, _Object) :- 573 var(Term), 574 fail. % raise error! 575config_term_to_object(List, Chain) :- 576 is_list(List), 577 !, 578 maplist(config_term_to_object, List, Objects), 579 chain_list(Chain, Objects). 580config_term_to_object(Atomic, Atomic) :- 581 atomic(Atomic), 582 !. 583config_term_to_object(Term+Attribute, Object) :- 584 !, 585 Attribute =.. [AttName, AttTerm], 586 config_term_to_object(AttTerm, AttObject), 587 config_term_to_object(Term, Object), 588 send(Object, AttName, AttObject). 589config_term_to_object(Term, Object) :- 590 new(Object, Term). 591 592% Object --> Term 593 594config_object_to_term(@off, false) :- !. 595config_object_to_term(@on, true) :- !. 596config_object_to_term(@Ref, @Ref) :- 597 atom(Ref), 598 !. % global objects! 599config_object_to_term(Chain, List) :- 600 send(Chain, instance_of, chain), 601 !, 602 chain_list(Chain, List0), 603 maplist(config_object_to_term, List0, List). 604config_object_to_term(Obj, Term) :- 605 object(Obj), 606 get(Obj, class_name, ClassName), 607 term_description(ClassName, Attributes, Condition), 608 send(Condition, forward, Obj), 609 config_attributes_to_term(Attributes, Obj, Term). 610config_object_to_term(Obj, Term) :- 611 object(Obj), 612 get(Obj, class_name, ClassName), 613 term_description(ClassName, Attributes), 614 config_attributes_to_term(Attributes, Obj, Term). 615config_object_to_term(V, V). 616 617config_attributes_to_term(map(Mapping), Obj, Term) :- 618 !, 619 memberchk(Obj=Term, Mapping). 620config_attributes_to_term(NewAtts+Att, Obj, Term+AttTerm) :- 621 !, 622 config_attributes_to_term(NewAtts, Obj, Term), 623 prolog_value_argument(Obj, Att, AttTermVal), 624 AttTerm =.. [Att, AttTermVal]. 625config_attributes_to_term(Attributes, Obj, Term) :- 626 is_list(Attributes), 627 !, 628 get(Obj, class_name, ClassName), 629 maplist(prolog_value_argument(Obj), Attributes, InitArgs), 630 Term =.. [ClassName|InitArgs]. 631config_attributes_to_term(Attribute, Obj, Term) :- 632 prolog_value_argument(Obj, Attribute, Term). 633 634 % unconditional term descriptions 635term_description(Type, TermDescription) :- 636 current_config_type(Type, _, Attributes), 637 member(term(TermDescription), Attributes), 638 \+ TermDescription = if(_,_). 639term_description(Type, TermDescription, Condition) :- 640 current_config_type(Type, _, Attributes), 641 member(term(if(Condition, TermDescription)), Attributes). 642 643prolog_value_argument(Obj, Arg, ArgTerm) :- 644 atom(Arg), 645 !, 646 get(Obj, Arg, V0), 647 config_object_to_term(V0, ArgTerm). 648prolog_value_argument(Obj, Arg, Value) :- 649 functor(Arg, ?, _), 650 get(Arg, '_forward', Obj, Value). 651prolog_value_argument(_, Arg, Arg). 652 653 654 /******************************* 655 * XREF SUPPORT * 656 *******************************/ 657 658:- multifile 659 prolog:called_by/2. 660 661prolog:called_by(register_config(G), [G+2]). 662