37
38:- module(qsave,
39 [ qsave_program/1, 40 qsave_program/2 41 ]). 42:- use_module(library(zip)). 43:- use_module(library(lists)). 44:- use_module(library(option)). 45:- use_module(library(error)). 46:- use_module(library(apply)). 47:- autoload(library(shlib), [current_foreign_library/2]). 48:- autoload(library(prolog_autoload), [autoload_all/1]). 49
59
60:- meta_predicate
61 qsave_program(+, :). 62
63:- multifile error:has_type/2. 64error:has_type(qsave_foreign_option, Term) :-
65 is_of_type(oneof([save, no_save, copy]), Term),
66 !.
67error:has_type(qsave_foreign_option, arch(Archs)) :-
68 is_of_type(list(atom), Archs),
69 !.
70
71save_option(stack_limit, integer,
72 "Stack limit (bytes)").
73save_option(goal, callable,
74 "Main initialization goal").
75save_option(toplevel, callable,
76 "Toplevel goal").
77save_option(init_file, atom,
78 "Application init file").
79save_option(pce, boolean,
80 "Do (not) include the xpce graphics subsystem").
81save_option(packs, boolean,
82 "Do (not) attach packs").
83save_option(class, oneof([runtime,development,prolog]),
84 "Development state").
85save_option(op, oneof([save,standard]),
86 "Save operators").
87save_option(autoload, boolean,
88 "Resolve autoloadable predicates").
89save_option(map, atom,
90 "File to report content of the state").
91save_option(stand_alone, boolean,
92 "Add emulator at start").
93save_option(traditional, boolean,
94 "Use traditional mode").
95save_option(emulator, ground,
96 "Emulator to use").
97save_option(foreign, qsave_foreign_option,
98 "Include foreign code in state").
99save_option(obfuscate, boolean,
100 "Obfuscate identifiers").
101save_option(verbose, boolean,
102 "Be more verbose about the state creation").
103save_option(undefined, oneof([ignore,error]),
104 "How to handle undefined predicates").
105save_option(on_error, oneof([print,halt,status]),
106 "How to handle errors").
107save_option(on_warning, oneof([print,halt,status]),
108 "How to handle warnings").
109
110term_expansion(save_pred_options,
111 (:- predicate_options(qsave_program/2, 2, Options))) :-
112 findall(O,
113 ( save_option(Name, Type, _),
114 O =.. [Name,Type]
115 ),
116 Options).
117
118save_pred_options.
119
120:- set_prolog_flag(generate_debug_info, false). 121
122:- dynamic
123 verbose/1,
124 saved_resource_file/1. 125:- volatile
126 verbose/1, 127 saved_resource_file/1. 128
133
134qsave_program(File) :-
135 qsave_program(File, []).
136
137qsave_program(FileBase, Options0) :-
138 meta_options(is_meta, Options0, Options1),
139 check_options(Options1),
140 exe_file(FileBase, File, Options1),
141 option(class(SaveClass), Options1, runtime),
142 qsave_init_file_option(SaveClass, Options1, Options),
143 prepare_entry_points(Options),
144 save_autoload(Options),
145 setup_call_cleanup(
146 open_map(Options),
147 ( prepare_state(Options),
148 create_prolog_flag(saved_program, true, []),
149 create_prolog_flag(saved_program_class, SaveClass, []),
150 delete_if_exists(File), 151 152 setup_call_catcher_cleanup(
153 open(File, write, StateOut, [type(binary)]),
154 write_state(StateOut, SaveClass, File, Options),
155 Reason,
156 finalize_state(Reason, StateOut, File))
157 ),
158 close_map),
159 cleanup,
160 !.
161
162write_state(StateOut, SaveClass, ExeFile, Options) :-
163 make_header(StateOut, SaveClass, Options),
164 setup_call_cleanup(
165 zip_open_stream(StateOut, RC, []),
166 write_zip_state(RC, SaveClass, ExeFile, Options),
167 zip_close(RC, [comment('SWI-Prolog saved state')])),
168 flush_output(StateOut).
169
170write_zip_state(RC, SaveClass, ExeFile, Options) :-
171 save_options(RC, SaveClass, Options),
172 save_resources(RC, SaveClass),
173 lock_files(SaveClass),
174 save_program(RC, SaveClass, Options),
175 save_foreign_libraries(RC, ExeFile, Options).
176
177finalize_state(exit, StateOut, File) :-
178 close(StateOut),
179 '$mark_executable'(File).
180finalize_state(!, StateOut, File) :-
181 print_message(warning, qsave(nondet)),
182 finalize_state(exit, StateOut, File).
183finalize_state(_, StateOut, File) :-
184 close(StateOut, [force(true)]),
185 catch(delete_file(File),
186 Error,
187 print_message(error, Error)).
188
189cleanup :-
190 retractall(saved_resource_file(_)).
191
192is_meta(goal).
193is_meta(toplevel).
194
195exe_file(Base, Exe, Options) :-
196 current_prolog_flag(windows, true),
197 option(stand_alone(true), Options, true),
198 file_name_extension(_, '', Base),
199 !,
200 file_name_extension(Base, exe, Exe).
201exe_file(Exe, Exe, _).
202
203delete_if_exists(File) :-
204 ( exists_file(File)
205 -> delete_file(File)
206 ; true
207 ).
208
209qsave_init_file_option(runtime, Options1, Options) :-
210 \+ option(init_file(_), Options1),
211 !,
212 Options = [init_file(none)|Options1].
213qsave_init_file_option(_, Options, Options).
214
215
216 219
221
(Out, _, Options) :-
223 stand_alone(Options),
224 !,
225 emulator(Emulator, Options),
226 setup_call_cleanup(
227 open(Emulator, read, In, [type(binary)]),
228 copy_stream_data(In, Out),
229 close(In)).
230make_header(Out, SaveClass, Options) :-
231 current_prolog_flag(unix, true),
232 !,
233 emulator(Emulator, Options),
234 current_prolog_flag(posix_shell, Shell),
235 format(Out, '#!~w~n', [Shell]),
236 format(Out, '# SWI-Prolog saved state~n', []),
237 ( SaveClass == runtime
238 -> ArgSep = ' -- '
239 ; ArgSep = ' '
240 ),
241 format(Out, 'exec ${SWIPL:-~w} -x "$0"~w"$@"~n~n', [Emulator, ArgSep]).
242make_header(_, _, _).
243
244stand_alone(Options) :-
245 ( current_prolog_flag(windows, true)
246 -> DefStandAlone = true
247 ; DefStandAlone = false
248 ),
249 option(stand_alone(true), Options, DefStandAlone).
250
251emulator(Emulator, Options) :-
252 ( option(emulator(OptVal), Options)
253 -> absolute_file_name(OptVal, [access(read)], Emulator)
254 ; current_prolog_flag(executable, Emulator)
255 ).
256
257
258
259 262
263min_stack(stack_limit, 100_000).
264
265convert_option(Stack, Val, NewVal, '~w') :- 266 min_stack(Stack, Min),
267 !,
268 ( Val == 0
269 -> NewVal = Val
270 ; NewVal is max(Min, Val)
271 ).
272convert_option(toplevel, Callable, Callable, '~q') :- !.
273convert_option(_, Value, Value, '~w').
274
275doption(Name) :- min_stack(Name, _).
276doption(init_file).
277doption(system_init_file).
278doption(class).
279doption(home).
280doption(nosignals).
281
290
291save_options(RC, SaveClass, Options) :-
292 zipper_open_new_file_in_zip(RC, '$prolog/options.txt', Fd, []),
293 ( doption(OptionName),
294 ( OptTerm =.. [OptionName,OptionVal2],
295 option(OptTerm, Options)
296 -> convert_option(OptionName, OptionVal2, OptionVal, FmtVal)
297 ; '$cmd_option_val'(OptionName, OptionVal0),
298 save_option_value(SaveClass, OptionName, OptionVal0, OptionVal1),
299 OptionVal = OptionVal1,
300 FmtVal = '~w'
301 ),
302 atomics_to_string(['~w=', FmtVal, '~n'], Fmt),
303 format(Fd, Fmt, [OptionName, OptionVal]),
304 fail
305 ; true
306 ),
307 save_init_goals(Fd, Options),
308 close(Fd).
309
311
312save_option_value(Class, class, _, Class) :- !.
313save_option_value(runtime, home, _, _) :- !, fail.
314save_option_value(_, _, Value, Value).
315
320
321save_init_goals(Out, Options) :-
322 option(goal(Goal), Options),
323 !,
324 format(Out, 'goal=~q~n', [Goal]),
325 save_toplevel_goal(Out, halt, Options).
326save_init_goals(Out, Options) :-
327 '$cmd_option_val'(goals, Goals),
328 forall(member(Goal, Goals),
329 format(Out, 'goal=~w~n', [Goal])),
330 ( Goals == []
331 -> DefToplevel = default
332 ; DefToplevel = halt
333 ),
334 save_toplevel_goal(Out, DefToplevel, Options).
335
336save_toplevel_goal(Out, _Default, Options) :-
337 option(toplevel(Goal), Options),
338 !,
339 unqualify_reserved_goal(Goal, Goal1),
340 format(Out, 'toplevel=~q~n', [Goal1]).
341save_toplevel_goal(Out, _Default, _Options) :-
342 '$cmd_option_val'(toplevel, Toplevel),
343 Toplevel \== default,
344 !,
345 format(Out, 'toplevel=~w~n', [Toplevel]).
346save_toplevel_goal(Out, Default, _Options) :-
347 format(Out, 'toplevel=~q~n', [Default]).
348
349unqualify_reserved_goal(_:prolog, prolog) :- !.
350unqualify_reserved_goal(_:default, default) :- !.
351unqualify_reserved_goal(Goal, Goal).
352
353
354 357
358save_resources(_RC, development) :- !.
359save_resources(RC, _SaveClass) :-
360 feedback('~nRESOURCES~n~n', []),
361 copy_resources(RC),
362 forall(declared_resource(Name, FileSpec, Options),
363 save_resource(RC, Name, FileSpec, Options)).
364
365declared_resource(RcName, FileSpec, []) :-
366 current_predicate(_, M:resource(_,_)),
367 M:resource(Name, FileSpec),
368 mkrcname(M, Name, RcName).
369declared_resource(RcName, FileSpec, Options) :-
370 current_predicate(_, M:resource(_,_,_)),
371 M:resource(Name, A2, A3),
372 ( is_list(A3)
373 -> FileSpec = A2,
374 Options = A3
375 ; FileSpec = A3
376 ),
377 mkrcname(M, Name, RcName).
378
382
383mkrcname(user, Name0, Name) :-
384 !,
385 path_segments_to_atom(Name0, Name).
386mkrcname(M, Name0, RcName) :-
387 path_segments_to_atom(Name0, Name),
388 atomic_list_concat([M, :, Name], RcName).
389
390path_segments_to_atom(Name0, Name) :-
391 phrase(segments_to_atom(Name0), Atoms),
392 atomic_list_concat(Atoms, /, Name).
393
394segments_to_atom(Var) -->
395 { var(Var), !,
396 instantiation_error(Var)
397 }.
398segments_to_atom(A/B) -->
399 !,
400 segments_to_atom(A),
401 segments_to_atom(B).
402segments_to_atom(A) -->
403 [A].
404
408
409save_resource(RC, Name, FileSpec, _Options) :-
410 absolute_file_name(FileSpec,
411 [ access(read),
412 file_errors(fail)
413 ], File),
414 !,
415 feedback('~t~8|~w~t~32|~w~n',
416 [Name, File]),
417 zipper_append_file(RC, Name, File, []).
418save_resource(RC, Name, FileSpec, Options) :-
419 findall(Dir,
420 absolute_file_name(FileSpec, Dir,
421 [ access(read),
422 file_type(directory),
423 file_errors(fail),
424 solutions(all)
425 ]),
426 Dirs),
427 Dirs \== [],
428 !,
429 forall(member(Dir, Dirs),
430 ( feedback('~t~8|~w~t~32|~w~n',
431 [Name, Dir]),
432 zipper_append_directory(RC, Name, Dir, Options))).
433save_resource(RC, Name, _, _Options) :-
434 '$rc_handle'(SystemRC),
435 copy_resource(SystemRC, RC, Name),
436 !.
437save_resource(_, Name, FileSpec, _Options) :-
438 print_message(warning,
439 error(existence_error(resource,
440 resource(Name, FileSpec)),
441 _)).
442
443copy_resources(ToRC) :-
444 '$rc_handle'(FromRC),
445 zipper_members(FromRC, List),
446 ( member(Name, List),
447 \+ declared_resource(Name, _, _),
448 \+ reserved_resource(Name),
449 copy_resource(FromRC, ToRC, Name),
450 fail
451 ; true
452 ).
453
454reserved_resource('$prolog/state.qlf').
455reserved_resource('$prolog/options.txt').
456
457copy_resource(FromRC, ToRC, Name) :-
458 ( zipper_goto(FromRC, file(Name))
459 -> true
460 ; existence_error(resource, Name)
461 ),
462 zipper_file_info(FromRC, _Name, Attrs),
463 get_dict(time, Attrs, Time),
464 setup_call_cleanup(
465 zipper_open_current(FromRC, FdIn,
466 [ type(binary),
467 time(Time)
468 ]),
469 setup_call_cleanup(
470 zipper_open_new_file_in_zip(ToRC, Name, FdOut, []),
471 ( feedback('~t~8|~w~t~24|~w~n',
472 [Name, '<Copied from running state>']),
473 copy_stream_data(FdIn, FdOut)
474 ),
475 close(FdOut)),
476 close(FdIn)).
477
478
479 482
486
487:- multifile prolog:obfuscate_identifiers/1. 488
489create_mapping(Options) :-
490 option(obfuscate(true), Options),
491 !,
492 ( predicate_property(prolog:obfuscate_identifiers(_), number_of_clauses(N)),
493 N > 0
494 -> true
495 ; use_module(library(obfuscate))
496 ),
497 ( catch(prolog:obfuscate_identifiers(Options), E,
498 print_message(error, E))
499 -> true
500 ; print_message(warning, failed(obfuscate_identifiers))
501 ).
502create_mapping(_).
503
511
512lock_files(runtime) :-
513 !,
514 '$set_source_files'(system). 515lock_files(_) :-
516 '$set_source_files'(from_state).
517
521
522save_program(RC, SaveClass, Options) :-
523 setup_call_cleanup(
524 ( zipper_open_new_file_in_zip(RC, '$prolog/state.qlf', StateFd,
525 [ zip64(true)
526 ]),
527 current_prolog_flag(access_level, OldLevel),
528 set_prolog_flag(access_level, system), 529 '$open_wic'(StateFd, Options)
530 ),
531 ( create_mapping(Options),
532 save_modules(SaveClass),
533 save_records,
534 save_flags,
535 save_prompt,
536 save_imports,
537 save_prolog_flags(Options),
538 save_operators(Options),
539 save_format_predicates
540 ),
541 ( '$close_wic',
542 set_prolog_flag(access_level, OldLevel),
543 close(StateFd)
544 )).
545
546
547 550
551save_modules(SaveClass) :-
552 forall(special_module(X),
553 save_module(X, SaveClass)),
554 forall((current_module(X), \+ special_module(X)),
555 save_module(X, SaveClass)).
556
557special_module(system).
558special_module(user).
559
560
566
567prepare_entry_points(Options) :-
568 define_init_goal(Options),
569 define_toplevel_goal(Options).
570
571define_init_goal(Options) :-
572 option(goal(Goal), Options),
573 !,
574 entry_point(Goal).
575define_init_goal(_).
576
577define_toplevel_goal(Options) :-
578 option(toplevel(Goal), Options),
579 !,
580 entry_point(Goal).
581define_toplevel_goal(_).
582
583entry_point(Goal) :-
584 define_predicate(Goal),
585 ( \+ predicate_property(Goal, built_in),
586 \+ predicate_property(Goal, imported_from(_))
587 -> goal_pi(Goal, PI),
588 public(PI)
589 ; true
590 ).
591
592define_predicate(Head) :-
593 '$define_predicate'(Head),
594 !. 595define_predicate(Head) :-
596 strip_module(Head, _, Term),
597 functor(Term, Name, Arity),
598 throw(error(existence_error(procedure, Name/Arity), _)).
599
600goal_pi(M:G, QPI) :-
601 !,
602 strip_module(M:G, Module, Goal),
603 functor(Goal, Name, Arity),
604 QPI = Module:Name/Arity.
605goal_pi(Goal, Name/Arity) :-
606 functor(Goal, Name, Arity).
607
612
613prepare_state(_) :-
614 forall('$init_goal'(when(prepare_state), Goal, Ctx),
615 run_initialize(Goal, Ctx)).
616
617run_initialize(Goal, Ctx) :-
618 ( catch(Goal, E, true),
619 ( var(E)
620 -> true
621 ; throw(error(initialization_error(E, Goal, Ctx), _))
622 )
623 ; throw(error(initialization_error(failed, Goal, Ctx), _))
624 ).
625
626
627 630
637
638save_autoload(Options) :-
639 option(autoload(true), Options, true),
640 !,
641 setup_call_cleanup(
642 current_prolog_flag(autoload, Old),
643 autoload_all(Options),
644 set_prolog_flag(autoload, Old)).
645save_autoload(_).
646
647
648 651
655
656save_module(M, SaveClass) :-
657 '$qlf_start_module'(M),
658 feedback('~n~nMODULE ~w~n', [M]),
659 save_unknown(M),
660 ( P = (M:_H),
661 current_predicate(_, P),
662 \+ predicate_property(P, imported_from(_)),
663 save_predicate(P, SaveClass),
664 fail
665 ; '$qlf_end_part',
666 feedback('~n', [])
667 ).
668
669save_predicate(P, _SaveClass) :-
670 predicate_property(P, foreign),
671 !,
672 P = (M:H),
673 functor(H, Name, Arity),
674 feedback('~npre-defining foreign ~w/~d ', [Name, Arity]),
675 '$add_directive_wic'('$predefine_foreign'(M:Name/Arity)),
676 save_attributes(P).
677save_predicate(P, SaveClass) :-
678 P = (M:H),
679 functor(H, F, A),
680 feedback('~nsaving ~w/~d ', [F, A]),
681 ( ( H = resource(_,_)
682 ; H = resource(_,_,_)
683 )
684 -> ( SaveClass == development
685 -> true
686 ; save_attribute(P, (dynamic)),
687 ( M == user
688 -> save_attribute(P, (multifile))
689 ),
690 feedback('(Skipped clauses)', []),
691 fail
692 )
693 ; true
694 ),
695 ( no_save(P)
696 -> true
697 ; save_attributes(P),
698 \+ predicate_property(P, (volatile)),
699 ( nth_clause(P, _, Ref),
700 feedback('.', []),
701 '$qlf_assert_clause'(Ref, SaveClass),
702 fail
703 ; true
704 )
705 ).
706
707no_save(P) :-
708 predicate_property(P, volatile),
709 \+ predicate_property(P, dynamic),
710 \+ predicate_property(P, multifile).
711
712pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :-
713 !,
714 strip_module(Head, M, _).
715pred_attrib(Attrib, Head,
716 '$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :-
717 attrib_name(Attrib, AttName, Val),
718 strip_module(Head, M, Term),
719 functor(Term, Name, Arity).
720
721attrib_name(dynamic, dynamic, true).
722attrib_name(incremental, incremental, true).
723attrib_name(volatile, volatile, true).
724attrib_name(thread_local, thread_local, true).
725attrib_name(multifile, multifile, true).
726attrib_name(public, public, true).
727attrib_name(transparent, transparent, true).
728attrib_name(discontiguous, discontiguous, true).
729attrib_name(notrace, trace, false).
730attrib_name(show_childs, hide_childs, false).
731attrib_name(built_in, system, true).
732attrib_name(nodebug, hide_childs, true).
733attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true).
734attrib_name(iso, iso, true).
735
736
737save_attribute(P, Attribute) :-
738 pred_attrib(Attribute, P, D),
739 ( Attribute == built_in 740 -> ( predicate_property(P, number_of_clauses(0))
741 -> true
742 ; predicate_property(P, volatile)
743 )
744 ; Attribute == (dynamic) 745 -> \+ predicate_property(P, thread_local)
746 ; true
747 ),
748 '$add_directive_wic'(D),
749 feedback('(~w) ', [Attribute]).
750
751save_attributes(P) :-
752 ( predicate_property(P, Attribute),
753 save_attribute(P, Attribute),
754 fail
755 ; true
756 ).
757
759
760save_unknown(M) :-
761 current_prolog_flag(M:unknown, Unknown),
762 ( Unknown == error
763 -> true
764 ; '$add_directive_wic'(set_prolog_flag(M:unknown, Unknown))
765 ).
766
767 770
771save_records :-
772 feedback('~nRECORDS~n', []),
773 ( current_key(X),
774 X \== '$topvar', 775 feedback('~n~t~8|~w ', [X]),
776 recorded(X, V, _),
777 feedback('.', []),
778 '$add_directive_wic'(recordz(X, V, _)),
779 fail
780 ; true
781 ).
782
783
784 787
788save_flags :-
789 feedback('~nFLAGS~n~n', []),
790 ( current_flag(X),
791 flag(X, V, V),
792 feedback('~t~8|~w = ~w~n', [X, V]),
793 '$add_directive_wic'(set_flag(X, V)),
794 fail
795 ; true
796 ).
797
798save_prompt :-
799 feedback('~nPROMPT~n~n', []),
800 prompt(Prompt, Prompt),
801 '$add_directive_wic'(prompt(_, Prompt)).
802
803
804 807
815
816save_imports :-
817 feedback('~nIMPORTS~n~n', []),
818 ( predicate_property(M:H, imported_from(I)),
819 \+ default_import(M, H, I),
820 functor(H, F, A),
821 feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
822 '$add_directive_wic'(qsave:restore_import(M, I, F/A)),
823 fail
824 ; true
825 ).
826
827default_import(To, Head, From) :-
828 '$get_predicate_attribute'(To:Head, (dynamic), 1),
829 predicate_property(From:Head, exported),
830 !,
831 fail.
832default_import(Into, _, From) :-
833 default_module(Into, From).
834
840
841restore_import(To, user, PI) :-
842 !,
843 export(user:PI),
844 To:import(user:PI).
845restore_import(To, From, PI) :-
846 To:import(From:PI).
847
848 851
852save_prolog_flags(Options) :-
853 feedback('~nPROLOG FLAGS~n~n', []),
854 '$current_prolog_flag'(Flag, Value0, _Scope, write, Type),
855 \+ no_save_flag(Flag),
856 map_flag(Flag, Value0, Value, Options),
857 feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]),
858 '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)),
859 fail.
860save_prolog_flags(_).
861
862no_save_flag(argv).
863no_save_flag(os_argv).
864no_save_flag(access_level).
865no_save_flag(tty_control).
866no_save_flag(readline).
867no_save_flag(associated_file).
868no_save_flag(cpu_count).
869no_save_flag(tmp_dir).
870no_save_flag(file_name_case_handling).
871no_save_flag(hwnd). 872 873map_flag(autoload, true, false, Options) :-
874 option(class(runtime), Options, runtime),
875 option(autoload(true), Options, true),
876 !.
877map_flag(_, Value, Value, _).
878
879
884
885restore_prolog_flag(Flag, Value, _Type) :-
886 current_prolog_flag(Flag, Value),
887 !.
888restore_prolog_flag(Flag, Value, _Type) :-
889 current_prolog_flag(Flag, _),
890 !,
891 catch(set_prolog_flag(Flag, Value), _, true).
892restore_prolog_flag(Flag, Value, Type) :-
893 create_prolog_flag(Flag, Value, [type(Type)]).
894
895
896 899
904
905save_operators(Options) :-
906 !,
907 option(op(save), Options, save),
908 feedback('~nOPERATORS~n', []),
909 forall(current_module(M), save_module_operators(M)),
910 feedback('~n', []).
911save_operators(_).
912
913save_module_operators(system) :- !.
914save_module_operators(M) :-
915 forall('$local_op'(P,T,M:N),
916 ( feedback('~n~t~8|~w ', [op(P,T,M:N)]),
917 '$add_directive_wic'(op(P,T,M:N))
918 )).
919
920
921 924
925save_format_predicates :-
926 feedback('~nFORMAT PREDICATES~n', []),
927 current_format_predicate(Code, Head),
928 qualify_head(Head, QHead),
929 D = format_predicate(Code, QHead),
930 feedback('~n~t~8|~w ', [D]),
931 '$add_directive_wic'(D),
932 fail.
933save_format_predicates.
934
935qualify_head(T, T) :-
936 functor(T, :, 2),
937 !.
938qualify_head(T, user:T).
939
940
941 944
948
949save_foreign_libraries(RC, _, Options) :-
950 option(foreign(save), Options),
951 !,
952 current_prolog_flag(arch, HostArch),
953 feedback('~nHOST(~w) FOREIGN LIBRARIES~n', [HostArch]),
954 save_foreign_libraries1(HostArch, RC, Options).
955save_foreign_libraries(RC, _, Options) :-
956 option(foreign(arch(Archs)), Options),
957 !,
958 forall(member(Arch, Archs),
959 ( feedback('~n~w FOREIGN LIBRARIES~n', [Arch]),
960 save_foreign_libraries1(Arch, RC, Options)
961 )).
962save_foreign_libraries(_RC, ExeFile, Options) :-
963 option(foreign(copy), Options),
964 copy_foreign_libraries(ExeFile, Options).
965save_foreign_libraries(_, _, _).
966
967save_foreign_libraries1(Arch, RC, _Options) :-
968 forall(current_foreign_library(FileSpec, _Predicates),
969 ( find_foreign_library(Arch, FileSpec, EntryName, File, Time),
970 term_to_atom(EntryName, Name),
971 zipper_append_file(RC, Name, File, [time(Time)])
972 )).
973
979
980:- if(current_prolog_flag(windows, true)). 981copy_foreign_libraries(ExeFile, _Options) :-
982 !,
983 file_directory_name(ExeFile, Dir),
984 win_process_modules(Modules),
985 include(prolog_dll, Modules, PrologDLLs),
986 maplist(copy_dll(Dir), PrologDLLs).
987:- endif. 988copy_foreign_libraries(_ExeFile, _Options) :-
989 print_message(warning, qsave(copy_foreign_libraries)).
990
991prolog_dll(DLL) :-
992 file_base_name(DLL, File),
993 absolute_file_name(foreign(File), DLL,
994 [ solutions(all) ]),
995 !.
996
997copy_dll(Dest, DLL) :-
998 print_message(informational, copy_foreign_library(DLL, Dest)),
999 copy_file(DLL, Dest).
1000
1001
1013
1014find_foreign_library(Arch, FileSpec, shlib(Arch,Name), SharedObject, Time) :-
1015 FileSpec = foreign(Name),
1016 ( catch(arch_find_shlib(Arch, FileSpec, File),
1017 E,
1018 print_message(error, E)),
1019 exists_file(File)
1020 -> true
1021 ; throw(error(existence_error(architecture_shlib(Arch), FileSpec),_))
1022 ),
1023 time_file(File, Time),
1024 strip_file(File, SharedObject).
1025
1030
1031strip_file(File, Stripped) :-
1032 absolute_file_name(path(strip), Strip,
1033 [ access(execute),
1034 file_errors(fail)
1035 ]),
1036 tmp_file(shared, Stripped),
1037 ( catch(do_strip_file(Strip, File, Stripped), E,
1038 (print_message(warning, E), fail))
1039 -> true
1040 ; print_message(warning, qsave(strip_failed(File))),
1041 fail
1042 ),
1043 !.
1044strip_file(File, File).
1045
1046do_strip_file(Strip, File, Stripped) :-
1047 format(atom(Cmd), '"~w" -x -o "~w" "~w"',
1048 [Strip, Stripped, File]),
1049 shell(Cmd),
1050 exists_file(Stripped).
1051
1063
1064:- multifile arch_shlib/3. 1065
1066arch_find_shlib(Arch, FileSpec, File) :-
1067 arch_shlib(Arch, FileSpec, File),
1068 !.
1069arch_find_shlib(Arch, FileSpec, File) :-
1070 current_prolog_flag(arch, Arch),
1071 absolute_file_name(FileSpec,
1072 [ file_type(executable),
1073 access(read),
1074 file_errors(fail)
1075 ], File),
1076 !.
1077arch_find_shlib(Arch, foreign(Base), File) :-
1078 current_prolog_flag(arch, Arch),
1079 current_prolog_flag(windows, true),
1080 current_prolog_flag(executable, WinExe),
1081 prolog_to_os_filename(Exe, WinExe),
1082 file_directory_name(Exe, BinDir),
1083 file_name_extension(Base, dll, DllFile),
1084 atomic_list_concat([BinDir, /, DllFile], File),
1085 exists_file(File).
1086
1087
1088 1091
1092open_map(Options) :-
1093 option(map(Map), Options),
1094 !,
1095 open(Map, write, Fd),
1096 asserta(verbose(Fd)).
1097open_map(_) :-
1098 retractall(verbose(_)).
1099
1100close_map :-
1101 retract(verbose(Fd)),
1102 close(Fd),
1103 !.
1104close_map.
1105
1106feedback(Fmt, Args) :-
1107 verbose(Fd),
1108 !,
1109 format(Fd, Fmt, Args).
1110feedback(_, _).
1111
1112
1113check_options([]) :- !.
1114check_options([Var|_]) :-
1115 var(Var),
1116 !,
1117 throw(error(domain_error(save_options, Var), _)).
1118check_options([Name=Value|T]) :-
1119 !,
1120 ( save_option(Name, Type, _Comment)
1121 -> ( must_be(Type, Value)
1122 -> check_options(T)
1123 ; throw(error(domain_error(Type, Value), _))
1124 )
1125 ; throw(error(domain_error(save_option, Name), _))
1126 ).
1127check_options([Term|T]) :-
1128 Term =.. [Name,Arg],
1129 !,
1130 check_options([Name=Arg|T]).
1131check_options([Var|_]) :-
1132 throw(error(domain_error(save_options, Var), _)).
1133check_options(Opt) :-
1134 throw(error(domain_error(list, Opt), _)).
1135
1136
1140
1141zipper_append_file(_, Name, _, _) :-
1142 saved_resource_file(Name),
1143 !.
1144zipper_append_file(_, _, File, _) :-
1145 source_file(File),
1146 !.
1147zipper_append_file(Zipper, Name, File, Options) :-
1148 ( option(time(_), Options)
1149 -> Options1 = Options
1150 ; time_file(File, Stamp),
1151 Options1 = [time(Stamp)|Options]
1152 ),
1153 setup_call_cleanup(
1154 open(File, read, In, [type(binary)]),
1155 setup_call_cleanup(
1156 zipper_open_new_file_in_zip(Zipper, Name, Out, Options1),
1157 copy_stream_data(In, Out),
1158 close(Out)),
1159 close(In)),
1160 assertz(saved_resource_file(Name)).
1161
1166
1167zipper_add_directory(Zipper, Name, Dir, Options) :-
1168 ( option(time(Stamp), Options)
1169 -> true
1170 ; time_file(Dir, Stamp)
1171 ),
1172 atom_concat(Name, /, DirName),
1173 ( saved_resource_file(DirName)
1174 -> true
1175 ; setup_call_cleanup(
1176 zipper_open_new_file_in_zip(Zipper, DirName, Out,
1177 [ method(store),
1178 time(Stamp)
1179 | Options
1180 ]),
1181 true,
1182 close(Out)),
1183 assertz(saved_resource_file(DirName))
1184 ).
1185
1186add_parent_dirs(Zipper, Name, Dir, Options) :-
1187 ( option(time(Stamp), Options)
1188 -> true
1189 ; time_file(Dir, Stamp)
1190 ),
1191 file_directory_name(Name, Parent),
1192 ( Parent \== Name
1193 -> add_parent_dirs(Zipper, Parent, [time(Stamp)|Options])
1194 ; true
1195 ).
1196
1197add_parent_dirs(_, '.', _) :-
1198 !.
1199add_parent_dirs(Zipper, Name, Options) :-
1200 zipper_add_directory(Zipper, Name, _, Options),
1201 file_directory_name(Name, Parent),
1202 ( Parent \== Name
1203 -> add_parent_dirs(Zipper, Parent, Options)
1204 ; true
1205 ).
1206
1207
1222
1223zipper_append_directory(Zipper, Name, Dir, Options) :-
1224 exists_directory(Dir),
1225 !,
1226 add_parent_dirs(Zipper, Name, Dir, Options),
1227 zipper_add_directory(Zipper, Name, Dir, Options),
1228 directory_files(Dir, Members),
1229 forall(member(M, Members),
1230 ( reserved(M)
1231 -> true
1232 ; ignored(M, Options)
1233 -> true
1234 ; atomic_list_concat([Dir,M], /, Entry),
1235 atomic_list_concat([Name,M], /, Store),
1236 catch(zipper_append_directory(Zipper, Store, Entry, Options),
1237 E,
1238 print_message(warning, E))
1239 )).
1240zipper_append_directory(Zipper, Name, File, Options) :-
1241 zipper_append_file(Zipper, Name, File, Options).
1242
1243reserved(.).
1244reserved(..).
1245
1250
1251ignored(File, Options) :-
1252 option(include(Patterns), Options),
1253 \+ ( ( is_list(Patterns)
1254 -> member(Pattern, Patterns)
1255 ; Pattern = Patterns
1256 ),
1257 glob_match(Pattern, File)
1258 ),
1259 !.
1260ignored(File, Options) :-
1261 option(exclude(Patterns), Options),
1262 ( is_list(Patterns)
1263 -> member(Pattern, Patterns)
1264 ; Pattern = Patterns
1265 ),
1266 glob_match(Pattern, File),
1267 !.
1268
1269glob_match(Pattern, File) :-
1270 current_prolog_flag(file_name_case_handling, case_sensitive),
1271 !,
1272 wildcard_match(Pattern, File).
1273glob_match(Pattern, File) :-
1274 wildcard_match(Pattern, File, [case_sensitive(false)]).
1275
1276
1277 1280
1284
1285:- public
1286 qsave_toplevel/0. 1287
1288qsave_toplevel :-
1289 current_prolog_flag(os_argv, Argv),
1290 qsave_options(Argv, Files, Options),
1291 set_on_error(Options),
1292 '$cmd_option_val'(compileout, Out),
1293 user:consult(Files),
1294 maybe_exit_on_errors,
1295 qsave_program(Out, user:Options).
1296
1297set_on_error(Options) :-
1298 option(on_error(_), Options), !.
1299set_on_error(_Options) :-
1300 set_prolog_flag(on_error, status).
1301
1302maybe_exit_on_errors :-
1303 '$exit_code'(Code),
1304 ( Code =\= 0
1305 -> halt
1306 ; true
1307 ).
1308
1309qsave_options([], [], []).
1310qsave_options([--|_], [], []) :-
1311 !.
1312qsave_options(['-c'|T0], Files, Options) :-
1313 !,
1314 argv_files(T0, T1, Files, FilesT),
1315 qsave_options(T1, FilesT, Options).
1316qsave_options([O|T0], Files, [Option|T]) :-
1317 string_concat(--, Opt, O),
1318 split_string(Opt, =, '', [NameS|Rest]),
1319 split_string(NameS, '-', '', NameParts),
1320 atomic_list_concat(NameParts, '_', Name),
1321 qsave_option(Name, OptName, Rest, Value),
1322 !,
1323 Option =.. [OptName, Value],
1324 qsave_options(T0, Files, T).
1325qsave_options([_|T0], Files, T) :-
1326 qsave_options(T0, Files, T).
1327
1328argv_files([], [], Files, Files).
1329argv_files([H|T], [H|T], Files, Files) :-
1330 sub_atom(H, 0, _, _, -),
1331 !.
1332argv_files([H|T0], T, [H|Files0], Files) :-
1333 argv_files(T0, T, Files0, Files).
1334
1336
1337qsave_option(Name, Name, [], true) :-
1338 save_option(Name, boolean, _),
1339 !.
1340qsave_option(NoName, Name, [], false) :-
1341 atom_concat('no_', Name, NoName),
1342 save_option(Name, boolean, _),
1343 !.
1344qsave_option(Name, Name, ValueStrings, Value) :-
1345 save_option(Name, Type, _),
1346 !,
1347 atomics_to_string(ValueStrings, "=", ValueString),
1348 convert_option_value(Type, ValueString, Value).
1349qsave_option(Name, Name, _Chars, _Value) :-
1350 existence_error(save_option, Name).
1351
1352convert_option_value(integer, String, Value) :-
1353 ( number_string(Value, String)
1354 -> true
1355 ; sub_string(String, 0, _, 1, SubString),
1356 sub_string(String, _, 1, 0, Suffix0),
1357 downcase_atom(Suffix0, Suffix),
1358 number_string(Number, SubString),
1359 suffix_multiplier(Suffix, Multiplier)
1360 -> Value is Number * Multiplier
1361 ; domain_error(integer, String)
1362 ).
1363convert_option_value(callable, String, Value) :-
1364 term_string(Value, String).
1365convert_option_value(atom, String, Value) :-
1366 atom_string(Value, String).
1367convert_option_value(boolean, String, Value) :-
1368 atom_string(Value, String).
1369convert_option_value(oneof(_), String, Value) :-
1370 atom_string(Value, String).
1371convert_option_value(ground, String, Value) :-
1372 atom_string(Value, String).
1373convert_option_value(qsave_foreign_option, "save", save).
1374convert_option_value(qsave_foreign_option, StrArchList, arch(ArchList)) :-
1375 split_string(StrArchList, ",", ", \t", StrArchList1),
1376 maplist(atom_string, ArchList, StrArchList1).
1377
1378suffix_multiplier(b, 1).
1379suffix_multiplier(k, 1024).
1380suffix_multiplier(m, 1024 * 1024).
1381suffix_multiplier(g, 1024 * 1024 * 1024).
1382
1383
1384 1387
1388:- multifile prolog:message/3. 1389
1390prolog:message(no_resource(Name, File)) -->
1391 [ 'Could not find resource ~w on ~w or system resources'-
1392 [Name, File] ].
1393prolog:message(qsave(nondet)) -->
1394 [ 'qsave_program/2 succeeded with a choice point'-[] ].
1395prolog:message(copy_foreign_library(Lib,Dir)) -->
1396 [ 'Copying ~w to ~w'-[Lib, Dir] ]