34
35:- module(prolog_pack,
36 [ pack_list_installed/0,
37 pack_info/1, 38 pack_list/1, 39 pack_search/1, 40 pack_install/1, 41 pack_install/2, 42 pack_upgrade/1, 43 pack_rebuild/1, 44 pack_rebuild/0, 45 pack_remove/1, 46 pack_property/2, 47
48 pack_url_file/2 49 ]).
50:- use_module(library(apply)).
51:- use_module(library(error)).
52:- use_module(library(process)).
53:- use_module(library(option)).
54:- use_module(library(readutil)).
55:- use_module(library(lists)).
56:- use_module(library(filesex)).
57:- use_module(library(xpath)).
58:- use_module(library(settings)).
59:- use_module(library(uri)).
60:- use_module(library(http/http_open)).
61:- use_module(library(http/http_client), []). 62:- if(exists_source(library(archive))).
63:- use_module(library(archive)).
64:- endif.
65
66
81
82:- multifile
83 environment/2. 84
85:- dynamic
86 pack_requires/2, 87 pack_provides_db/2. 88
89
90 93
94:- setting(server, atom, 'http://www.swi-prolog.org/pack/',
95 'Server to exchange pack information').
96
97
98 101
105
106current_pack(Pack) :-
107 '$pack':pack(Pack, _).
108
116
117pack_list_installed :-
118 findall(Pack, current_pack(Pack), Packages0),
119 Packages0 \== [],
120 !,
121 sort(Packages0, Packages),
122 length(Packages, Count),
123 format('Installed packages (~D):~n~n', [Count]),
124 maplist(pack_info(list), Packages),
125 validate_dependencies.
126pack_list_installed :-
127 print_message(informational, pack(no_packages_installed)).
128
132
133pack_info(Name) :-
134 pack_info(info, Name).
135
136pack_info(Level, Name) :-
137 must_be(atom, Name),
138 findall(Info, pack_info(Name, Level, Info), Infos0),
139 ( Infos0 == []
140 -> print_message(warning, pack(no_pack_installed(Name))),
141 fail
142 ; true
143 ),
144 update_dependency_db(Name, Infos0),
145 findall(Def, pack_default(Level, Infos, Def), Defs),
146 append(Infos0, Defs, Infos1),
147 sort(Infos1, Infos),
148 show_info(Name, Infos, [info(Level)]).
149
150
151show_info(_Name, _Properties, Options) :-
152 option(silent(true), Options),
153 !.
154show_info(Name, Properties, Options) :-
155 option(info(list), Options),
156 !,
157 memberchk(title(Title), Properties),
158 memberchk(version(Version), Properties),
159 format('i ~w@~w ~28|- ~w~n', [Name, Version, Title]).
160show_info(Name, Properties, _) :-
161 !,
162 print_property_value('Package'-'~w', [Name]),
163 findall(Term, pack_level_info(info, Term, _, _), Terms),
164 maplist(print_property(Properties), Terms).
165
166print_property(_, nl) :-
167 !,
168 format('~n').
169print_property(Properties, Term) :-
170 findall(Term, member(Term, Properties), Terms),
171 Terms \== [],
172 !,
173 pack_level_info(_, Term, LabelFmt, _Def),
174 ( LabelFmt = Label-FmtElem
175 -> true
176 ; Label = LabelFmt,
177 FmtElem = '~w'
178 ),
179 multi_valued(Terms, FmtElem, FmtList, Values),
180 atomic_list_concat(FmtList, ', ', Fmt),
181 print_property_value(Label-Fmt, Values).
182print_property(_, _).
183
184multi_valued([H], LabelFmt, [LabelFmt], Values) :-
185 !,
186 H =.. [_|Values].
187multi_valued([H|T], LabelFmt, [LabelFmt|LT], Values) :-
188 H =.. [_|VH],
189 append(VH, MoreValues, Values),
190 multi_valued(T, LabelFmt, LT, MoreValues).
191
192
193pvalue_column(24).
194print_property_value(Prop-Fmt, Values) :-
195 !,
196 pvalue_column(C),
197 atomic_list_concat(['~w:~t~*|', Fmt, '~n'], Format),
198 format(Format, [Prop,C|Values]).
199
200pack_info(Name, Level, Info) :-
201 '$pack':pack(Name, BaseDir),
202 ( Info = directory(BaseDir)
203 ; pack_info_term(BaseDir, Info)
204 ),
205 pack_level_info(Level, Info, _Format, _Default).
206
207:- public pack_level_info/4. 208
209pack_level_info(_, title(_), 'Title', '<no title>').
210pack_level_info(_, version(_), 'Installed version', '<unknown>').
211pack_level_info(info, directory(_), 'Installed in directory', -).
212pack_level_info(info, author(_, _), 'Author'-'~w <~w>', -).
213pack_level_info(info, maintainer(_, _), 'Maintainer'-'~w <~w>', -).
214pack_level_info(info, packager(_, _), 'Packager'-'~w <~w>', -).
215pack_level_info(info, home(_), 'Home page', -).
216pack_level_info(info, download(_), 'Download URL', -).
217pack_level_info(_, provides(_), 'Provides', -).
218pack_level_info(_, requires(_), 'Requires', -).
219pack_level_info(_, conflicts(_), 'Conflicts with', -).
220pack_level_info(_, replaces(_), 'Replaces packages', -).
221
222pack_default(Level, Infos, Def) :-
223 pack_level_info(Level, ITerm, _Format, Def),
224 Def \== (-),
225 \+ memberchk(ITerm, Infos).
226
230
231pack_info_term(BaseDir, Info) :-
232 directory_file_path(BaseDir, 'pack.pl', InfoFile),
233 catch(
234 setup_call_cleanup(
235 open(InfoFile, read, In),
236 term_in_stream(In, Info),
237 close(In)),
238 error(existence_error(source_sink, InfoFile), _),
239 ( print_message(error, pack(no_meta_data(BaseDir))),
240 fail
241 )).
242
243term_in_stream(In, Term) :-
244 repeat,
245 read_term(In, Term0, []),
246 ( Term0 == end_of_file
247 -> !, fail
248 ; Term = Term0,
249 valid_info_term(Term0)
250 ).
251
252valid_info_term(Term) :-
253 Term =.. [Name|Args],
254 same_length(Args, Types),
255 Decl =.. [Name|Types],
256 ( pack_info_term(Decl)
257 -> maplist(valid_info_arg, Types, Args)
258 ; print_message(warning, pack(invalid_info(Term))),
259 fail
260 ).
261
262valid_info_arg(Type, Arg) :-
263 must_be(Type, Arg).
264
269
270pack_info_term(name(atom)). 271pack_info_term(title(atom)).
272pack_info_term(keywords(list(atom))).
273pack_info_term(description(list(atom))).
274pack_info_term(version(version)).
275pack_info_term(author(atom, email_or_url)). 276pack_info_term(maintainer(atom, email_or_url)).
277pack_info_term(packager(atom, email_or_url)).
278pack_info_term(home(atom)). 279pack_info_term(download(atom)). 280pack_info_term(provides(atom)). 281pack_info_term(requires(atom)).
282pack_info_term(conflicts(atom)). 283pack_info_term(replaces(atom)). 284pack_info_term(autoload(boolean)). 285
286:- multifile
287 error:has_type/2.
288
289error:has_type(version, Version) :-
290 atom(Version),
291 version_data(Version, _Data).
292error:has_type(email_or_url, Address) :-
293 atom(Address),
294 ( sub_atom(Address, _, _, _, @)
295 -> true
296 ; uri_is_global(Address)
297 ).
298
299version_data(Version, version(Data)) :-
300 atomic_list_concat(Parts, '.', Version),
301 maplist(atom_number, Parts, Data).
302
303
304 307
334
335pack_list(Query) :-
336 pack_search(Query).
337
338pack_search(Query) :-
339 query_pack_server(search(Query), Result, []),
340 ( Result == false
341 -> ( local_search(Query, Packs),
342 Packs \== []
343 -> forall(member(pack(Pack, Stat, Title, Version, _), Packs),
344 format('~w ~w@~w ~28|- ~w~n',
345 [Stat, Pack, Version, Title]))
346 ; print_message(warning, pack(search_no_matches(Query)))
347 )
348 ; Result = true(Hits),
349 local_search(Query, Local),
350 append(Hits, Local, All),
351 sort(All, Sorted),
352 list_hits(Sorted)
353 ).
354
355list_hits([]).
356list_hits([ pack(Pack, i, Title, Version, _),
357 pack(Pack, p, Title, Version, _)
358 | More
359 ]) :-
360 !,
361 format('i ~w@~w ~28|- ~w~n', [Pack, Version, Title]),
362 list_hits(More).
363list_hits([ pack(Pack, i, Title, VersionI, _),
364 pack(Pack, p, _, VersionS, _)
365 | More
366 ]) :-
367 !,
368 version_data(VersionI, VDI),
369 version_data(VersionS, VDS),
370 ( VDI @< VDS
371 -> Tag = ('U')
372 ; Tag = ('A')
373 ),
374 format('~w ~w@~w(~w) ~28|- ~w~n', [Tag, Pack, VersionI, VersionS, Title]),
375 list_hits(More).
376list_hits([ pack(Pack, i, Title, VersionI, _)
377 | More
378 ]) :-
379 !,
380 format('l ~w@~w ~28|- ~w~n', [Pack, VersionI, Title]),
381 list_hits(More).
382list_hits([pack(Pack, Stat, Title, Version, _)|More]) :-
383 format('~w ~w@~w ~28|- ~w~n', [Stat, Pack, Version, Title]),
384 list_hits(More).
385
386
387local_search(Query, Packs) :-
388 findall(Pack, matching_installed_pack(Query, Pack), Packs).
389
390matching_installed_pack(Query, pack(Pack, i, Title, Version, URL)) :-
391 current_pack(Pack),
392 findall(Term,
393 ( pack_info(Pack, _, Term),
394 search_info(Term)
395 ), Info),
396 ( sub_atom_icasechk(Pack, _, Query)
397 -> true
398 ; memberchk(title(Title), Info),
399 sub_atom_icasechk(Title, _, Query)
400 ),
401 option(title(Title), Info, '<no title>'),
402 option(version(Version), Info, '<no version>'),
403 option(download(URL), Info, '<no download url>').
404
405search_info(title(_)).
406search_info(version(_)).
407search_info(download(_)).
408
409
410 413
429
430pack_install(Spec) :-
431 pack_default_options(Spec, Pack, [], Options),
432 pack_install(Pack, [pack(Pack)|Options]).
433
434pack_default_options(_Spec, Pack, OptsIn, Options) :-
435 option(url(URL), OptsIn),
436 !,
437 ( option(git(_), OptsIn)
438 -> Options = OptsIn
439 ; git_url(URL, Pack)
440 -> Options = [git(true)|OptsIn]
441 ; Options = OptsIn
442 ),
443 ( nonvar(Pack)
444 -> true
445 ; option(pack(Pack), Options)
446 -> true
447 ; pack_version_file(Pack, _Version, URL)
448 ).
449pack_default_options(Archive, Pack, _, Options) :- 450 must_be(atom, Archive),
451 expand_file_name(Archive, [File]),
452 exists_file(File),
453 !,
454 pack_version_file(Pack, Version, File),
455 uri_file_name(FileURL, File),
456 Options = [url(FileURL), version(Version)].
457pack_default_options(URL, Pack, _, Options) :-
458 git_url(URL, Pack),
459 !,
460 Options = [git(true), url(URL)].
461pack_default_options(FileURL, Pack, _, Options) :- 462 uri_file_name(FileURL, Dir),
463 exists_directory(Dir),
464 pack_info_term(Dir, name(Pack)),
465 !,
466 ( pack_info_term(Dir, version(Version))
467 -> uri_file_name(DirURL, Dir),
468 Options = [url(DirURL), version(Version)]
469 ; throw(error(existence_error(key, version, Dir),_))
470 ).
471pack_default_options(URL, Pack, _, Options) :- 472 pack_version_file(Pack, Version, URL),
473 download_url(URL),
474 !,
475 available_download_versions(URL, [URLVersion-LatestURL|_]),
476 Options = [url(LatestURL)|VersionOptions],
477 version_options(Version, URLVersion, VersionOptions).
478pack_default_options(Pack, Pack, OptsIn, Options) :- 479 \+ uri_is_global(Pack), 480 query_pack_server(locate(Pack), Reply, OptsIn),
481 ( Reply = true(Results)
482 -> pack_select_candidate(Pack, Results, OptsIn, Options)
483 ; print_message(warning, pack(no_match(Pack))),
484 fail
485 ).
486
487version_options(Version, Version, [version(Version)]) :- !.
488version_options(Version, _, [version(Version)]) :-
489 Version = version(List),
490 maplist(integer, List),
491 !.
492version_options(_, _, []).
493
494pack_select_candidate(Pack, Available, Options, OptsOut) :-
495 option(url(URL), Options),
496 memberchk(_Version-URLs, Available),
497 memberchk(URL, URLs),
498 !,
499 ( git_url(URL, Pack)
500 -> Extra = [git(true)]
501 ; Extra = []
502 ),
503 OptsOut = [url(URL), inquiry(true) | Extra].
504pack_select_candidate(Pack, [Version-[URL]|_], Options,
505 [url(URL), git(true), inquiry(true)]) :-
506 git_url(URL, Pack),
507 !,
508 confirm(install_from(Pack, Version, git(URL)), yes, Options).
509pack_select_candidate(Pack, [Version-[URL]|More], Options,
510 [url(URL), inquiry(true)]) :-
511 ( More == []
512 -> !
513 ; true
514 ),
515 confirm(install_from(Pack, Version, URL), yes, Options),
516 !.
517pack_select_candidate(Pack, [Version-URLs|_], Options,
518 [url(URL), inquiry(true)|Rest]) :-
519 maplist(url_menu_item, URLs, Tagged),
520 append(Tagged, [cancel=cancel], Menu),
521 Menu = [Default=_|_],
522 menu(pack(select_install_from(Pack, Version)),
523 Menu, Default, Choice, Options),
524 ( Choice == cancel
525 -> fail
526 ; Choice = git(URL)
527 -> Rest = [git(true)]
528 ; Choice = URL,
529 Rest = []
530 ).
531
(URL, git(URL)=install_from(git(URL))) :-
533 git_url(URL, _),
534 !.
535url_menu_item(URL, URL=install_from(URL)).
536
537
565
566pack_install(Spec, Options) :-
567 pack_default_options(Spec, Pack, Options, DefOptions),
568 merge_options(Options, DefOptions, PackOptions),
569 update_dependency_db,
570 pack_install_dir(PackDir, PackOptions),
571 pack_install(Pack, PackDir, PackOptions).
572
573pack_install_dir(PackDir, Options) :-
574 option(package_directory(PackDir), Options),
575 !.
576pack_install_dir(PackDir, _Options) :- 577 absolute_file_name(pack(.), PackDir,
578 [ file_type(directory),
579 access(write),
580 file_errors(fail)
581 ]),
582 !.
583pack_install_dir(PackDir, Options) :- 584 pack_create_install_dir(PackDir, Options).
585
586pack_create_install_dir(PackDir, Options) :-
587 findall(Candidate = create_dir(Candidate),
588 ( absolute_file_name(pack(.), Candidate, [solutions(all)]),
589 \+ exists_file(Candidate),
590 \+ exists_directory(Candidate),
591 file_directory_name(Candidate, Super),
592 ( exists_directory(Super)
593 -> access_file(Super, write)
594 ; true
595 )
596 ),
597 Candidates0),
598 list_to_set(Candidates0, Candidates), 599 pack_create_install_dir(Candidates, PackDir, Options).
600
601pack_create_install_dir(Candidates, PackDir, Options) :-
602 Candidates = [Default=_|_],
603 !,
604 append(Candidates, [cancel=cancel], Menu),
605 menu(pack(create_pack_dir), Menu, Default, Selected, Options),
606 Selected \== cancel,
607 ( catch(make_directory_path(Selected), E,
608 (print_message(warning, E), fail))
609 -> PackDir = Selected
610 ; delete(Candidates, PackDir=create_dir(PackDir), Remaining),
611 pack_create_install_dir(Remaining, PackDir, Options)
612 ).
613pack_create_install_dir(_, _, _) :-
614 print_message(error, pack(cannot_create_dir(pack(.)))),
615 fail.
616
617
629
630pack_install(Name, _, Options) :-
631 current_pack(Name),
632 option(upgrade(false), Options, false),
633 print_message(error, pack(already_installed(Name))),
634 pack_info(Name),
635 print_message(information, pack(remove_with(Name))),
636 !,
637 fail.
638pack_install(Name, PackDir, Options) :-
639 option(url(URL), Options),
640 uri_file_name(URL, Source),
641 !,
642 pack_install_from_local(Source, PackDir, Name, Options).
643pack_install(Name, PackDir, Options) :-
644 option(url(URL), Options),
645 uri_components(URL, Components),
646 uri_data(scheme, Components, Scheme),
647 pack_install_from_url(Scheme, URL, PackDir, Name, Options).
648
655
656pack_install_from_local(Source, PackTopDir, Name, Options) :-
657 exists_directory(Source),
658 !,
659 directory_file_path(PackTopDir, Name, PackDir),
660 prepare_pack_dir(PackDir, Options),
661 copy_directory(Source, PackDir),
662 pack_post_install(Name, PackDir, Options).
663pack_install_from_local(Source, PackTopDir, Name, Options) :-
664 exists_file(Source),
665 directory_file_path(PackTopDir, Name, PackDir),
666 prepare_pack_dir(PackDir, Options),
667 pack_unpack(Source, PackDir, Name, Options),
668 pack_post_install(Name, PackDir, Options).
669
670
674
675:- if(current_predicate(archive_extract/3)).
676pack_unpack(Source, PackDir, Pack, Options) :-
677 pack_archive_info(Source, Pack, _Info, StripOptions),
678 prepare_pack_dir(PackDir, Options),
679 archive_extract(Source, PackDir, StripOptions).
680:- else.
681pack_unpack(_,_,_,_) :-
682 existence_error(library, archive).
683:- endif.
684
685 688
698
699:- if(current_predicate(archive_open/3)).
700pack_archive_info(Archive, Pack, [archive_size(Bytes)|Info], Strip) :-
701 size_file(Archive, Bytes),
702 setup_call_cleanup(
703 archive_open(Archive, Handle, []),
704 ( repeat,
705 ( archive_next_header(Handle, InfoFile)
706 -> true
707 ; !, fail
708 )
709 ),
710 archive_close(Handle)),
711 file_base_name(InfoFile, 'pack.pl'),
712 atom_concat(Prefix, 'pack.pl', InfoFile),
713 strip_option(Prefix, Pack, Strip),
714 setup_call_cleanup(
715 archive_open_entry(Handle, Stream),
716 read_stream_to_terms(Stream, Info),
717 close(Stream)),
718 !,
719 must_be(ground, Info),
720 maplist(valid_info_term, Info).
721:- else.
722pack_archive_info(_, _, _, _) :-
723 existence_error(library, archive).
724:- endif.
725pack_archive_info(_, _, _, _) :-
726 existence_error(pack_file, 'pack.pl').
727
728strip_option('', _, []) :- !.
729strip_option('./', _, []) :- !.
730strip_option(Prefix, Pack, [remove_prefix(Prefix)]) :-
731 atom_concat(PrefixDir, /, Prefix),
732 file_base_name(PrefixDir, Base),
733 ( Base == Pack
734 -> true
735 ; pack_version_file(Pack, _, Base)
736 ).
737
738read_stream_to_terms(Stream, Terms) :-
739 read(Stream, Term0),
740 read_stream_to_terms(Term0, Stream, Terms).
741
742read_stream_to_terms(end_of_file, _, []) :- !.
743read_stream_to_terms(Term0, Stream, [Term0|Terms]) :-
744 read(Stream, Term1),
745 read_stream_to_terms(Term1, Stream, Terms).
746
747
752
753pack_git_info(GitDir, Hash, [git(true), installed_size(Bytes)|Info]) :-
754 exists_directory(GitDir),
755 !,
756 git_ls_tree(Entries, [directory(GitDir)]),
757 git_hash(Hash, [directory(GitDir)]),
758 maplist(arg(4), Entries, Sizes),
759 sum_list(Sizes, Bytes),
760 directory_file_path(GitDir, 'pack.pl', InfoFile),
761 read_file_to_terms(InfoFile, Info, [encoding(utf8)]),
762 must_be(ground, Info),
763 maplist(valid_info_term, Info).
764
768
769download_file_sanity_check(Archive, Pack, Info) :-
770 info_field(name(Name), Info),
771 info_field(version(VersionAtom), Info),
772 atom_version(VersionAtom, Version),
773 pack_version_file(PackA, VersionA, Archive),
774 must_match([Pack, PackA, Name], name),
775 must_match([Version, VersionA], version).
776
777info_field(Field, Info) :-
778 memberchk(Field, Info),
779 ground(Field),
780 !.
781info_field(Field, _Info) :-
782 functor(Field, FieldName, _),
783 print_message(error, pack(missing(FieldName))),
784 fail.
785
786must_match(Values, _Field) :-
787 sort(Values, [_]),
788 !.
789must_match(Values, Field) :-
790 print_message(error, pack(conflict(Field, Values))),
791 fail.
792
793
794 797
803
804prepare_pack_dir(Dir, Options) :-
805 exists_directory(Dir),
806 !,
807 ( empty_directory(Dir)
808 -> true
809 ; option(upgrade(true), Options)
810 -> delete_directory_contents(Dir)
811 ; confirm(remove_existing_pack(Dir), yes, Options),
812 delete_directory_contents(Dir)
813 ).
814prepare_pack_dir(Dir, _) :-
815 make_directory(Dir).
816
820
821empty_directory(Dir) :-
822 \+ ( directory_files(Dir, Entries),
823 member(Entry, Entries),
824 \+ special(Entry)
825 ).
826
827special(.).
828special(..).
829
830
837
838pack_install_from_url(_, URL, PackTopDir, Pack, Options) :-
839 option(git(true), Options),
840 !,
841 directory_file_path(PackTopDir, Pack, PackDir),
842 prepare_pack_dir(PackDir, Options),
843 run_process(path(git), [clone, URL, PackDir], []),
844 pack_git_info(PackDir, Hash, Info),
845 pack_inquiry(URL, git(Hash), Info, Options),
846 show_info(Pack, Info, Options),
847 confirm(git_post_install(PackDir, Pack), yes, Options),
848 pack_post_install(Pack, PackDir, Options).
849pack_install_from_url(Scheme, URL, PackTopDir, Pack, Options) :-
850 download_scheme(Scheme),
851 directory_file_path(PackTopDir, Pack, PackDir),
852 prepare_pack_dir(PackDir, Options),
853 pack_download_dir(PackTopDir, DownLoadDir),
854 download_file(URL, Pack, DownloadBase, Options),
855 directory_file_path(DownLoadDir, DownloadBase, DownloadFile),
856 setup_call_cleanup(
857 http_open(URL, In,
858 [ cert_verify_hook(ssl_verify)
859 ]),
860 setup_call_cleanup(
861 open(DownloadFile, write, Out, [type(binary)]),
862 copy_stream_data(In, Out),
863 close(Out)),
864 close(In)),
865 pack_archive_info(DownloadFile, Pack, Info, _),
866 download_file_sanity_check(DownloadFile, Pack, Info),
867 pack_inquiry(URL, DownloadFile, Info, Options),
868 show_info(Pack, Info, Options),
869 confirm(install_downloaded(DownloadFile), yes, Options),
870 pack_install_from_local(DownloadFile, PackTopDir, Pack, Options).
871
873
874download_file(URL, Pack, File, Options) :-
875 option(version(Version), Options),
876 !,
877 atom_version(VersionA, Version),
878 file_name_extension(_, Ext, URL),
879 format(atom(File), '~w-~w.~w', [Pack, VersionA, Ext]).
880download_file(URL, Pack, File, _) :-
881 file_base_name(URL,Basename),
882 file_name_extension(Tag,Ext,Basename),
883 tag_version(Tag,Version),
884 !,
885 atom_version(VersionA,Version),
886 format(atom(File), '~w-~w.~w', [Pack, VersionA, Ext]).
887download_file(URL, _, File, _) :-
888 file_base_name(URL, File).
889
895
896pack_url_file(URL, FileID) :-
897 github_release_url(URL, Pack, Version),
898 !,
899 download_file(URL, Pack, FileID, [version(Version)]).
900pack_url_file(URL, FileID) :-
901 file_base_name(URL, FileID).
902
903
904:- public ssl_verify/5.
905
911
912ssl_verify(_SSL,
913 _ProblemCertificate, _AllCertificates, _FirstCertificate,
914 _Error).
915
916pack_download_dir(PackTopDir, DownLoadDir) :-
917 directory_file_path(PackTopDir, 'Downloads', DownLoadDir),
918 ( exists_directory(DownLoadDir)
919 -> true
920 ; make_directory(DownLoadDir)
921 ),
922 ( access_file(DownLoadDir, write)
923 -> true
924 ; permission_error(write, directory, DownLoadDir)
925 ).
926
930
931download_url(URL) :-
932 atom(URL),
933 uri_components(URL, Components),
934 uri_data(scheme, Components, Scheme),
935 download_scheme(Scheme).
936
937download_scheme(http).
938download_scheme(https) :-
939 catch(use_module(library(http/http_ssl_plugin)),
940 E, (print_message(warning, E), fail)).
941
949
950pack_post_install(Pack, PackDir, Options) :-
951 post_install_foreign(Pack, PackDir,
952 [ build_foreign(if_absent)
953 | Options
954 ]),
955 post_install_autoload(PackDir, Options),
956 '$pack_attach'(PackDir).
957
961
962pack_rebuild(Pack) :-
963 '$pack':pack(Pack, BaseDir),
964 !,
965 catch(pack_make(BaseDir, [distclean], []), E,
966 print_message(warning, E)),
967 post_install_foreign(Pack, BaseDir, []).
968pack_rebuild(Pack) :-
969 existence_error(pack, Pack).
970
974
975pack_rebuild :-
976 forall(current_pack(Pack),
977 ( print_message(informational, pack(rebuild(Pack))),
978 pack_rebuild(Pack)
979 )).
980
981
985
986post_install_foreign(Pack, PackDir, Options) :-
987 is_foreign_pack(PackDir),
988 !,
989 ( option(build_foreign(if_absent), Options),
990 foreign_present(PackDir)
991 -> print_message(informational, pack(kept_foreign(Pack)))
992 ; setup_path,
993 save_build_environment(PackDir),
994 configure_foreign(PackDir, Options),
995 make_foreign(PackDir, Options)
996 ).
997post_install_foreign(_, _, _).
998
999foreign_present(PackDir) :-
1000 current_prolog_flag(arch, Arch),
1001 atomic_list_concat([PackDir, '/lib'], ForeignBaseDir),
1002 exists_directory(ForeignBaseDir),
1003 !,
1004 atomic_list_concat([PackDir, '/lib/', Arch], ForeignDir),
1005 exists_directory(ForeignDir),
1006 current_prolog_flag(shared_object_extension, Ext),
1007 atomic_list_concat([ForeignDir, '/*.', Ext], Pattern),
1008 expand_file_name(Pattern, Files),
1009 Files \== [].
1010
1011is_foreign_pack(PackDir) :-
1012 foreign_file(File),
1013 directory_file_path(PackDir, File, Path),
1014 exists_file(Path),
1015 !.
1016
1017foreign_file('configure.in').
1018foreign_file('configure').
1019foreign_file('Makefile').
1020foreign_file('makefile').
1021
1022
1027
1028configure_foreign(PackDir, Options) :-
1029 make_configure(PackDir, Options),
1030 directory_file_path(PackDir, configure, Configure),
1031 exists_file(Configure),
1032 !,
1033 build_environment(BuildEnv),
1034 run_process(path(bash), [Configure],
1035 [ env(BuildEnv),
1036 directory(PackDir)
1037 ]).
1038configure_foreign(_, _).
1039
1040make_configure(PackDir, _Options) :-
1041 directory_file_path(PackDir, 'configure', Configure),
1042 exists_file(Configure),
1043 !.
1044make_configure(PackDir, _Options) :-
1045 directory_file_path(PackDir, 'configure.in', ConfigureIn),
1046 exists_file(ConfigureIn),
1047 !,
1048 run_process(path(autoheader), [], [directory(PackDir)]),
1049 run_process(path(autoconf), [], [directory(PackDir)]).
1050make_configure(_, _).
1051
1055
1056make_foreign(PackDir, Options) :-
1057 pack_make(PackDir, [all, check, install], Options).
1058
1059pack_make(PackDir, Targets, _Options) :-
1060 directory_file_path(PackDir, 'Makefile', Makefile),
1061 exists_file(Makefile),
1062 !,
1063 build_environment(BuildEnv),
1064 ProcessOptions = [ directory(PackDir), env(BuildEnv) ],
1065 forall(member(Target, Targets),
1066 run_process(path(make), [Target], ProcessOptions)).
1067pack_make(_, _, _).
1068
1073
1074save_build_environment(PackDir) :-
1075 directory_file_path(PackDir, 'buildenv.sh', EnvFile),
1076 build_environment(Env),
1077 setup_call_cleanup(
1078 open(EnvFile, write, Out),
1079 write_env_script(Out, Env),
1080 close(Out)).
1081
1082write_env_script(Out, Env) :-
1083 format(Out,
1084 '# This file contains the environment that can be used to\n\c
1085 # build the foreign pack outside Prolog. This file must\n\c
1086 # be loaded into a bourne-compatible shell using\n\c
1087 #\n\c
1088 # $ source buildenv.sh\n\n',
1089 []),
1090 forall(member(Var=Value, Env),
1091 format(Out, '~w=\'~w\'\n', [Var, Value])),
1092 format(Out, '\nexport ', []),
1093 forall(member(Var=_, Env),
1094 format(Out, ' ~w', [Var])),
1095 format(Out, '\n', []).
1096
1097build_environment(Env) :-
1098 findall(Name=Value, environment(Name, Value), UserEnv),
1099 findall(Name=Value,
1100 ( def_environment(Name, Value),
1101 \+ memberchk(Name=_, UserEnv)
1102 ),
1103 DefEnv),
1104 append(UserEnv, DefEnv, Env).
1105
1106
1124
1125
1130
1131def_environment('PATH', Value) :-
1132 getenv('PATH', PATH),
1133 current_prolog_flag(executable, Exe),
1134 file_directory_name(Exe, ExeDir),
1135 prolog_to_os_filename(ExeDir, OsExeDir),
1136 ( current_prolog_flag(windows, true)
1137 -> Sep = (;)
1138 ; Sep = (:)
1139 ),
1140 atomic_list_concat([OsExeDir, Sep, PATH], Value).
1141def_environment('SWIPL', Value) :-
1142 current_prolog_flag(executable, Value).
1143def_environment('SWIPLVERSION', Value) :-
1144 current_prolog_flag(version, Value).
1145def_environment('SWIHOME', Value) :-
1146 current_prolog_flag(home, Value).
1147def_environment('SWIARCH', Value) :-
1148 current_prolog_flag(arch, Value).
1149def_environment('PACKSODIR', Value) :-
1150 current_prolog_flag(arch, Arch),
1151 atom_concat('lib/', Arch, Value).
1152def_environment('SWISOLIB', Value) :-
1153 current_prolog_flag(c_libplso, Value).
1154def_environment('SWILIB', '-lswipl').
1155def_environment('CC', Value) :-
1156 ( getenv('CC', value)
1157 -> true
1158 ; current_prolog_flag(c_cc, Value)
1159 ).
1160def_environment('LD', Value) :-
1161 ( getenv('LD', Value)
1162 -> true
1163 ; current_prolog_flag(c_cc, Value)
1164 ).
1165def_environment('CFLAGS', Value) :-
1166 ( getenv('CFLAGS', SystemFlags)
1167 -> Extra = [' ', SystemFlags]
1168 ; Extra = []
1169 ),
1170 current_prolog_flag(c_cflags, Value0),
1171 current_prolog_flag(home, Home),
1172 atomic_list_concat([Value0, ' -I"', Home, '/include"' | Extra], Value).
1173def_environment('LDSOFLAGS', Value) :-
1174 ( getenv('LDFLAGS', SystemFlags)
1175 -> Extra = [' ', SystemFlags|System]
1176 ; Extra = System
1177 ),
1178 ( current_prolog_flag(windows, true)
1179 -> current_prolog_flag(home, Home),
1180 atomic_list_concat([' -L"', Home, '/bin"'], SystemLib),
1181 System = [SystemLib]
1182 ; current_prolog_flag(shared_object_extension, so)
1183 -> System = [] 1184 ; current_prolog_flag(home, Home),
1185 current_prolog_flag(arch, Arch),
1186 atomic_list_concat([' -L"', Home, '/lib/', Arch, '"'], SystemLib),
1187 System = [SystemLib]
1188 ),
1189 current_prolog_flag(c_ldflags, LDFlags),
1190 atomic_list_concat([LDFlags, ' -shared' | Extra], Value).
1191def_environment('SOEXT', Value) :-
1192 current_prolog_flag(shared_object_extension, Value).
1193def_environment(Pass, Value) :-
1194 pass_env(Pass),
1195 getenv(Pass, Value).
1196
1197pass_env('TMP').
1198pass_env('TEMP').
1199pass_env('USER').
1200pass_env('HOME').
1201
1202 1205
1206setup_path :-
1207 has_program(path(make), _),
1208 has_program(path(gcc), _),
1209 !.
1210setup_path :-
1211 current_prolog_flag(windows, true),
1212 !,
1213 ( mingw_extend_path
1214 -> true
1215 ; print_message(error, pack(no_mingw))
1216 ).
1217setup_path.
1218
1219has_program(Program, Path) :-
1220 exe_options(ExeOptions),
1221 absolute_file_name(Program, Path,
1222 [ file_errors(fail)
1223 | ExeOptions
1224 ]).
1225
1226exe_options(Options) :-
1227 current_prolog_flag(windows, true),
1228 !,
1229 Options = [ extensions(['',exe,com]), access(read) ].
1230exe_options(Options) :-
1231 Options = [ access(execute) ].
1232
1233mingw_extend_path :-
1234 mingw_root(MinGW),
1235 directory_file_path(MinGW, bin, MinGWBinDir),
1236 atom_concat(MinGW, '/msys/*/bin', Pattern),
1237 expand_file_name(Pattern, MsysDirs),
1238 last(MsysDirs, MSysBinDir),
1239 prolog_to_os_filename(MinGWBinDir, WinDirMinGW),
1240 prolog_to_os_filename(MSysBinDir, WinDirMSYS),
1241 getenv('PATH', Path0),
1242 atomic_list_concat([WinDirMSYS, WinDirMinGW, Path0], ';', Path),
1243 setenv('PATH', Path).
1244
1245mingw_root(MinGwRoot) :-
1246 current_prolog_flag(executable, Exe),
1247 sub_atom(Exe, 1, _, _, :),
1248 sub_atom(Exe, 0, 1, _, PlDrive),
1249 Drives = [PlDrive,c,d],
1250 member(Drive, Drives),
1251 format(atom(MinGwRoot), '~a:/MinGW', [Drive]),
1252 exists_directory(MinGwRoot),
1253 !.
1254
1255
1256 1259
1263
1264post_install_autoload(PackDir, Options) :-
1265 option(autoload(true), Options, true),
1266 pack_info_term(PackDir, autoload(true)),
1267 !,
1268 directory_file_path(PackDir, prolog, PrologLibDir),
1269 make_library_index(PrologLibDir).
1270post_install_autoload(_, _).
1271
1272
1273 1276
1282
1283pack_upgrade(Pack) :-
1284 pack_info(Pack, _, directory(Dir)),
1285 directory_file_path(Dir, '.git', GitDir),
1286 exists_directory(GitDir),
1287 !,
1288 print_message(informational, pack(git_fetch(Dir))),
1289 git([fetch], [ directory(Dir) ]),
1290 git_describe(V0, [ directory(Dir) ]),
1291 git_describe(V1, [ directory(Dir), commit('origin/master') ]),
1292 ( V0 == V1
1293 -> print_message(informational, pack(up_to_date(Pack)))
1294 ; confirm(upgrade(Pack, V0, V1), yes, []),
1295 git([merge, 'origin/master'], [ directory(Dir) ]),
1296 pack_rebuild(Pack)
1297 ).
1298pack_upgrade(Pack) :-
1299 once(pack_info(Pack, _, version(VersionAtom))),
1300 atom_version(VersionAtom, Version),
1301 pack_info(Pack, _, download(URL)),
1302 wildcard_pattern(URL),
1303 !,
1304 available_download_versions(URL, [Latest-LatestURL|_Versions]),
1305 ( Latest @> Version
1306 -> confirm(upgrade(Pack, Version, Latest), yes, []),
1307 pack_install(Pack,
1308 [ url(LatestURL),
1309 upgrade(true)
1310 ])
1311 ; print_message(informational, pack(up_to_date(Pack)))
1312 ).
1313pack_upgrade(Pack) :-
1314 print_message(warning, pack(no_upgrade_info(Pack))).
1315
1316
1317 1320
1324
1325pack_remove(Pack) :-
1326 update_dependency_db,
1327 ( setof(Dep, pack_depends_on(Dep, Pack), Deps)
1328 -> confirm_remove(Pack, Deps, Delete),
1329 forall(member(P, Delete), pack_remove_forced(P))
1330 ; pack_remove_forced(Pack)
1331 ).
1332
1333pack_remove_forced(Pack) :-
1334 '$pack_detach'(Pack, BaseDir),
1335 print_message(informational, pack(remove(BaseDir))),
1336 delete_directory_and_contents(BaseDir).
1337
1338confirm_remove(Pack, Deps, Delete) :-
1339 print_message(warning, pack(depends(Pack, Deps))),
1340 menu(pack(resolve_remove),
1341 [ [Pack] = remove_only(Pack),
1342 [Pack|Deps] = remove_deps(Pack, Deps),
1343 [] = cancel
1344 ], [], Delete, []),
1345 Delete \== [].
1346
1347
1348 1351
1372
1373pack_property(Pack, Property) :-
1374 findall(Pack-Property, pack_property_(Pack, Property), List),
1375 member(Pack-Property, List). 1376
1377pack_property_(Pack, Property) :-
1378 pack_info(Pack, _, Property).
1379pack_property_(Pack, Property) :-
1380 \+ \+ info_file(Property, _),
1381 '$pack':pack(Pack, BaseDir),
1382 access_file(BaseDir, read),
1383 directory_files(BaseDir, Files),
1384 member(File, Files),
1385 info_file(Property, Pattern),
1386 downcase_atom(File, Pattern),
1387 directory_file_path(BaseDir, File, InfoFile),
1388 arg(1, Property, InfoFile).
1389
1390info_file(readme(_), 'readme.txt').
1391info_file(readme(_), 'readme').
1392info_file(todo(_), 'todo.txt').
1393info_file(todo(_), 'todo').
1394
1395
1396 1399
1403
1404git_url(URL, Pack) :-
1405 uri_components(URL, Components),
1406 uri_data(scheme, Components, Scheme),
1407 uri_data(path, Components, Path),
1408 ( Scheme == git
1409 -> true
1410 ; git_download_scheme(Scheme),
1411 file_name_extension(_, git, Path)
1412 ),
1413 file_base_name(Path, PackExt),
1414 ( file_name_extension(Pack, git, PackExt)
1415 -> true
1416 ; Pack = PackExt
1417 ),
1418 ( safe_pack_name(Pack)
1419 -> true
1420 ; domain_error(pack_name, Pack)
1421 ).
1422
1423git_download_scheme(http).
1424git_download_scheme(https).
1425
1430
1431safe_pack_name(Name) :-
1432 atom_length(Name, Len),
1433 Len >= 3, 1434 atom_codes(Name, Codes),
1435 maplist(safe_pack_char, Codes),
1436 !.
1437
1438safe_pack_char(C) :- between(0'a, 0'z, C), !.
1439safe_pack_char(C) :- between(0'A, 0'Z, C), !.
1440safe_pack_char(C) :- between(0'0, 0'9, C), !.
1441safe_pack_char(0'_).
1442
1443
1444 1447
1454
1455pack_version_file(Pack, Version, GitHubRelease) :-
1456 atomic(GitHubRelease),
1457 github_release_url(GitHubRelease, Pack, Version),
1458 !.
1459pack_version_file(Pack, Version, Path) :-
1460 atomic(Path),
1461 file_base_name(Path, File),
1462 file_name_extension(Base, Ext, File),
1463 Ext \== '',
1464 atom_codes(Base, Codes),
1465 ( phrase(pack_version(Pack, Version), Codes),
1466 safe_pack_name(Pack)
1467 -> true
1468 ; print_message(error, pack(invalid_name(File))),
1469 fail
1470 ).
1471
1480
1481github_release_url(URL, Pack, Version) :-
1482 uri_components(URL, Components),
1483 uri_data(authority, Components, 'github.com'),
1484 uri_data(scheme, Components, Scheme),
1485 download_scheme(Scheme),
1486 uri_data(path, Components, Path),
1487 atomic_list_concat(['',_Project,Pack,archive,File], /, Path),
1488 file_name_extension(Tag, Ext, File),
1489 github_archive_extension(Ext),
1490 tag_version(Tag, Version),
1491 !.
1492
1493github_archive_extension(tgz).
1494github_archive_extension(zip).
1495
1496tag_version(Tag, Version) :-
1497 version_tag_prefix(Prefix),
1498 atom_concat(Prefix, AtomVersion, Tag),
1499 atom_version(AtomVersion, Version).
1500
1501version_tag_prefix(v).
1502version_tag_prefix('V').
1503version_tag_prefix('').
1504
1505
1506:- public
1507 atom_version/2.
1508
1509atom_version(Atom, version(Parts)) :-
1510 ( atom(Atom)
1511 -> atom_codes(Atom, Codes),
1512 phrase(version(Parts), Codes)
1513 ; atomic_list_concat(Parts, '.', Atom)
1514 ).
1515
1516pack_version(Pack, version(Parts)) -->
1517 string(Codes), "-",
1518 version(Parts),
1519 !,
1520 { atom_codes(Pack, Codes)
1521 }.
1522
1523version([_|T]) -->
1524 "*",
1525 !,
1526 ( "."
1527 -> version(T)
1528 ; []
1529 ).
1530version([H|T]) -->
1531 integer(H),
1532 ( "."
1533 -> version(T)
1534 ; { T = [] }
1535 ).
1536
1537integer(H) --> digit(D0), digits(L), { number_codes(H, [D0|L]) }.
1538digit(D) --> [D], { code_type(D, digit) }.
1539digits([H|T]) --> digit(H), !, digits(T).
1540digits([]) --> [].
1541
1542
1543 1546
1564
1565pack_inquiry(_, _, _, Options) :-
1566 option(inquiry(false), Options),
1567 !.
1568pack_inquiry(URL, DownloadFile, Info, Options) :-
1569 setting(server, ServerBase),
1570 ServerBase \== '',
1571 atom_concat(ServerBase, query, Server),
1572 ( option(inquiry(true), Options)
1573 -> true
1574 ; confirm(inquiry(Server), yes, Options)
1575 ),
1576 !,
1577 ( DownloadFile = git(SHA1)
1578 -> true
1579 ; file_sha1(DownloadFile, SHA1)
1580 ),
1581 query_pack_server(install(URL, SHA1, Info), Reply, Options),
1582 inquiry_result(Reply, URL, Options).
1583pack_inquiry(_, _, _, _).
1584
1585
1590
1591query_pack_server(Query, Result, Options) :-
1592 setting(server, ServerBase),
1593 ServerBase \== '',
1594 atom_concat(ServerBase, query, Server),
1595 format(codes(Data), '~q.~n', Query),
1596 info_level(Informational, Options),
1597 print_message(Informational, pack(contacting_server(Server))),
1598 setup_call_cleanup(
1599 http_open(Server, In,
1600 [ post(codes(application/'x-prolog', Data)),
1601 header(content_type, ContentType)
1602 ]),
1603 read_reply(ContentType, In, Result),
1604 close(In)),
1605 message_severity(Result, Level, Informational),
1606 print_message(Level, pack(server_reply(Result))).
1607
1608read_reply(ContentType, In, Result) :-
1609 sub_atom(ContentType, 0, _, _, 'application/x-prolog'),
1610 !,
1611 set_stream(In, encoding(utf8)),
1612 read(In, Result).
1613read_reply(ContentType, In, _Result) :-
1614 read_string(In, 500, String),
1615 print_message(error, pack(no_prolog_response(ContentType, String))),
1616 fail.
1617
1618info_level(Level, Options) :-
1619 option(silent(true), Options),
1620 !,
1621 Level = silent.
1622info_level(informational, _).
1623
1624message_severity(true(_), Informational, Informational).
1625message_severity(false, warning, _).
1626message_severity(exception(_), error, _).
1627
1628
1633
1634inquiry_result(Reply, File, Options) :-
1635 findall(Eval, eval_inquiry(Reply, File, Eval, Options), Evaluation),
1636 \+ member(cancel, Evaluation),
1637 select_option(git(_), Options, Options1, _),
1638 forall(member(install_dependencies(Resolution), Evaluation),
1639 maplist(install_dependency(Options1), Resolution)).
1640
1641eval_inquiry(true(Reply), URL, Eval, _) :-
1642 include(alt_hash, Reply, Alts),
1643 Alts \== [],
1644 print_message(warning, pack(alt_hashes(URL, Alts))),
1645 ( memberchk(downloads(Count), Reply),
1646 ( git_url(URL, _)
1647 -> Default = yes,
1648 Eval = with_git_commits_in_same_version
1649 ; Default = no,
1650 Eval = with_alt_hashes
1651 ),
1652 confirm(continue_with_alt_hashes(Count, URL), Default, [])
1653 -> true
1654 ; !, 1655 Eval = cancel
1656 ).
1657eval_inquiry(true(Reply), _, Eval, Options) :-
1658 include(dependency, Reply, Deps),
1659 Deps \== [],
1660 select_dependency_resolution(Deps, Eval, Options),
1661 ( Eval == cancel
1662 -> !
1663 ; true
1664 ).
1665eval_inquiry(true(Reply), URL, true, Options) :-
1666 file_base_name(URL, File),
1667 info_level(Informational, Options),
1668 print_message(Informational, pack(inquiry_ok(Reply, File))).
1669eval_inquiry(exception(pack(modified_hash(_SHA1-URL, _SHA2-[URL]))),
1670 URL, Eval, Options) :-
1671 ( confirm(continue_with_modified_hash(URL), no, Options)
1672 -> Eval = true
1673 ; Eval = cancel
1674 ).
1675
1676alt_hash(alt_hash(_,_,_)).
1677dependency(dependency(_,_,_,_,_)).
1678
1679
1685
1686select_dependency_resolution(Deps, Eval, Options) :-
1687 resolve_dependencies(Deps, Resolution),
1688 exclude(local_dep, Resolution, ToBeDone),
1689 ( ToBeDone == []
1690 -> !, Eval = true
1691 ; print_message(warning, pack(install_dependencies(Resolution))),
1692 ( memberchk(_-unresolved, Resolution)
1693 -> Default = cancel
1694 ; Default = install_deps
1695 ),
1696 menu(pack(resolve_deps),
1697 [ install_deps = install_deps,
1698 install_no_deps = install_no_deps,
1699 cancel = cancel
1700 ], Default, Choice, Options),
1701 ( Choice == cancel
1702 -> !, Eval = cancel
1703 ; Choice == install_no_deps
1704 -> !, Eval = install_no_deps
1705 ; !, Eval = install_dependencies(Resolution)
1706 )
1707 ).
1708
1709local_dep(_-resolved(_)).
1710
1711
1717
1718install_dependency(Options,
1719 _Token-resolve(Pack, VersionAtom, [URL|_], SubResolve)) :-
1720 !,
1721 atom_version(VersionAtom, Version),
1722 merge_options([ url(URL),
1723 version(Version),
1724 interactive(false),
1725 inquiry(false),
1726 info(list),
1727 pack(Pack)
1728 ], Options, InstallOptions),
1729 pack_install(Pack, InstallOptions),
1730 maplist(install_dependency(Options), SubResolve).
1731install_dependency(_, _-_).
1732
1733
1734 1737
1744
1745available_download_versions(URL, Versions) :-
1746 wildcard_pattern(URL),
1747 !,
1748 file_directory_name(URL, DirURL0),
1749 ensure_slash(DirURL0, DirURL),
1750 print_message(informational, pack(query_versions(DirURL))),
1751 setup_call_cleanup(
1752 http_open(DirURL, In, []),
1753 load_html(stream(In), DOM,
1754 [ syntax_errors(quiet)
1755 ]),
1756 close(In)),
1757 findall(MatchingURL,
1758 absolute_matching_href(DOM, URL, MatchingURL),
1759 MatchingURLs),
1760 ( MatchingURLs == []
1761 -> print_message(warning, pack(no_matching_urls(URL)))
1762 ; true
1763 ),
1764 versioned_urls(MatchingURLs, VersionedURLs),
1765 keysort(VersionedURLs, SortedVersions),
1766 reverse(SortedVersions, Versions),
1767 print_message(informational, pack(found_versions(Versions))).
1768available_download_versions(URL, [Version-URL]) :-
1769 ( pack_version_file(_Pack, Version0, URL)
1770 -> Version = Version0
1771 ; Version = unknown
1772 ).
1773
1774wildcard_pattern(URL) :- sub_atom(URL, _, _, _, *).
1775wildcard_pattern(URL) :- sub_atom(URL, _, _, _, ?).
1776
1777ensure_slash(Dir, DirS) :-
1778 ( sub_atom(Dir, _, _, 0, /)
1779 -> DirS = Dir
1780 ; atom_concat(Dir, /, DirS)
1781 ).
1782
1783absolute_matching_href(DOM, Pattern, Match) :-
1784 xpath(DOM, //a(@href), HREF),
1785 uri_normalized(HREF, Pattern, Match),
1786 wildcard_match(Pattern, Match).
1787
1788versioned_urls([], []).
1789versioned_urls([H|T0], List) :-
1790 file_base_name(H, File),
1791 ( pack_version_file(_Pack, Version, File)
1792 -> List = [Version-H|T]
1793 ; List = T
1794 ),
1795 versioned_urls(T0, T).
1796
1797
1798 1801
1805
1806update_dependency_db :-
1807 retractall(pack_requires(_,_)),
1808 retractall(pack_provides_db(_,_)),
1809 forall(current_pack(Pack),
1810 ( findall(Info, pack_info(Pack, dependency, Info), Infos),
1811 update_dependency_db(Pack, Infos)
1812 )).
1813
1814update_dependency_db(Name, Info) :-
1815 retractall(pack_requires(Name, _)),
1816 retractall(pack_provides_db(Name, _)),
1817 maplist(assert_dep(Name), Info).
1818
1819assert_dep(Pack, provides(Token)) :-
1820 !,
1821 assertz(pack_provides_db(Pack, Token)).
1822assert_dep(Pack, requires(Token)) :-
1823 !,
1824 assertz(pack_requires(Pack, Token)).
1825assert_dep(_, _).
1826
1830
1831validate_dependencies :-
1832 unsatisfied_dependencies(Unsatisfied),
1833 !,
1834 print_message(warning, pack(unsatisfied(Unsatisfied))).
1835validate_dependencies.
1836
1837
1838unsatisfied_dependencies(Unsatisfied) :-
1839 findall(Req-Pack, pack_requires(Pack, Req), Reqs0),
1840 keysort(Reqs0, Reqs1),
1841 group_pairs_by_key(Reqs1, GroupedReqs),
1842 exclude(satisfied_dependency, GroupedReqs, Unsatisfied),
1843 Unsatisfied \== [].
1844
1845satisfied_dependency(Needed-_By) :-
1846 pack_provides(_, Needed).
1847
1851
1852pack_provides(Pack, Pack) :-
1853 current_pack(Pack).
1854pack_provides(Pack, Token) :-
1855 pack_provides_db(Pack, Token).
1856
1860
1861pack_depends_on(Pack, Dependency) :-
1862 ( atom(Pack)
1863 -> pack_depends_on_fwd(Pack, Dependency, [Pack])
1864 ; pack_depends_on_bwd(Pack, Dependency, [Dependency])
1865 ).
1866
1867pack_depends_on_fwd(Pack, Dependency, Visited) :-
1868 pack_depends_on_1(Pack, Dep1),
1869 \+ memberchk(Dep1, Visited),
1870 ( Dependency = Dep1
1871 ; pack_depends_on_fwd(Dep1, Dependency, [Dep1|Visited])
1872 ).
1873
1874pack_depends_on_bwd(Pack, Dependency, Visited) :-
1875 pack_depends_on_1(Dep1, Dependency),
1876 \+ memberchk(Dep1, Visited),
1877 ( Pack = Dep1
1878 ; pack_depends_on_bwd(Pack, Dep1, [Dep1|Visited])
1879 ).
1880
1881pack_depends_on_1(Pack, Dependency) :-
1882 atom(Dependency),
1883 !,
1884 pack_provides(Dependency, Token),
1885 pack_requires(Pack, Token).
1886pack_depends_on_1(Pack, Dependency) :-
1887 pack_requires(Pack, Token),
1888 pack_provides(Dependency, Token).
1889
1890
1904
1905resolve_dependencies(Dependencies, Resolution) :-
1906 maplist(dependency_pair, Dependencies, Pairs0),
1907 keysort(Pairs0, Pairs1),
1908 group_pairs_by_key(Pairs1, ByToken),
1909 maplist(resolve_dep, ByToken, Resolution).
1910
1911dependency_pair(dependency(Token, Pack, Version, URLs, SubDeps),
1912 Token-(Pack-pack(Version,URLs, SubDeps))).
1913
1914resolve_dep(Token-Pairs, Token-Resolution) :-
1915 ( resolve_dep2(Token-Pairs, Resolution)
1916 *-> true
1917 ; Resolution = unresolved
1918 ).
1919
1920resolve_dep2(Token-_, resolved(Pack)) :-
1921 pack_provides(Pack, Token).
1922resolve_dep2(_-Pairs, resolve(Pack, VersionAtom, URLs, SubResolves)) :-
1923 keysort(Pairs, Sorted),
1924 group_pairs_by_key(Sorted, ByPack),
1925 member(Pack-Versions, ByPack),
1926 Pack \== (-),
1927 maplist(version_pack, Versions, VersionData),
1928 sort(VersionData, ByVersion),
1929 reverse(ByVersion, ByVersionLatest),
1930 member(pack(Version,URLs,SubDeps), ByVersionLatest),
1931 atom_version(VersionAtom, Version),
1932 include(dependency, SubDeps, Deps),
1933 resolve_dependencies(Deps, SubResolves).
1934
1935version_pack(pack(VersionAtom,URLs,SubDeps),
1936 pack(Version,URLs,SubDeps)) :-
1937 atom_version(VersionAtom, Version).
1938
1939
1940 1943
1958
1959run_process(Executable, Argv, Options) :-
1960 \+ option(output(_), Options),
1961 \+ option(error(_), Options),
1962 current_prolog_flag(unix, true),
1963 current_prolog_flag(threads, true),
1964 !,
1965 process_create_options(Options, Extra),
1966 process_create(Executable, Argv,
1967 [ stdout(pipe(Out)),
1968 stderr(pipe(Error)),
1969 process(PID)
1970 | Extra
1971 ]),
1972 thread_create(relay_output([output-Out, error-Error]), Id, []),
1973 process_wait(PID, Status),
1974 thread_join(Id, _),
1975 ( Status == exit(0)
1976 -> true
1977 ; throw(error(process_error(process(Executable, Argv), Status), _))
1978 ).
1979run_process(Executable, Argv, Options) :-
1980 process_create_options(Options, Extra),
1981 setup_call_cleanup(
1982 process_create(Executable, Argv,
1983 [ stdout(pipe(Out)),
1984 stderr(pipe(Error)),
1985 process(PID)
1986 | Extra
1987 ]),
1988 ( read_stream_to_codes(Out, OutCodes, []),
1989 read_stream_to_codes(Error, ErrorCodes, []),
1990 process_wait(PID, Status)
1991 ),
1992 ( close(Out),
1993 close(Error)
1994 )),
1995 print_error(ErrorCodes, Options),
1996 print_output(OutCodes, Options),
1997 ( Status == exit(0)
1998 -> true
1999 ; throw(error(process_error(process(Executable, Argv), Status), _))
2000 ).
2001
2002process_create_options(Options, Extra) :-
2003 option(directory(Dir), Options, .),
2004 ( option(env(Env), Options)
2005 -> Extra = [cwd(Dir), env(Env)]
2006 ; Extra = [cwd(Dir)]
2007 ).
2008
2009relay_output([]) :- !.
2010relay_output(Output) :-
2011 pairs_values(Output, Streams),
2012 wait_for_input(Streams, Ready, infinite),
2013 relay(Ready, Output, NewOutputs),
2014 relay_output(NewOutputs).
2015
2016relay([], Outputs, Outputs).
2017relay([H|T], Outputs0, Outputs) :-
2018 selectchk(Type-H, Outputs0, Outputs1),
2019 ( at_end_of_stream(H)
2020 -> close(H),
2021 relay(T, Outputs1, Outputs)
2022 ; read_pending_codes(H, Codes, []),
2023 relay(Type, Codes),
2024 relay(T, Outputs0, Outputs)
2025 ).
2026
2027relay(error, Codes) :-
2028 set_prolog_flag(thread_message_prefix, false),
2029 print_error(Codes, []).
2030relay(output, Codes) :-
2031 print_output(Codes, []).
2032
2033print_output(OutCodes, Options) :-
2034 option(output(Codes), Options),
2035 !,
2036 Codes = OutCodes.
2037print_output(OutCodes, _) :-
2038 print_message(informational, pack(process_output(OutCodes))).
2039
2040print_error(OutCodes, Options) :-
2041 option(error(Codes), Options),
2042 !,
2043 Codes = OutCodes.
2044print_error(OutCodes, _) :-
2045 phrase(classify_message(Level), OutCodes, _),
2046 print_message(Level, pack(process_output(OutCodes))).
2047
2048classify_message(error) -->
2049 string(_), "fatal:",
2050 !.
2051classify_message(error) -->
2052 string(_), "error:",
2053 !.
2054classify_message(warning) -->
2055 string(_), "warning:",
2056 !.
2057classify_message(informational) -->
2058 [].
2059
2060string([]) --> [].
2061string([H|T]) --> [H], string(T).
2062
2063
2064 2067
2068:- multifile prolog:message//1.
2069
2071
(_Question, _Alternatives, Default, Selection, Options) :-
2073 option(interactive(false), Options),
2074 !,
2075 Selection = Default.
2076menu(Question, Alternatives, Default, Selection, _) :-
2077 length(Alternatives, N),
2078 between(1, 5, _),
2079 print_message(query, Question),
2080 print_menu(Alternatives, Default, 1),
2081 print_message(query, pack(menu(select))),
2082 read_selection(N, Choice),
2083 !,
2084 ( Choice == default
2085 -> Selection = Default
2086 ; nth1(Choice, Alternatives, Selection=_)
2087 -> true
2088 ).
2089
([], _, _).
2091print_menu([Value=Label|T], Default, I) :-
2092 ( Value == Default
2093 -> print_message(query, pack(menu(default_item(I, Label))))
2094 ; print_message(query, pack(menu(item(I, Label))))
2095 ),
2096 I2 is I + 1,
2097 print_menu(T, Default, I2).
2098
2099read_selection(Max, Choice) :-
2100 get_single_char(Code),
2101 ( answered_default(Code)
2102 -> Choice = default
2103 ; code_type(Code, digit(Choice)),
2104 between(1, Max, Choice)
2105 -> true
2106 ; print_message(warning, pack(menu(reply(1,Max)))),
2107 fail
2108 ).
2109
2115
2116confirm(_Question, Default, Options) :-
2117 Default \== none,
2118 option(interactive(false), Options, true),
2119 !,
2120 Default == yes.
2121confirm(Question, Default, _) :-
2122 between(1, 5, _),
2123 print_message(query, pack(confirm(Question, Default))),
2124 read_yes_no(YesNo, Default),
2125 !,
2126 format(user_error, '~N', []),
2127 YesNo == yes.
2128
2129read_yes_no(YesNo, Default) :-
2130 get_single_char(Code),
2131 code_yes_no(Code, Default, YesNo),
2132 !.
2133
2134code_yes_no(0'y, _, yes).
2135code_yes_no(0'Y, _, yes).
2136code_yes_no(0'n, _, no).
2137code_yes_no(0'N, _, no).
2138code_yes_no(_, none, _) :- !, fail.
2139code_yes_no(C, Default, Default) :-
2140 answered_default(C).
2141
2142answered_default(0'\r).
2143answered_default(0'\n).
2144answered_default(0'\s).
2145
2146
2147 2150
2151:- multifile prolog:message//1.
2152
2153prolog:message(pack(Message)) -->
2154 message(Message).
2155
2156:- discontiguous
2157 message//1,
2158 label//1.
2159
2160message(invalid_info(Term)) -->
2161 [ 'Invalid package description: ~q'-[Term] ].
2162message(directory_exists(Dir)) -->
2163 [ 'Package target directory exists and is not empty:', nl,
2164 '\t~q'-[Dir]
2165 ].
2166message(already_installed(Pack)) -->
2167 [ 'Pack `~w'' is already installed. Package info:'-[Pack] ].
2168message(invalid_name(File)) -->
2169 [ '~w: A package archive must be named <pack>-<version>.<ext>'-[File] ],
2170 no_tar_gz(File).
2171
2172no_tar_gz(File) -->
2173 { sub_atom(File, _, _, 0, '.tar.gz') },
2174 !,
2175 [ nl,
2176 'Package archive files must have a single extension. E.g., \'.tgz\''-[]
2177 ].
2178no_tar_gz(_) --> [].
2179
2180message(kept_foreign(Pack)) -->
2181 [ 'Found foreign libraries for target platform.'-[], nl,
2182 'Use ?- pack_rebuild(~q). to rebuild from sources'-[Pack]
2183 ].
2184message(no_pack_installed(Pack)) -->
2185 [ 'No pack ~q installed. Use ?- pack_list(Pattern) to search'-[Pack] ].
2186message(no_packages_installed) -->
2187 { setting(server, ServerBase) },
2188 [ 'There are no extra packages installed.', nl,
2189 'Please visit ~wlist.'-[ServerBase]
2190 ].
2191message(remove_with(Pack)) -->
2192 [ 'The package can be removed using: ?- ~q.'-[pack_remove(Pack)]
2193 ].
2194message(unsatisfied(Packs)) -->
2195 [ 'The following dependencies are not satisfied:', nl ],
2196 unsatisfied(Packs).
2197message(depends(Pack, Deps)) -->
2198 [ 'The following packages depend on `~w\':'-[Pack], nl ],
2199 pack_list(Deps).
2200message(remove(PackDir)) -->
2201 [ 'Removing ~q and contents'-[PackDir] ].
2202message(remove_existing_pack(PackDir)) -->
2203 [ 'Remove old installation in ~q'-[PackDir] ].
2204message(install_from(Pack, Version, git(URL))) -->
2205 [ 'Install ~w@~w from GIT at ~w'-[Pack, Version, URL] ].
2206message(install_from(Pack, Version, URL)) -->
2207 [ 'Install ~w@~w from ~w'-[Pack, Version, URL] ].
2208message(select_install_from(Pack, Version)) -->
2209 [ 'Select download location for ~w@~w'-[Pack, Version] ].
2210message(install_downloaded(File)) -->
2211 { file_base_name(File, Base),
2212 size_file(File, Size) },
2213 [ 'Install "~w" (~D bytes)'-[Base, Size] ].
2214message(git_post_install(PackDir, Pack)) -->
2215 ( { is_foreign_pack(PackDir) }
2216 -> [ 'Run post installation scripts for pack "~w"'-[Pack] ]
2217 ; [ 'Activate pack "~w"'-[Pack] ]
2218 ).
2219message(no_meta_data(BaseDir)) -->
2220 [ 'Cannot find pack.pl inside directory ~q. Not a package?'-[BaseDir] ].
2221message(inquiry(Server)) -->
2222 [ 'Verify package status (anonymously)', nl,
2223 '\tat "~w"'-[Server]
2224 ].
2225message(rebuild(Pack)) -->
2226 [ 'Checking pack "~w" for rebuild ...'-[Pack] ].
2227message(upgrade(Pack, From, To)) -->
2228 [ 'Upgrade "~w" from '-[Pack] ],
2229 msg_version(From), [' to '-[]], msg_version(To).
2230message(up_to_date(Pack)) -->
2231 [ 'Package "~w" is up-to-date'-[Pack] ].
2232message(query_versions(URL)) -->
2233 [ 'Querying "~w" to find new versions ...'-[URL] ].
2234message(no_matching_urls(URL)) -->
2235 [ 'Could not find any matching URL: ~q'-[URL] ].
2236message(found_versions([Latest-_URL|More])) -->
2237 { length(More, Len),
2238 atom_version(VLatest, Latest)
2239 },
2240 [ ' Latest version: ~w (~D older)'-[VLatest, Len] ].
2241message(process_output(Codes)) -->
2242 { split_lines(Codes, Lines) },
2243 process_lines(Lines).
2244message(contacting_server(Server)) -->
2245 [ 'Contacting server at ~w ...'-[Server], flush ].
2246message(server_reply(true(_))) -->
2247 [ at_same_line, ' ok'-[] ].
2248message(server_reply(false)) -->
2249 [ at_same_line, ' done'-[] ].
2250message(server_reply(exception(E))) -->
2251 [ 'Server reported the following error:'-[], nl ],
2252 '$messages':translate_message(E).
2253message(cannot_create_dir(Alias)) -->
2254 { setof(PackDir,
2255 absolute_file_name(Alias, PackDir, [solutions(all)]),
2256 PackDirs)
2257 },
2258 [ 'Cannot find a place to create a package directory.'-[],
2259 'Considered:'-[]
2260 ],
2261 candidate_dirs(PackDirs).
2262message(no_match(Name)) -->
2263 [ 'No registered pack matches "~w"'-[Name] ].
2264message(conflict(version, [PackV, FileV])) -->
2265 ['Version mismatch: pack.pl: '-[]], msg_version(PackV),
2266 [', file claims version '-[]], msg_version(FileV).
2267message(conflict(name, [PackInfo, FileInfo])) -->
2268 ['Pack ~w mismatch: pack.pl: ~p'-[PackInfo]],
2269 [', file claims ~w: ~p'-[FileInfo]].
2270message(no_prolog_response(ContentType, String)) -->
2271 [ 'Expected Prolog response. Got content of type ~p'-[ContentType], nl,
2272 '~s'-[String]
2273 ].
2274
2275candidate_dirs([]) --> [].
2276candidate_dirs([H|T]) --> [ nl, ' ~w'-[H] ], candidate_dirs(T).
2277
2278message(no_mingw) -->
2279 [ 'Cannot find MinGW and/or MSYS.'-[] ].
2280
2281 2282message(resolve_remove) -->
2283 [ nl, 'Please select an action:', nl, nl ].
2284message(create_pack_dir) -->
2285 [ nl, 'Create directory for packages', nl ].
2286message(menu(item(I, Label))) -->
2287 [ '~t(~d)~6| '-[I] ],
2288 label(Label).
2289message(menu(default_item(I, Label))) -->
2290 [ '~t(~d)~6| * '-[I] ],
2291 label(Label).
2292message(menu(select)) -->
2293 [ nl, 'Your choice? ', flush ].
2294message(confirm(Question, Default)) -->
2295 message(Question),
2296 confirm_default(Default),
2297 [ flush ].
2298message(menu(reply(Min,Max))) -->
2299 ( { Max =:= Min+1 }
2300 -> [ 'Please enter ~w or ~w'-[Min,Max] ]
2301 ; [ 'Please enter a number between ~w and ~w'-[Min,Max] ]
2302 ).
2303
2305
2306message(alt_hashes(URL, _Alts)) -->
2307 { git_url(URL, _)
2308 },
2309 !,
2310 [ 'GIT repository was updated without updating version' ].
2311message(alt_hashes(URL, Alts)) -->
2312 { file_base_name(URL, File)
2313 },
2314 [ 'Found multiple versions of "~w".'-[File], nl,
2315 'This could indicate a compromised or corrupted file', nl
2316 ],
2317 alt_hashes(Alts).
2318message(continue_with_alt_hashes(Count, URL)) -->
2319 [ 'Continue installation from "~w" (downloaded ~D times)'-[URL, Count] ].
2320message(continue_with_modified_hash(_URL)) -->
2321 [ 'Pack may be compromised. Continue anyway'
2322 ].
2323message(modified_hash(_SHA1-URL, _SHA2-[URL])) -->
2324 [ 'Content of ~q has changed.'-[URL]
2325 ].
2326
2327alt_hashes([]) --> [].
2328alt_hashes([H|T]) --> alt_hash(H), ( {T == []} -> [] ; [nl], alt_hashes(T) ).
2329
2330alt_hash(alt_hash(Count, URLs, Hash)) -->
2331 [ '~t~d~8| ~w'-[Count, Hash] ],
2332 alt_urls(URLs).
2333
2334alt_urls([]) --> [].
2335alt_urls([H|T]) -->
2336 [ nl, ' ~w'-[H] ],
2337 alt_urls(T).
2338
2340
2341message(install_dependencies(Resolution)) -->
2342 [ 'Package depends on the following:' ],
2343 msg_res_tokens(Resolution, 1).
2344
2345msg_res_tokens([], _) --> [].
2346msg_res_tokens([H|T], L) --> msg_res_token(H, L), msg_res_tokens(T, L).
2347
2348msg_res_token(Token-unresolved, L) -->
2349 res_indent(L),
2350 [ '"~w" cannot be satisfied'-[Token] ].
2351msg_res_token(Token-resolve(Pack, Version, [URL|_], SubResolves), L) -->
2352 !,
2353 res_indent(L),
2354 [ '"~w", provided by ~w@~w from ~w'-[Token, Pack, Version, URL] ],
2355 { L2 is L+1 },
2356 msg_res_tokens(SubResolves, L2).
2357msg_res_token(Token-resolved(Pack), L) -->
2358 !,
2359 res_indent(L),
2360 [ '"~w", provided by installed pack ~w'-[Token,Pack] ].
2361
2362res_indent(L) -->
2363 { I is L*2 },
2364 [ nl, '~*c'-[I,0'\s] ].
2365
2366message(resolve_deps) -->
2367 [ nl, 'What do you wish to do' ].
2368label(install_deps) -->
2369 [ 'Install proposed dependencies' ].
2370label(install_no_deps) -->
2371 [ 'Only install requested package' ].
2372
2373
2374message(git_fetch(Dir)) -->
2375 [ 'Running "git fetch" in ~q'-[Dir] ].
2376
2378
2379message(inquiry_ok(Reply, File)) -->
2380 { memberchk(downloads(Count), Reply),
2381 memberchk(rating(VoteCount, Rating), Reply),
2382 !,
2383 length(Stars, Rating),
2384 maplist(=(0'*), Stars)
2385 },
2386 [ '"~w" was downloaded ~D times. Package rated ~s (~D votes)'-
2387 [ File, Count, Stars, VoteCount ]
2388 ].
2389message(inquiry_ok(Reply, File)) -->
2390 { memberchk(downloads(Count), Reply)
2391 },
2392 [ '"~w" was downloaded ~D times'-[ File, Count ] ].
2393
2394 2395unsatisfied([]) --> [].
2396unsatisfied([Needed-[By]|T]) -->
2397 [ '\t`~q\', needed by package `~w\''-[Needed, By] ],
2398 unsatisfied(T).
2399unsatisfied([Needed-By|T]) -->
2400 [ '\t`~q\', needed by packages'-[Needed], nl ],
2401 pack_list(By),
2402 unsatisfied(T).
2403
2404pack_list([]) --> [].
2405pack_list([H|T]) -->
2406 [ '\t\tPackage `~w\''-[H], nl ],
2407 pack_list(T).
2408
2409process_lines([]) --> [].
2410process_lines([H|T]) -->
2411 [ '~s'-[H] ],
2412 ( {T==[]}
2413 -> []
2414 ; [nl], process_lines(T)
2415 ).
2416
2417split_lines([], []) :- !.
2418split_lines(All, [Line1|More]) :-
2419 append(Line1, [0'\n|Rest], All),
2420 !,
2421 split_lines(Rest, More).
2422split_lines(Line, [Line]).
2423
2424label(remove_only(Pack)) -->
2425 [ 'Only remove package ~w (break dependencies)'-[Pack] ].
2426label(remove_deps(Pack, Deps)) -->
2427 { length(Deps, Count) },
2428 [ 'Remove package ~w and ~D dependencies'-[Pack, Count] ].
2429label(create_dir(Dir)) -->
2430 [ '~w'-[Dir] ].
2431label(install_from(git(URL))) -->
2432 !,
2433 [ 'GIT repository at ~w'-[URL] ].
2434label(install_from(URL)) -->
2435 [ '~w'-[URL] ].
2436label(cancel) -->
2437 [ 'Cancel' ].
2438
2439confirm_default(yes) -->
2440 [ ' Y/n? ' ].
2441confirm_default(no) -->
2442 [ ' y/N? ' ].
2443confirm_default(none) -->
2444 [ ' y/n? ' ].
2445
2446msg_version(Version) -->
2447 { atom(Version) },
2448 !,
2449 [ '~w'-[Version] ].
2450msg_version(VersionData) -->
2451 !,
2452 { atom_version(Atom, VersionData) },
2453 [ '~w'-[Atom] ].