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