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]), 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, Options),
155 Reason,
156 finalize_state(Reason, StateOut, File))
157 ),
158 close_map),
159 cleanup,
160 !.
161
162write_state(StateOut, SaveClass, Options) :-
163 make_header(StateOut, SaveClass, Options),
164 setup_call_cleanup(
165 zip_open_stream(StateOut, RC, []),
166 write_zip_state(RC, SaveClass, Options),
167 zip_close(RC, [comment('SWI-Prolog saved state')])),
168 flush_output(StateOut).
169
170write_zip_state(RC, SaveClass, 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, 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(volatile, volatile, true).
723attrib_name(thread_local, thread_local, true).
724attrib_name(multifile, multifile, true).
725attrib_name(public, public, true).
726attrib_name(transparent, transparent, true).
727attrib_name(discontiguous, discontiguous, true).
728attrib_name(notrace, trace, false).
729attrib_name(show_childs, hide_childs, false).
730attrib_name(built_in, system, true).
731attrib_name(nodebug, hide_childs, true).
732attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true).
733attrib_name(iso, iso, true).
734
735
736save_attribute(P, Attribute) :-
737 pred_attrib(Attribute, P, D),
738 ( Attribute == built_in 739 -> ( predicate_property(P, number_of_clauses(0))
740 -> true
741 ; predicate_property(P, volatile)
742 )
743 ; Attribute == (dynamic) 744 -> \+ predicate_property(P, thread_local)
745 ; true
746 ),
747 '$add_directive_wic'(D),
748 feedback('(~w) ', [Attribute]).
749
750save_attributes(P) :-
751 ( predicate_property(P, Attribute),
752 save_attribute(P, Attribute),
753 fail
754 ; true
755 ).
756
758
759save_unknown(M) :-
760 current_prolog_flag(M:unknown, Unknown),
761 ( Unknown == error
762 -> true
763 ; '$add_directive_wic'(set_prolog_flag(M:unknown, Unknown))
764 ).
765
766 769
770save_records :-
771 feedback('~nRECORDS~n', []),
772 ( current_key(X),
773 X \== '$topvar', 774 feedback('~n~t~8|~w ', [X]),
775 recorded(X, V, _),
776 feedback('.', []),
777 '$add_directive_wic'(recordz(X, V, _)),
778 fail
779 ; true
780 ).
781
782
783 786
787save_flags :-
788 feedback('~nFLAGS~n~n', []),
789 ( current_flag(X),
790 flag(X, V, V),
791 feedback('~t~8|~w = ~w~n', [X, V]),
792 '$add_directive_wic'(set_flag(X, V)),
793 fail
794 ; true
795 ).
796
797save_prompt :-
798 feedback('~nPROMPT~n~n', []),
799 prompt(Prompt, Prompt),
800 '$add_directive_wic'(prompt(_, Prompt)).
801
802
803 806
814
815save_imports :-
816 feedback('~nIMPORTS~n~n', []),
817 ( predicate_property(M:H, imported_from(I)),
818 \+ default_import(M, H, I),
819 functor(H, F, A),
820 feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
821 '$add_directive_wic'(qsave:restore_import(M, I, F/A)),
822 fail
823 ; true
824 ).
825
826default_import(To, Head, From) :-
827 '$get_predicate_attribute'(To:Head, (dynamic), 1),
828 predicate_property(From:Head, exported),
829 !,
830 fail.
831default_import(Into, _, From) :-
832 default_module(Into, From).
833
839
840restore_import(To, user, PI) :-
841 !,
842 export(user:PI),
843 To:import(user:PI).
844restore_import(To, From, PI) :-
845 To:import(From:PI).
846
847 850
851save_prolog_flags(Options) :-
852 feedback('~nPROLOG FLAGS~n~n', []),
853 '$current_prolog_flag'(Flag, Value0, _Scope, write, Type),
854 \+ no_save_flag(Flag),
855 map_flag(Flag, Value0, Value, Options),
856 feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]),
857 '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)),
858 fail.
859save_prolog_flags(_).
860
861no_save_flag(argv).
862no_save_flag(os_argv).
863no_save_flag(access_level).
864no_save_flag(tty_control).
865no_save_flag(readline).
866no_save_flag(associated_file).
867no_save_flag(cpu_count).
868no_save_flag(tmp_dir).
869no_save_flag(file_name_case_handling).
870no_save_flag(hwnd). 871 872map_flag(autoload, true, false, Options) :-
873 option(class(runtime), Options, runtime),
874 option(autoload(true), Options, true),
875 !.
876map_flag(_, Value, Value, _).
877
878
883
884restore_prolog_flag(Flag, Value, _Type) :-
885 current_prolog_flag(Flag, Value),
886 !.
887restore_prolog_flag(Flag, Value, _Type) :-
888 current_prolog_flag(Flag, _),
889 !,
890 catch(set_prolog_flag(Flag, Value), _, true).
891restore_prolog_flag(Flag, Value, Type) :-
892 create_prolog_flag(Flag, Value, [type(Type)]).
893
894
895 898
903
904save_operators(Options) :-
905 !,
906 option(op(save), Options, save),
907 feedback('~nOPERATORS~n', []),
908 forall(current_module(M), save_module_operators(M)),
909 feedback('~n', []).
910save_operators(_).
911
912save_module_operators(system) :- !.
913save_module_operators(M) :-
914 forall('$local_op'(P,T,M:N),
915 ( feedback('~n~t~8|~w ', [op(P,T,M:N)]),
916 '$add_directive_wic'(op(P,T,M:N))
917 )).
918
919
920 923
924save_format_predicates :-
925 feedback('~nFORMAT PREDICATES~n', []),
926 current_format_predicate(Code, Head),
927 qualify_head(Head, QHead),
928 D = format_predicate(Code, QHead),
929 feedback('~n~t~8|~w ', [D]),
930 '$add_directive_wic'(D),
931 fail.
932save_format_predicates.
933
934qualify_head(T, T) :-
935 functor(T, :, 2),
936 !.
937qualify_head(T, user:T).
938
939
940 943
947
948save_foreign_libraries(RC, Options) :-
949 option(foreign(save), Options),
950 !,
951 current_prolog_flag(arch, HostArch),
952 feedback('~nHOST(~w) FOREIGN LIBRARIES~n', [HostArch]),
953 save_foreign_libraries1(HostArch, RC, Options).
954save_foreign_libraries(RC, Options) :-
955 option(foreign(arch(Archs)), Options),
956 !,
957 forall(member(Arch, Archs),
958 ( feedback('~n~w FOREIGN LIBRARIES~n', [Arch]),
959 save_foreign_libraries1(Arch, RC, Options)
960 )).
961save_foreign_libraries(_, _).
962
963save_foreign_libraries1(Arch, RC, _Options) :-
964 forall(current_foreign_library(FileSpec, _Predicates),
965 ( find_foreign_library(Arch, FileSpec, EntryName, File, Time),
966 term_to_atom(EntryName, Name),
967 zipper_append_file(RC, Name, File, [time(Time)])
968 )).
969
981
982find_foreign_library(Arch, FileSpec, shlib(Arch,Name), SharedObject, Time) :-
983 FileSpec = foreign(Name),
984 ( catch(arch_find_shlib(Arch, FileSpec, File),
985 E,
986 print_message(error, E)),
987 exists_file(File)
988 -> true
989 ; throw(error(existence_error(architecture_shlib(Arch), FileSpec),_))
990 ),
991 time_file(File, Time),
992 strip_file(File, SharedObject).
993
998
999strip_file(File, Stripped) :-
1000 absolute_file_name(path(strip), Strip,
1001 [ access(execute),
1002 file_errors(fail)
1003 ]),
1004 tmp_file(shared, Stripped),
1005 ( catch(do_strip_file(Strip, File, Stripped), E,
1006 (print_message(warning, E), fail))
1007 -> true
1008 ; print_message(warning, qsave(strip_failed(File))),
1009 fail
1010 ),
1011 !.
1012strip_file(File, File).
1013
1014do_strip_file(Strip, File, Stripped) :-
1015 format(atom(Cmd), '"~w" -x -o "~w" "~w"',
1016 [Strip, Stripped, File]),
1017 shell(Cmd),
1018 exists_file(Stripped).
1019
1031
1032:- multifile arch_shlib/3. 1033
1034arch_find_shlib(Arch, FileSpec, File) :-
1035 arch_shlib(Arch, FileSpec, File),
1036 !.
1037arch_find_shlib(Arch, FileSpec, File) :-
1038 current_prolog_flag(arch, Arch),
1039 absolute_file_name(FileSpec,
1040 [ file_type(executable),
1041 access(read),
1042 file_errors(fail)
1043 ], File),
1044 !.
1045arch_find_shlib(Arch, foreign(Base), File) :-
1046 current_prolog_flag(arch, Arch),
1047 current_prolog_flag(windows, true),
1048 current_prolog_flag(executable, WinExe),
1049 prolog_to_os_filename(Exe, WinExe),
1050 file_directory_name(Exe, BinDir),
1051 file_name_extension(Base, dll, DllFile),
1052 atomic_list_concat([BinDir, /, DllFile], File),
1053 exists_file(File).
1054
1055
1056 1059
1060open_map(Options) :-
1061 option(map(Map), Options),
1062 !,
1063 open(Map, write, Fd),
1064 asserta(verbose(Fd)).
1065open_map(_) :-
1066 retractall(verbose(_)).
1067
1068close_map :-
1069 retract(verbose(Fd)),
1070 close(Fd),
1071 !.
1072close_map.
1073
1074feedback(Fmt, Args) :-
1075 verbose(Fd),
1076 !,
1077 format(Fd, Fmt, Args).
1078feedback(_, _).
1079
1080
1081check_options([]) :- !.
1082check_options([Var|_]) :-
1083 var(Var),
1084 !,
1085 throw(error(domain_error(save_options, Var), _)).
1086check_options([Name=Value|T]) :-
1087 !,
1088 ( save_option(Name, Type, _Comment)
1089 -> ( must_be(Type, Value)
1090 -> check_options(T)
1091 ; throw(error(domain_error(Type, Value), _))
1092 )
1093 ; throw(error(domain_error(save_option, Name), _))
1094 ).
1095check_options([Term|T]) :-
1096 Term =.. [Name,Arg],
1097 !,
1098 check_options([Name=Arg|T]).
1099check_options([Var|_]) :-
1100 throw(error(domain_error(save_options, Var), _)).
1101check_options(Opt) :-
1102 throw(error(domain_error(list, Opt), _)).
1103
1104
1108
1109zipper_append_file(_, Name, _, _) :-
1110 saved_resource_file(Name),
1111 !.
1112zipper_append_file(_, _, File, _) :-
1113 source_file(File),
1114 !.
1115zipper_append_file(Zipper, Name, File, Options) :-
1116 ( option(time(_), Options)
1117 -> Options1 = Options
1118 ; time_file(File, Stamp),
1119 Options1 = [time(Stamp)|Options]
1120 ),
1121 setup_call_cleanup(
1122 open(File, read, In, [type(binary)]),
1123 setup_call_cleanup(
1124 zipper_open_new_file_in_zip(Zipper, Name, Out, Options1),
1125 copy_stream_data(In, Out),
1126 close(Out)),
1127 close(In)),
1128 assertz(saved_resource_file(Name)).
1129
1134
1135zipper_add_directory(Zipper, Name, Dir, Options) :-
1136 ( option(time(Stamp), Options)
1137 -> true
1138 ; time_file(Dir, Stamp)
1139 ),
1140 atom_concat(Name, /, DirName),
1141 ( saved_resource_file(DirName)
1142 -> true
1143 ; setup_call_cleanup(
1144 zipper_open_new_file_in_zip(Zipper, DirName, Out,
1145 [ method(store),
1146 time(Stamp)
1147 | Options
1148 ]),
1149 true,
1150 close(Out)),
1151 assertz(saved_resource_file(DirName))
1152 ).
1153
1154add_parent_dirs(Zipper, Name, Dir, Options) :-
1155 ( option(time(Stamp), Options)
1156 -> true
1157 ; time_file(Dir, Stamp)
1158 ),
1159 file_directory_name(Name, Parent),
1160 ( Parent \== Name
1161 -> add_parent_dirs(Zipper, Parent, [time(Stamp)|Options])
1162 ; true
1163 ).
1164
1165add_parent_dirs(_, '.', _) :-
1166 !.
1167add_parent_dirs(Zipper, Name, Options) :-
1168 zipper_add_directory(Zipper, Name, _, Options),
1169 file_directory_name(Name, Parent),
1170 ( Parent \== Name
1171 -> add_parent_dirs(Zipper, Parent, Options)
1172 ; true
1173 ).
1174
1175
1190
1191zipper_append_directory(Zipper, Name, Dir, Options) :-
1192 exists_directory(Dir),
1193 !,
1194 add_parent_dirs(Zipper, Name, Dir, Options),
1195 zipper_add_directory(Zipper, Name, Dir, Options),
1196 directory_files(Dir, Members),
1197 forall(member(M, Members),
1198 ( reserved(M)
1199 -> true
1200 ; ignored(M, Options)
1201 -> true
1202 ; atomic_list_concat([Dir,M], /, Entry),
1203 atomic_list_concat([Name,M], /, Store),
1204 catch(zipper_append_directory(Zipper, Store, Entry, Options),
1205 E,
1206 print_message(warning, E))
1207 )).
1208zipper_append_directory(Zipper, Name, File, Options) :-
1209 zipper_append_file(Zipper, Name, File, Options).
1210
1211reserved(.).
1212reserved(..).
1213
1218
1219ignored(File, Options) :-
1220 option(include(Patterns), Options),
1221 \+ ( ( is_list(Patterns)
1222 -> member(Pattern, Patterns)
1223 ; Pattern = Patterns
1224 ),
1225 glob_match(Pattern, File)
1226 ),
1227 !.
1228ignored(File, Options) :-
1229 option(exclude(Patterns), Options),
1230 ( is_list(Patterns)
1231 -> member(Pattern, Patterns)
1232 ; Pattern = Patterns
1233 ),
1234 glob_match(Pattern, File),
1235 !.
1236
1237glob_match(Pattern, File) :-
1238 current_prolog_flag(file_name_case_handling, case_sensitive),
1239 !,
1240 wildcard_match(Pattern, File).
1241glob_match(Pattern, File) :-
1242 wildcard_match(Pattern, File, [case_sensitive(false)]).
1243
1244
1245 1248
1252
1253:- public
1254 qsave_toplevel/0. 1255
1256qsave_toplevel :-
1257 current_prolog_flag(os_argv, Argv),
1258 qsave_options(Argv, Files, Options),
1259 set_on_error(Options),
1260 '$cmd_option_val'(compileout, Out),
1261 user:consult(Files),
1262 maybe_exit_on_errors,
1263 qsave_program(Out, user:Options).
1264
1265set_on_error(Options) :-
1266 option(on_error(_), Options), !.
1267set_on_error(_Options) :-
1268 set_prolog_flag(on_error, status).
1269
1270maybe_exit_on_errors :-
1271 '$exit_code'(Code),
1272 ( Code =\= 0
1273 -> halt
1274 ; true
1275 ).
1276
1277qsave_options([], [], []).
1278qsave_options([--|_], [], []) :-
1279 !.
1280qsave_options(['-c'|T0], Files, Options) :-
1281 !,
1282 argv_files(T0, T1, Files, FilesT),
1283 qsave_options(T1, FilesT, Options).
1284qsave_options([O|T0], Files, [Option|T]) :-
1285 string_concat(--, Opt, O),
1286 split_string(Opt, =, '', [NameS|Rest]),
1287 split_string(NameS, '-', '', NameParts),
1288 atomic_list_concat(NameParts, '_', Name),
1289 qsave_option(Name, OptName, Rest, Value),
1290 !,
1291 Option =.. [OptName, Value],
1292 qsave_options(T0, Files, T).
1293qsave_options([_|T0], Files, T) :-
1294 qsave_options(T0, Files, T).
1295
1296argv_files([], [], Files, Files).
1297argv_files([H|T], [H|T], Files, Files) :-
1298 sub_atom(H, 0, _, _, -),
1299 !.
1300argv_files([H|T0], T, [H|Files0], Files) :-
1301 argv_files(T0, T, Files0, Files).
1302
1304
1305qsave_option(Name, Name, [], true) :-
1306 save_option(Name, boolean, _),
1307 !.
1308qsave_option(NoName, Name, [], false) :-
1309 atom_concat('no_', Name, NoName),
1310 save_option(Name, boolean, _),
1311 !.
1312qsave_option(Name, Name, ValueStrings, Value) :-
1313 save_option(Name, Type, _),
1314 !,
1315 atomics_to_string(ValueStrings, "=", ValueString),
1316 convert_option_value(Type, ValueString, Value).
1317qsave_option(Name, Name, _Chars, _Value) :-
1318 existence_error(save_option, Name).
1319
1320convert_option_value(integer, String, Value) :-
1321 ( number_string(Value, String)
1322 -> true
1323 ; sub_string(String, 0, _, 1, SubString),
1324 sub_string(String, _, 1, 0, Suffix0),
1325 downcase_atom(Suffix0, Suffix),
1326 number_string(Number, SubString),
1327 suffix_multiplier(Suffix, Multiplier)
1328 -> Value is Number * Multiplier
1329 ; domain_error(integer, String)
1330 ).
1331convert_option_value(callable, String, Value) :-
1332 term_string(Value, String).
1333convert_option_value(atom, String, Value) :-
1334 atom_string(Value, String).
1335convert_option_value(boolean, String, Value) :-
1336 atom_string(Value, String).
1337convert_option_value(oneof(_), String, Value) :-
1338 atom_string(Value, String).
1339convert_option_value(ground, String, Value) :-
1340 atom_string(Value, String).
1341convert_option_value(qsave_foreign_option, "save", save).
1342convert_option_value(qsave_foreign_option, StrArchList, arch(ArchList)) :-
1343 split_string(StrArchList, ",", ", \t", StrArchList1),
1344 maplist(atom_string, ArchList, StrArchList1).
1345
1346suffix_multiplier(b, 1).
1347suffix_multiplier(k, 1024).
1348suffix_multiplier(m, 1024 * 1024).
1349suffix_multiplier(g, 1024 * 1024 * 1024).
1350
1351
1352 1355
1356:- multifile prolog:message/3. 1357
1358prolog:message(no_resource(Name, File)) -->
1359 [ 'Could not find resource ~w on ~w or system resources'-
1360 [Name, File] ].
1361prolog:message(qsave(nondet)) -->
1362 [ 'qsave_program/2 succeeded with a choice point'-[] ]