1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2012-2021, VU University Amsterdam
    7                              CWI, Amsterdam
    8                              SWI-Prolog Solutions b.v.
    9    All rights reserved.
   10
   11    Redistribution and use in source and binary forms, with or without
   12    modification, are permitted provided that the following conditions
   13    are met:
   14
   15    1. Redistributions of source code must retain the above copyright
   16       notice, this list of conditions and the following disclaimer.
   17
   18    2. Redistributions in binary form must reproduce the above copyright
   19       notice, this list of conditions and the following disclaimer in
   20       the documentation and/or other materials provided with the
   21       distribution.
   22
   23    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   24    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   25    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   26    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   27    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   28    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   29    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   30    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   31    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   32    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   33    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   34    POSSIBILITY OF SUCH DAMAGE.
   35*/
   36
   37:- module(prolog_pack,
   38          [ pack_list_installed/0,
   39            pack_info/1,                % +Name
   40            pack_list/1,                % +Keyword
   41            pack_search/1,              % +Keyword
   42            pack_install/1,             % +Name
   43            pack_install/2,             % +Name, +Options
   44            pack_upgrade/1,             % +Name
   45            pack_rebuild/1,             % +Name
   46            pack_rebuild/0,             % All packages
   47            pack_remove/1,              % +Name
   48            pack_property/2,            % ?Name, ?Property
   49            pack_attach/2,              % +Dir, +Options
   50
   51            pack_url_file/2             % +URL, -File
   52          ]).   53:- use_module(library(apply)).   54:- use_module(library(error)).   55:- use_module(library(option)).   56:- use_module(library(readutil)).   57:- use_module(library(lists)).   58:- use_module(library(filesex)).   59:- use_module(library(xpath)).   60:- use_module(library(settings)).   61:- use_module(library(uri)).   62:- use_module(library(dcg/basics)).   63:- use_module(library(http/http_open)).   64:- use_module(library(http/json)).   65:- use_module(library(http/http_client), []).   % plugin for POST support
   66:- use_module(library(prolog_config)).   67:- use_module(library(debug), [assertion/1]).   68:- use_module(library(pairs), [group_pairs_by_key/2]).   69% Stuff we may not have and may not need
   70:- autoload(library(git)).   71:- autoload(library(sgml)).   72:- autoload(library(sha)).   73:- autoload(library(build/tools)).   74
   75/** <module> A package manager for Prolog
   76
   77The library(prolog_pack) provides the SWI-Prolog   package manager. This
   78library lets you inspect installed   packages,  install packages, remove
   79packages, etc. It is complemented by   the  built-in attach_packs/0 that
   80makes installed packages available as libraries.
   81
   82To make changes to a package:
   83  * Clone the git repo,t go into the repo and run:
   84    `?- pack_install(.).`
   85    This builds the pack locally and creates a symlink to make it available.
   86  * `?- pack_rebuild(package_name).`
   87    This runs `make clean` and `make` with the right environment. It will also
   88    write a file `buildendv.sh` that you can source to get the environment
   89    for running a normal `make` (this is done only if there is a `configure`
   90    step; i.e., if there is a `configure.in` or `configure`.
   91  * The build process also supports `cmake`.
   92
   93Once you have made the changes, you should edit the `pack.pl` file
   94to change the `version` item. After updating the git repo, issue
   95a `pack_install(package_name, [upgrade(true), test(true), rebuild(make)])`
   96to cause the repository to refresh.
   97
   98@see    Installed packages can be inspected using =|?- doc_browser.|=
   99@see    library(build/tools)
  100@tbd    Version logic
  101@tbd    Find and resolve conflicts
  102@tbd    Upgrade git packages
  103@tbd    Validate git packages
  104@tbd    Test packages: run tests from directory `test'.
  105*/
  106
  107:- multifile
  108    environment/2.                          % Name, Value
  109
  110:- dynamic
  111    pack_requires/2,                        % Pack, Requirement
  112    pack_provides_db/2.                     % Pack, Provided
  113
  114
  115                 /*******************************
  116                 *          CONSTANTS           *
  117                 *******************************/
  118
  119:- setting(server, atom, 'https://www.swi-prolog.org/pack/',
  120           'Server to exchange pack information').  121
  122
  123                 /*******************************
  124                 *         PACKAGE INFO         *
  125                 *******************************/
  126
  127%!  current_pack(?Pack) is nondet.
  128%!  current_pack(?Pack, ?Dir) is nondet.
  129%
  130%   True if Pack is a currently installed pack.
  131
  132current_pack(Pack) :-
  133    current_pack(Pack, _).
  134
  135current_pack(Pack, Dir) :-
  136    '$pack':pack(Pack, Dir).
  137
  138%!  pack_list_installed is det.
  139%
  140%   List currently installed  packages.   Unlike  pack_list/1,  only
  141%   locally installed packages are displayed   and  no connection is
  142%   made to the internet.
  143%
  144%   @see Use pack_list/1 to find packages.
  145
  146pack_list_installed :-
  147    findall(Pack, current_pack(Pack), Packages0),
  148    Packages0 \== [],
  149    !,
  150    sort(Packages0, Packages),
  151    length(Packages, Count),
  152    format('Installed packages (~D):~n~n', [Count]),
  153    maplist(pack_info(list), Packages),
  154    validate_dependencies.
  155pack_list_installed :-
  156    print_message(informational, pack(no_packages_installed)).
  157
  158%!  pack_info(+Pack)
  159%
  160%   Print more detailed information about Pack.
  161
  162pack_info(Name) :-
  163    pack_info(info, Name).
  164
  165pack_info(Level, Name) :-
  166    must_be(atom, Name),
  167    findall(Info, pack_info(Name, Level, Info), Infos0),
  168    (   Infos0 == []
  169    ->  print_message(warning, pack(no_pack_installed(Name))),
  170        fail
  171    ;   true
  172    ),
  173    update_dependency_db(Name, Infos0),
  174    findall(Def,  pack_default(Level, Infos, Def), Defs),
  175    append(Infos0, Defs, Infos1),
  176    sort(Infos1, Infos),
  177    show_info(Name, Infos, [info(Level)]).
  178
  179
  180show_info(_Name, _Properties, Options) :-
  181    option(silent(true), Options),
  182    !.
  183show_info(Name, Properties, Options) :-
  184    option(info(list), Options),
  185    !,
  186    memberchk(title(Title), Properties),
  187    memberchk(version(Version), Properties),
  188    format('i ~w@~w ~28|- ~w~n', [Name, Version, Title]).
  189show_info(Name, Properties, _) :-
  190    !,
  191    print_property_value('Package'-'~w', [Name]),
  192    findall(Term, pack_level_info(info, Term, _, _), Terms),
  193    maplist(print_property(Properties), Terms).
  194
  195print_property(_, nl) :-
  196    !,
  197    format('~n').
  198print_property(Properties, Term) :-
  199    findall(Term, member(Term, Properties), Terms),
  200    Terms \== [],
  201    !,
  202    pack_level_info(_, Term, LabelFmt, _Def),
  203    (   LabelFmt = Label-FmtElem
  204    ->  true
  205    ;   Label = LabelFmt,
  206        FmtElem = '~w'
  207    ),
  208    multi_valued(Terms, FmtElem, FmtList, Values),
  209    atomic_list_concat(FmtList, ', ', Fmt),
  210    print_property_value(Label-Fmt, Values).
  211print_property(_, _).
  212
  213multi_valued([H], LabelFmt, [LabelFmt], Values) :-
  214    !,
  215    H =.. [_|Values].
  216multi_valued([H|T], LabelFmt, [LabelFmt|LT], Values) :-
  217    H =.. [_|VH],
  218    append(VH, MoreValues, Values),
  219    multi_valued(T, LabelFmt, LT, MoreValues).
  220
  221
  222pvalue_column(24).
  223print_property_value(Prop-Fmt, Values) :-
  224    !,
  225    pvalue_column(C),
  226    atomic_list_concat(['~w:~t~*|', Fmt, '~n'], Format),
  227    format(Format, [Prop,C|Values]).
  228
  229pack_info(Name, Level, Info) :-
  230    '$pack':pack(Name, BaseDir),
  231    (   Info = directory(BaseDir)
  232    ;   pack_info_term(BaseDir, Info)
  233    ),
  234    pack_level_info(Level, Info, _Format, _Default).
  235
  236:- public pack_level_info/4.                    % used by web-server
  237
  238pack_level_info(_,    title(_),         'Title',                   '<no title>').
  239pack_level_info(_,    version(_),       'Installed version',       '<unknown>').
  240pack_level_info(info, directory(_),     'Installed in directory',  -).
  241pack_level_info(info, author(_, _),     'Author'-'~w <~w>',        -).
  242pack_level_info(info, maintainer(_, _), 'Maintainer'-'~w <~w>',    -).
  243pack_level_info(info, packager(_, _),   'Packager'-'~w <~w>',      -).
  244pack_level_info(info, home(_),          'Home page',               -).
  245pack_level_info(info, download(_),      'Download URL',            -).
  246pack_level_info(_,    provides(_),      'Provides',                -).
  247pack_level_info(_,    requires(_),      'Requires',                -).
  248pack_level_info(_,    conflicts(_),     'Conflicts with',          -).
  249pack_level_info(_,    replaces(_),      'Replaces packages',       -).
  250pack_level_info(info, library(_),	'Provided libraries',      -).
  251
  252pack_default(Level, Infos, Def) :-
  253    pack_level_info(Level, ITerm, _Format, Def),
  254    Def \== (-),
  255    \+ memberchk(ITerm, Infos).
  256
  257%!  pack_info_term(+PackDir, ?Info) is nondet.
  258%
  259%   True when Info is meta-data for the package PackName.
  260
  261pack_info_term(BaseDir, Info) :-
  262    directory_file_path(BaseDir, 'pack.pl', InfoFile),
  263    catch(
  264        setup_call_cleanup(
  265            open(InfoFile, read, In),
  266            term_in_stream(In, Info),
  267            close(In)),
  268        error(existence_error(source_sink, InfoFile), _),
  269        ( print_message(error, pack(no_meta_data(BaseDir))),
  270          fail
  271        )).
  272pack_info_term(BaseDir, library(Lib)) :-
  273    atom_concat(BaseDir, '/prolog/', LibDir),
  274    atom_concat(LibDir, '*.pl', Pattern),
  275    expand_file_name(Pattern, Files),
  276    maplist(atom_concat(LibDir), Plain, Files),
  277    convlist(base_name, Plain, Libs),
  278    member(Lib, Libs).
  279
  280base_name(File, Base) :-
  281    file_name_extension(Base, pl, File).
  282
  283term_in_stream(In, Term) :-
  284    repeat,
  285        read_term(In, Term0, []),
  286        (   Term0 == end_of_file
  287        ->  !, fail
  288        ;   Term = Term0,
  289            valid_info_term(Term0)
  290        ).
  291
  292valid_info_term(Term) :-
  293    Term =.. [Name|Args],
  294    same_length(Args, Types),
  295    Decl =.. [Name|Types],
  296    (   pack_info_term(Decl)
  297    ->  maplist(valid_info_arg, Types, Args)
  298    ;   print_message(warning, pack(invalid_info(Term))),
  299        fail
  300    ).
  301
  302valid_info_arg(Type, Arg) :-
  303    must_be(Type, Arg).
  304
  305%!  pack_info_term(?Term) is nondet.
  306%
  307%   True when Term describes name and   arguments of a valid package
  308%   info term.
  309
  310pack_info_term(name(atom)).                     % Synopsis
  311pack_info_term(title(atom)).
  312pack_info_term(keywords(list(atom))).
  313pack_info_term(description(list(atom))).
  314pack_info_term(version(version)).
  315pack_info_term(author(atom, email_or_url_or_empty)).     % Persons
  316pack_info_term(maintainer(atom, email_or_url)).
  317pack_info_term(packager(atom, email_or_url)).
  318pack_info_term(pack_version(nonneg)).           % Package convention version
  319pack_info_term(home(atom)).                     % Home page
  320pack_info_term(download(atom)).                 % Source
  321pack_info_term(provides(atom)).                 % Dependencies
  322pack_info_term(requires(dependency)).
  323pack_info_term(conflicts(dependency)).          % Conflicts with package
  324pack_info_term(replaces(atom)).                 % Replaces another package
  325pack_info_term(autoload(boolean)).              % Default installation options
  326
  327:- multifile
  328    error:has_type/2.  329
  330error:has_type(version, Version) :-
  331    atom(Version),
  332    version_data(Version, _Data).
  333error:has_type(email_or_url, Address) :-
  334    atom(Address),
  335    (   sub_atom(Address, _, _, _, @)
  336    ->  true
  337    ;   uri_is_global(Address)
  338    ).
  339error:has_type(email_or_url_or_empty, Address) :-
  340    (   Address == ''
  341    ->  true
  342    ;   error:has_type(email_or_url, Address)
  343    ).
  344error:has_type(dependency, Value) :-
  345    is_dependency(Value, _Token, _Version).
  346
  347version_data(Version, version(Data)) :-
  348    atomic_list_concat(Parts, '.', Version),
  349    maplist(atom_number, Parts, Data).
  350
  351is_dependency(Token, Token, *) :-
  352    atom(Token).
  353is_dependency(Term, Token, VersionCmp) :-
  354    Term =.. [Op,Token,Version],
  355    cmp(Op, _),
  356    version_data(Version, _),
  357    VersionCmp =.. [Op,Version].
  358
  359cmp(<,  @<).
  360cmp(=<, @=<).
  361cmp(==, ==).
  362cmp(>=, @>=).
  363cmp(>,  @>).
  364
  365
  366                 /*******************************
  367                 *            SEARCH            *
  368                 *******************************/
  369
  370%!  pack_search(+Query) is det.
  371%!  pack_list(+Query) is det.
  372%
  373%   Query package server and installed packages and display results.
  374%   Query is matches case-insensitively against   the name and title
  375%   of known and installed packages. For   each  matching package, a
  376%   single line is displayed that provides:
  377%
  378%     - Installation status
  379%       - *p*: package, not installed
  380%       - *i*: installed package; up-to-date with public version
  381%       - *U*: installed package; can be upgraded
  382%       - *A*: installed package; newer than publically available
  383%       - *l*: installed package; not on server
  384%     - Name@Version
  385%     - Name@Version(ServerVersion)
  386%     - Title
  387%
  388%   Hint: =|?- pack_list('').|= lists all packages.
  389%
  390%   The predicates pack_list/1 and pack_search/1  are synonyms. Both
  391%   contact the package server at  http://www.swi-prolog.org to find
  392%   available packages.
  393%
  394%   @see    pack_list_installed/0 to list installed packages without
  395%           contacting the server.
  396
  397pack_list(Query) :-
  398    pack_search(Query).
  399
  400pack_search(Query) :-
  401    query_pack_server(search(Query), Result, []),
  402    (   Result == false
  403    ->  (   local_search(Query, Packs),
  404            Packs \== []
  405        ->  forall(member(pack(Pack, Stat, Title, Version, _), Packs),
  406                   format('~w ~w@~w ~28|- ~w~n',
  407                          [Stat, Pack, Version, Title]))
  408        ;   print_message(warning, pack(search_no_matches(Query)))
  409        )
  410    ;   Result = true(Hits),
  411        local_search(Query, Local),
  412        append(Hits, Local, All),
  413        sort(All, Sorted),
  414        list_hits(Sorted)
  415    ).
  416
  417list_hits([]).
  418list_hits([ pack(Pack, i, Title, Version, _),
  419            pack(Pack, p, Title, Version, _)
  420          | More
  421          ]) :-
  422    !,
  423    format('i ~w@~w ~28|- ~w~n', [Pack, Version, Title]),
  424    list_hits(More).
  425list_hits([ pack(Pack, i, Title, VersionI, _),
  426            pack(Pack, p, _,     VersionS, _)
  427          | More
  428          ]) :-
  429    !,
  430    version_data(VersionI, VDI),
  431    version_data(VersionS, VDS),
  432    (   VDI @< VDS
  433    ->  Tag = ('U')
  434    ;   Tag = ('A')
  435    ),
  436    format('~w ~w@~w(~w) ~28|- ~w~n', [Tag, Pack, VersionI, VersionS, Title]),
  437    list_hits(More).
  438list_hits([ pack(Pack, i, Title, VersionI, _)
  439          | More
  440          ]) :-
  441    !,
  442    format('l ~w@~w ~28|- ~w~n', [Pack, VersionI, Title]),
  443    list_hits(More).
  444list_hits([pack(Pack, Stat, Title, Version, _)|More]) :-
  445    format('~w ~w@~w ~28|- ~w~n', [Stat, Pack, Version, Title]),
  446    list_hits(More).
  447
  448
  449local_search(Query, Packs) :-
  450    findall(Pack, matching_installed_pack(Query, Pack), Packs).
  451
  452matching_installed_pack(Query, pack(Pack, i, Title, Version, URL)) :-
  453    current_pack(Pack),
  454    findall(Term,
  455            ( pack_info(Pack, _, Term),
  456              search_info(Term)
  457            ), Info),
  458    (   sub_atom_icasechk(Pack, _, Query)
  459    ->  true
  460    ;   memberchk(title(Title), Info),
  461        sub_atom_icasechk(Title, _, Query)
  462    ),
  463    option(title(Title), Info, '<no title>'),
  464    option(version(Version), Info, '<no version>'),
  465    option(download(URL), Info, '<no download url>').
  466
  467search_info(title(_)).
  468search_info(version(_)).
  469search_info(download(_)).
  470
  471
  472                 /*******************************
  473                 *            INSTALL           *
  474                 *******************************/
  475
  476%!  pack_install(+Spec:atom) is det.
  477%
  478%   Install a package.  Spec is one of
  479%
  480%     * Archive file name
  481%     * HTTP URL of an archive file name.  This URL may contain a
  482%       star (*) for the version.  In this case pack_install asks
  483%       for the directory content and selects the latest version.
  484%     * GIT URL (not well supported yet)
  485%     * A local directory name given as =|file://|= URL or `'.'`
  486%     * A package name.  This queries the package repository
  487%       at http://www.swi-prolog.org
  488%
  489%   After resolving the type of package,   pack_install/2 is used to
  490%   do the actual installation.
  491
  492pack_install(Spec) :-
  493    pack_default_options(Spec, Pack, [], Options),
  494    pack_install(Pack, [pack(Pack)|Options]).
  495
  496%!  pack_default_options(+Spec, -Pack, +OptionsIn, -Options) is det.
  497%
  498%   Establish  the  pack  name  (Pack)  and    install  options  from  a
  499%   specification and options (OptionsIn) provided by the user.
  500
  501pack_default_options(_Spec, Pack, OptsIn, Options) :-
  502    option(already_installed(pack(Pack,_Version)), OptsIn),
  503    !,
  504    Options = OptsIn.
  505pack_default_options(_Spec, Pack, OptsIn, Options) :-
  506    option(url(URL), OptsIn),
  507    !,
  508    (   option(git(_), OptsIn)
  509    ->  Options = OptsIn
  510    ;   git_url(URL, Pack)
  511    ->  Options = [git(true)|OptsIn]
  512    ;   Options = OptsIn
  513    ),
  514    (   nonvar(Pack)
  515    ->  true
  516    ;   option(pack(Pack), Options)
  517    ->  true
  518    ;   pack_version_file(Pack, _Version, URL)
  519    ).
  520pack_default_options(Archive, Pack, _, Options) :-      % Install from archive
  521    must_be(atom, Archive),
  522    \+ uri_is_global(Archive),
  523    expand_file_name(Archive, [File]),
  524    exists_file(File),
  525    !,
  526    pack_version_file(Pack, Version, File),
  527    uri_file_name(FileURL, File),
  528    Options = [url(FileURL), version(Version)].
  529pack_default_options(URL, Pack, _, Options) :-
  530    git_url(URL, Pack),
  531    !,
  532    Options = [git(true), url(URL)].
  533pack_default_options(FileURL, Pack, _, Options) :-      % Install from directory
  534    uri_file_name(FileURL, Dir),
  535    exists_directory(Dir),
  536    pack_info_term(Dir, name(Pack)),
  537    !,
  538    (   pack_info_term(Dir, version(Version))
  539    ->  uri_file_name(DirURL, Dir),
  540        Options = [url(DirURL), version(Version)]
  541    ;   throw(error(existence_error(key, version, Dir),_))
  542    ).
  543pack_default_options('.', Pack, _, Options) :-          % Install from CWD
  544    pack_info_term('.', name(Pack)),
  545    !,
  546    working_directory(Dir, Dir),
  547    (   pack_info_term(Dir, version(Version))
  548    ->  uri_file_name(DirURL, Dir),
  549        Options = [url(DirURL), version(Version) | Options1],
  550        (   current_prolog_flag(windows, true)
  551        ->  Options1 = []
  552        ;   Options1 = [link(true), rebuild(make)]
  553        )
  554    ;   throw(error(existence_error(key, version, Dir),_))
  555    ).
  556pack_default_options(URL, Pack, _, Options) :-          % Install from URL
  557    pack_version_file(Pack, Version, URL),
  558    download_url(URL),
  559    !,
  560    available_download_versions(URL, [URLVersion-LatestURL|_]),
  561    Options = [url(LatestURL)|VersionOptions],
  562    version_options(Version, URLVersion, VersionOptions).
  563pack_default_options(Pack, Pack, OptsIn, Options) :-    % Install from name
  564    \+ uri_is_global(Pack),                             % ignore URLs
  565    query_pack_server(locate(Pack), Reply, OptsIn),
  566    (   Reply = true(Results)
  567    ->  pack_select_candidate(Pack, Results, OptsIn, Options)
  568    ;   print_message(warning, pack(no_match(Pack))),
  569        fail
  570    ).
  571
  572version_options(Version, Version, [version(Version)]) :- !.
  573version_options(Version, _, [version(Version)]) :-
  574    Version = version(List),
  575    maplist(integer, List),
  576    !.
  577version_options(_, _, []).
  578
  579%!  pack_select_candidate(+Pack, +AvailableVersions, +OptionsIn, -Options)
  580%
  581%   Select from available packages.
  582
  583pack_select_candidate(Pack, [AtomVersion-_|_], Options,
  584                      [already_installed(pack(Pack, Installed))|Options]) :-
  585    current_pack(Pack),
  586    pack_info(Pack, _, version(InstalledAtom)),
  587    atom_version(InstalledAtom, Installed),
  588    atom_version(AtomVersion, Version),
  589    Installed @>= Version,
  590    !.
  591pack_select_candidate(Pack, Available, Options, OptsOut) :-
  592    option(url(URL), Options),
  593    memberchk(_Version-URLs, Available),
  594    memberchk(URL, URLs),
  595    !,
  596    (   git_url(URL, Pack)
  597    ->  Extra = [git(true)]
  598    ;   Extra = []
  599    ),
  600    OptsOut = [url(URL), inquiry(true) | Extra].
  601pack_select_candidate(Pack, [Version-[URL]|_], Options,
  602                      [url(URL), git(true), inquiry(true)]) :-
  603    git_url(URL, Pack),
  604    !,
  605    confirm(install_from(Pack, Version, git(URL)), yes, Options).
  606pack_select_candidate(Pack, [Version-[URL]|More], Options,
  607                      [url(URL), inquiry(true) | Upgrade]) :-
  608    (   More == []
  609    ->  !
  610    ;   true
  611    ),
  612    confirm(install_from(Pack, Version, URL), yes, Options),
  613    !,
  614    add_upgrade(Pack, Upgrade).
  615pack_select_candidate(Pack, [Version-URLs|_], Options,
  616                      [url(URL), inquiry(true)|Rest]) :-
  617    maplist(url_menu_item, URLs, Tagged),
  618    append(Tagged, [cancel=cancel], Menu),
  619    Menu = [Default=_|_],
  620    menu(pack(select_install_from(Pack, Version)),
  621         Menu, Default, Choice, Options),
  622    (   Choice == cancel
  623    ->  fail
  624    ;   Choice = git(URL)
  625    ->  Rest = [git(true)|Upgrade]
  626    ;   Choice = URL,
  627        Rest = Upgrade
  628    ),
  629    add_upgrade(Pack, Upgrade).
  630
  631add_upgrade(Pack, Options) :-
  632    current_pack(Pack),
  633    !,
  634    Options = [upgrade(true)].
  635add_upgrade(_, []).
  636
  637url_menu_item(URL, git(URL)=install_from(git(URL))) :-
  638    git_url(URL, _),
  639    !.
  640url_menu_item(URL, URL=install_from(URL)).
  641
  642
  643%!  pack_install(+Name, +Options) is det.
  644%
  645%   Install package Name.  Processes  the   options  below.  Default
  646%   options as would be used by  pack_install/1 are used to complete
  647%   the provided Options.
  648%
  649%     * url(+URL)
  650%     Source for downloading the package
  651%     * package_directory(+Dir)
  652%     Directory into which to install the package.
  653%     * global(+Boolean)
  654%     If `true`, install in the XDG common application data path, making
  655%     the pack accessible to everyone. If `false`, install in the XDG
  656%     user application data path, making the pack accessible for the
  657%     current user only.  If the option is absent, use the first
  658%     existing and writable directory.  If that doesn't exist find
  659%     locations where it can be created and prompt the user to do
  660%     so.
  661%     * interactive(+Boolean)
  662%     Use default answer without asking the user if there
  663%     is a default action.
  664%     * silent(+Boolean)
  665%     If `true` (default false), suppress informational progress
  666%     messages.
  667%     * upgrade(+Boolean)
  668%     If `true` (default `false`), upgrade package if it is already
  669%     installed.
  670%     * rebuild(Condition)
  671%     Rebuild the foreign components.  Condition is one of
  672%     `if_absent` (default, do nothing if the directory with foreign
  673%     resources exists), `make` (run `make`) or `true` (run `make
  674%     distclean` followed by the default configure and build steps).
  675%     * test(Boolean)
  676%     If `true` (default), run the pack tests.
  677%     * git(+Boolean)
  678%     If `true` (default `false` unless `URL` ends with =.git=),
  679%     assume the URL is a GIT repository.
  680%     * link(+Boolean)
  681%     Can be used if the installation source is a local directory
  682%     and the file system supports symbolic links.  In this case
  683%     the system adds the current directory to the pack registration
  684%     using a symbolic link and performs the local installation steps.
  685%
  686%   Non-interactive installation can be established using the option
  687%   interactive(false). It is adviced to   install from a particular
  688%   _trusted_ URL instead of the  plain   pack  name  for unattented
  689%   operation.
  690
  691pack_install(Spec, Options) :-
  692    pack_default_options(Spec, Pack, Options, DefOptions),
  693    (   option(already_installed(Installed), DefOptions)
  694    ->  print_message(informational, pack(already_installed(Installed)))
  695    ;   merge_options(Options, DefOptions, PackOptions),
  696        update_dependency_db,
  697        pack_install_dir(PackDir, PackOptions),
  698        pack_install(Pack, PackDir, PackOptions)
  699    ).
  700
  701pack_install_dir(PackDir, Options) :-
  702    option(package_directory(PackDir), Options),
  703    !.
  704pack_install_dir(PackDir, Options) :-
  705    base_alias(Alias, Options),
  706    absolute_file_name(Alias, PackDir,
  707                       [ file_type(directory),
  708                         access(write),
  709                         file_errors(fail)
  710                       ]),
  711    !.
  712pack_install_dir(PackDir, Options) :-
  713    pack_create_install_dir(PackDir, Options).
  714
  715base_alias(Alias, Options) :-
  716    option(global(true), Options),
  717    !,
  718    Alias = common_app_data(pack).
  719base_alias(Alias, Options) :-
  720    option(global(false), Options),
  721    !,
  722    Alias = user_app_data(pack).
  723base_alias(Alias, _Options) :-
  724    Alias = pack('.').
  725
  726pack_create_install_dir(PackDir, Options) :-
  727    base_alias(Alias, Options),
  728    findall(Candidate = create_dir(Candidate),
  729            ( absolute_file_name(Alias, Candidate, [solutions(all)]),
  730              \+ exists_file(Candidate),
  731              \+ exists_directory(Candidate),
  732              file_directory_name(Candidate, Super),
  733              (   exists_directory(Super)
  734              ->  access_file(Super, write)
  735              ;   true
  736              )
  737            ),
  738            Candidates0),
  739    list_to_set(Candidates0, Candidates),   % keep order
  740    pack_create_install_dir(Candidates, PackDir, Options).
  741
  742pack_create_install_dir(Candidates, PackDir, Options) :-
  743    Candidates = [Default=_|_],
  744    !,
  745    append(Candidates, [cancel=cancel], Menu),
  746    menu(pack(create_pack_dir), Menu, Default, Selected, Options),
  747    Selected \== cancel,
  748    (   catch(make_directory_path(Selected), E,
  749              (print_message(warning, E), fail))
  750    ->  PackDir = Selected
  751    ;   delete(Candidates, PackDir=create_dir(PackDir), Remaining),
  752        pack_create_install_dir(Remaining, PackDir, Options)
  753    ).
  754pack_create_install_dir(_, _, _) :-
  755    print_message(error, pack(cannot_create_dir(pack(.)))),
  756    fail.
  757
  758
  759%!  pack_install(+Pack, +PackDir, +Options)
  760%
  761%   Install package Pack into PackDir.  Options:
  762%
  763%     - url(URL)
  764%     Install from the given URL, URL is either a file://, a git URL
  765%     or a download URL.
  766%     - upgrade(Boolean)
  767%     If Pack is already installed and Boolean is `true`, update the
  768%     package to the latest version.  If Boolean is `false` print
  769%     an error and fail.
  770
  771pack_install(Name, _, Options) :-
  772    current_pack(Name, Dir),
  773    option(upgrade(false), Options, false),
  774    \+ pack_is_in_local_dir(Name, Dir, Options),
  775    print_message(error, pack(already_installed(Name))),
  776    pack_info(Name),
  777    print_message(information, pack(remove_with(Name))),
  778    !,
  779    fail.
  780pack_install(Name, PackDir, Options) :-
  781    option(url(URL), Options),
  782    uri_file_name(URL, Source),
  783    !,
  784    pack_install_from_local(Source, PackDir, Name, Options).
  785pack_install(Name, PackDir, Options) :-
  786    option(url(URL), Options),
  787    uri_components(URL, Components),
  788    uri_data(scheme, Components, Scheme),
  789    pack_install_from_url(Scheme, URL, PackDir, Name, Options).
  790
  791%!  pack_install_from_local(+Source, +PackTopDir, +Name, +Options)
  792%
  793%   Install a package from a local media.
  794%
  795%   @tbd    Provide an option to install directories using a
  796%           link (or file-links).
  797
  798pack_install_from_local(Source, PackTopDir, Name, Options) :-
  799    exists_directory(Source),
  800    !,
  801    directory_file_path(PackTopDir, Name, PackDir),
  802    (   option(link(true), Options)
  803    ->  (   same_file(Source, PackDir)
  804        ->  true
  805        ;   atom_concat(PackTopDir, '/', PackTopDirS),
  806            relative_file_name(Source, PackTopDirS, RelPath),
  807            link_file(RelPath, PackDir, symbolic),
  808            assertion(same_file(Source, PackDir))
  809        )
  810    ;   prepare_pack_dir(PackDir, Options),
  811        copy_directory(Source, PackDir)
  812    ),
  813    pack_post_install(Name, PackDir, Options).
  814pack_install_from_local(Source, PackTopDir, Name, Options) :-
  815    exists_file(Source),
  816    directory_file_path(PackTopDir, Name, PackDir),
  817    prepare_pack_dir(PackDir, Options),
  818    pack_unpack(Source, PackDir, Name, Options),
  819    pack_post_install(Name, PackDir, Options).
  820
  821pack_is_in_local_dir(_Pack, PackDir, Options) :-
  822    option(url(DirURL), Options),
  823    uri_file_name(DirURL, Dir),
  824    same_file(PackDir, Dir).
  825
  826
  827%!  pack_unpack(+SourceFile, +PackDir, +Pack, +Options)
  828%
  829%   Unpack an archive to the given package dir.
  830
  831:- if(exists_source(library(archive))).  832pack_unpack(Source, PackDir, Pack, Options) :-
  833    ensure_loaded_archive,
  834    pack_archive_info(Source, Pack, _Info, StripOptions),
  835    prepare_pack_dir(PackDir, Options),
  836    archive_extract(Source, PackDir,
  837                    [ exclude(['._*'])          % MacOS resource forks
  838                    | StripOptions
  839                    ]).
  840:- else.  841pack_unpack(_,_,_,_) :-
  842    existence_error(library, archive).
  843:- endif.  844
  845                 /*******************************
  846                 *             INFO             *
  847                 *******************************/
  848
  849%!  pack_archive_info(+Archive, +Pack, -Info, -Strip)
  850%
  851%   True when Archive archives Pack. Info  is unified with the terms
  852%   from pack.pl in the  pack  and   Strip  is  the strip-option for
  853%   archive_extract/3.
  854%
  855%   Requires library(archive), which is lazily loaded when needed.
  856%
  857%   @error  existence_error(pack_file, 'pack.pl') if the archive
  858%           doesn't contain pack.pl
  859%   @error  Syntax errors if pack.pl cannot be parsed.
  860
  861:- if(exists_source(library(archive))).  862ensure_loaded_archive :-
  863    current_predicate(archive_open/3),
  864    !.
  865ensure_loaded_archive :-
  866    use_module(library(archive)).
  867
  868pack_archive_info(Archive, Pack, [archive_size(Bytes)|Info], Strip) :-
  869    ensure_loaded_archive,
  870    size_file(Archive, Bytes),
  871    setup_call_cleanup(
  872        archive_open(Archive, Handle, []),
  873        (   repeat,
  874            (   archive_next_header(Handle, InfoFile)
  875            ->  true
  876            ;   !, fail
  877            )
  878        ),
  879        archive_close(Handle)),
  880    file_base_name(InfoFile, 'pack.pl'),
  881    atom_concat(Prefix, 'pack.pl', InfoFile),
  882    strip_option(Prefix, Pack, Strip),
  883    setup_call_cleanup(
  884        archive_open_entry(Handle, Stream),
  885        read_stream_to_terms(Stream, Info),
  886        close(Stream)),
  887    !,
  888    must_be(ground, Info),
  889    maplist(valid_info_term, Info).
  890:- else.  891pack_archive_info(_, _, _, _) :-
  892    existence_error(library, archive).
  893:- endif.  894pack_archive_info(_, _, _, _) :-
  895    existence_error(pack_file, 'pack.pl').
  896
  897strip_option('', _, []) :- !.
  898strip_option('./', _, []) :- !.
  899strip_option(Prefix, Pack, [remove_prefix(Prefix)]) :-
  900    atom_concat(PrefixDir, /, Prefix),
  901    file_base_name(PrefixDir, Base),
  902    (   Base == Pack
  903    ->  true
  904    ;   pack_version_file(Pack, _, Base)
  905    ->  true
  906    ;   \+ sub_atom(PrefixDir, _, _, _, /)
  907    ).
  908
  909read_stream_to_terms(Stream, Terms) :-
  910    read(Stream, Term0),
  911    read_stream_to_terms(Term0, Stream, Terms).
  912
  913read_stream_to_terms(end_of_file, _, []) :- !.
  914read_stream_to_terms(Term0, Stream, [Term0|Terms]) :-
  915    read(Stream, Term1),
  916    read_stream_to_terms(Term1, Stream, Terms).
  917
  918
  919%!  pack_git_info(+GitDir, -Hash, -Info) is det.
  920%
  921%   Retrieve info from a cloned git   repository  that is compatible
  922%   with pack_archive_info/4.
  923
  924pack_git_info(GitDir, Hash, [git(true), installed_size(Bytes)|Info]) :-
  925    exists_directory(GitDir),
  926    !,
  927    git_ls_tree(Entries, [directory(GitDir)]),
  928    git_hash(Hash, [directory(GitDir)]),
  929    maplist(arg(4), Entries, Sizes),
  930    sum_list(Sizes, Bytes),
  931    directory_file_path(GitDir, 'pack.pl', InfoFile),
  932    read_file_to_terms(InfoFile, Info, [encoding(utf8)]),
  933    must_be(ground, Info),
  934    maplist(valid_info_term, Info).
  935
  936%!  download_file_sanity_check(+Archive, +Pack, +Info) is semidet.
  937%
  938%   Perform basic sanity checks on DownloadFile
  939
  940download_file_sanity_check(Archive, Pack, Info) :-
  941    info_field(name(Name), Info),
  942    info_field(version(VersionAtom), Info),
  943    atom_version(VersionAtom, Version),
  944    pack_version_file(PackA, VersionA, Archive),
  945    must_match([Pack, PackA, Name], name),
  946    must_match([Version, VersionA], version).
  947
  948info_field(Field, Info) :-
  949    memberchk(Field, Info),
  950    ground(Field),
  951    !.
  952info_field(Field, _Info) :-
  953    functor(Field, FieldName, _),
  954    print_message(error, pack(missing(FieldName))),
  955    fail.
  956
  957must_match(Values, _Field) :-
  958    sort(Values, [_]),
  959    !.
  960must_match(Values, Field) :-
  961    print_message(error, pack(conflict(Field, Values))),
  962    fail.
  963
  964
  965                 /*******************************
  966                 *         INSTALLATION         *
  967                 *******************************/
  968
  969%!  prepare_pack_dir(+Dir, +Options)
  970%
  971%   Prepare for installing the package into  Dir. This
  972%
  973%     - If the directory exist and is empty, done.
  974%     - Else if the directory exists, remove the directory and recreate
  975%       it. Note that if the directory is a symlink this just deletes
  976%       the link.
  977%     - Else create the directory.
  978
  979prepare_pack_dir(Dir, Options) :-
  980    exists_directory(Dir),
  981    !,
  982    (   empty_directory(Dir)
  983    ->  true
  984    ;   (   option(upgrade(true), Options)
  985        ;   confirm(remove_existing_pack(Dir), yes, Options)
  986        )
  987    ->  delete_directory_and_contents(Dir),
  988        make_directory(Dir)
  989    ).
  990prepare_pack_dir(Dir, _) :-
  991    make_directory(Dir).
  992
  993%!  empty_directory(+Directory) is semidet.
  994%
  995%   True if Directory is empty (holds no files or sub-directories).
  996
  997empty_directory(Dir) :-
  998    \+ ( directory_files(Dir, Entries),
  999         member(Entry, Entries),
 1000         \+ special(Entry)
 1001       ).
 1002
 1003special(.).
 1004special(..).
 1005
 1006
 1007%!  pack_install_from_url(+Scheme, +URL, +PackDir, +Pack, +Options)
 1008%
 1009%   Install a package from a remote source. For git repositories, we
 1010%   simply clone. Archives are  downloaded.   We  currently  use the
 1011%   built-in HTTP client. For complete  coverage, we should consider
 1012%   using an external (e.g., curl) if available.
 1013
 1014pack_install_from_url(_, URL, PackTopDir, Pack, Options) :-
 1015    option(git(true), Options),
 1016    !,
 1017    directory_file_path(PackTopDir, Pack, PackDir),
 1018    prepare_pack_dir(PackDir, Options),
 1019    run_process(path(git), [clone, URL, PackDir], []),
 1020    pack_git_info(PackDir, Hash, Info),
 1021    pack_inquiry(URL, git(Hash), Info, Options),
 1022    show_info(Pack, Info, Options),
 1023    confirm(git_post_install(PackDir, Pack), yes, Options),
 1024    pack_post_install(Pack, PackDir, Options).
 1025pack_install_from_url(Scheme, URL, PackTopDir, Pack, Options) :-
 1026    download_scheme(Scheme),
 1027    directory_file_path(PackTopDir, Pack, PackDir),
 1028    prepare_pack_dir(PackDir, Options),
 1029    pack_download_dir(PackTopDir, DownLoadDir),
 1030    download_file(URL, Pack, DownloadBase, Options),
 1031    directory_file_path(DownLoadDir, DownloadBase, DownloadFile),
 1032    setup_call_cleanup(
 1033        http_open(URL, In,
 1034                  [ cert_verify_hook(ssl_verify)
 1035                  ]),
 1036        setup_call_cleanup(
 1037            open(DownloadFile, write, Out, [type(binary)]),
 1038            copy_stream_data(In, Out),
 1039            close(Out)),
 1040        close(In)),
 1041    pack_archive_info(DownloadFile, Pack, Info, _),
 1042    download_file_sanity_check(DownloadFile, Pack, Info),
 1043    pack_inquiry(URL, DownloadFile, Info, Options),
 1044    show_info(Pack, Info, Options),
 1045    confirm(install_downloaded(DownloadFile), yes, Options),
 1046    pack_install_from_local(DownloadFile, PackTopDir, Pack, Options).
 1047
 1048%!  download_file(+URL, +Pack, -File, +Options) is det.
 1049
 1050download_file(URL, Pack, File, Options) :-
 1051    option(version(Version), Options),
 1052    !,
 1053    atom_version(VersionA, Version),
 1054    file_name_extension(_, Ext, URL),
 1055    format(atom(File), '~w-~w.~w', [Pack, VersionA, Ext]).
 1056download_file(URL, Pack, File, _) :-
 1057    file_base_name(URL,Basename),
 1058    no_int_file_name_extension(Tag,Ext,Basename),
 1059    tag_version(Tag,Version),
 1060    !,
 1061    atom_version(VersionA,Version),
 1062    format(atom(File0), '~w-~w', [Pack, VersionA]),
 1063    file_name_extension(File0, Ext, File).
 1064download_file(URL, _, File, _) :-
 1065    file_base_name(URL, File).
 1066
 1067%!  pack_url_file(+URL, -File) is det.
 1068%
 1069%   True if File is a unique id for the referenced pack and version.
 1070%   Normally, that is simply the  base   name,  but  GitHub archives
 1071%   destroy this picture. Needed by the pack manager.
 1072
 1073pack_url_file(URL, FileID) :-
 1074    github_release_url(URL, Pack, Version),
 1075    !,
 1076    download_file(URL, Pack, FileID, [version(Version)]).
 1077pack_url_file(URL, FileID) :-
 1078    file_base_name(URL, FileID).
 1079
 1080
 1081:- public ssl_verify/5. 1082
 1083%!  ssl_verify(+SSL, +ProblemCert, +AllCerts, +FirstCert, +Error)
 1084%
 1085%   Currently we accept  all  certificates.   We  organise  our  own
 1086%   security using SHA1 signatures, so  we   do  not  care about the
 1087%   source of the data.
 1088
 1089ssl_verify(_SSL,
 1090           _ProblemCertificate, _AllCertificates, _FirstCertificate,
 1091           _Error).
 1092
 1093pack_download_dir(PackTopDir, DownLoadDir) :-
 1094    directory_file_path(PackTopDir, 'Downloads', DownLoadDir),
 1095    (   exists_directory(DownLoadDir)
 1096    ->  true
 1097    ;   make_directory(DownLoadDir)
 1098    ),
 1099    (   access_file(DownLoadDir, write)
 1100    ->  true
 1101    ;   permission_error(write, directory, DownLoadDir)
 1102    ).
 1103
 1104%!  download_url(+URL) is det.
 1105%
 1106%   True if URL looks like a URL we can download from.
 1107
 1108download_url(URL) :-
 1109    atom(URL),
 1110    uri_components(URL, Components),
 1111    uri_data(scheme, Components, Scheme),
 1112    download_scheme(Scheme).
 1113
 1114download_scheme(http).
 1115download_scheme(https) :-
 1116    catch(use_module(library(http/http_ssl_plugin)),
 1117          E, (print_message(warning, E), fail)).
 1118
 1119%!  pack_post_install(+Pack, +PackDir, +Options) is det.
 1120%
 1121%   Process post installation work.  Steps:
 1122%
 1123%     - Create foreign resources
 1124%     - Register directory as autoload library
 1125%     - Attach the package
 1126
 1127pack_post_install(Pack, PackDir, Options) :-
 1128    post_install_foreign(Pack, PackDir, Options),
 1129    post_install_autoload(PackDir, Options),
 1130    '$pack_attach'(PackDir).
 1131
 1132%!  pack_rebuild(+Pack) is det.
 1133%
 1134%   Rebuilt possible foreign components of Pack.
 1135
 1136pack_rebuild(Pack) :-
 1137    current_pack(Pack, PackDir),
 1138    !,
 1139    post_install_foreign(Pack, PackDir, [rebuild(true)]).
 1140pack_rebuild(Pack) :-
 1141    unattached_pacth(Pack, PackDir),
 1142    !,
 1143    post_install_foreign(Pack, PackDir, [rebuild(true)]).
 1144pack_rebuild(Pack) :-
 1145    existence_error(pack, Pack).
 1146
 1147unattached_pacth(Pack, BaseDir) :-
 1148    directory_file_path(Pack, 'pack.pl', PackFile),
 1149    absolute_file_name(pack(PackFile), PackPath,
 1150                       [ access(read),
 1151                         file_errors(fail)
 1152                       ]),
 1153    file_directory_name(PackPath, BaseDir).
 1154
 1155%!  pack_rebuild is det.
 1156%
 1157%   Rebuild foreign components of all packages.
 1158
 1159pack_rebuild :-
 1160    forall(current_pack(Pack),
 1161           ( print_message(informational, pack(rebuild(Pack))),
 1162             pack_rebuild(Pack)
 1163           )).
 1164
 1165
 1166%!  post_install_foreign(+Pack, +PackDir, +Options) is det.
 1167%
 1168%   Install foreign parts of the package.
 1169
 1170post_install_foreign(Pack, PackDir, Options) :-
 1171    is_foreign_pack(PackDir, _),
 1172    !,
 1173    (   pack_info_term(PackDir, pack_version(Version))
 1174    ->  true
 1175    ;   Version = 1
 1176    ),
 1177    option(rebuild(Rebuild), Options, if_absent),
 1178    (   Rebuild == if_absent,
 1179        foreign_present(PackDir)
 1180    ->  print_message(informational, pack(kept_foreign(Pack)))
 1181    ;   BuildSteps0 = [[dependencies], [configure], build, [test], install],
 1182        (   Rebuild == true
 1183        ->  BuildSteps1 = [distclean|BuildSteps0]
 1184        ;   BuildSteps1 = BuildSteps0
 1185        ),
 1186        (   option(test(false), Options)
 1187        ->  delete(BuildSteps1, [test], BuildSteps)
 1188        ;   BuildSteps = BuildSteps1
 1189        ),
 1190        build_steps(BuildSteps, PackDir, [pack_version(Version)|Options])
 1191    ).
 1192post_install_foreign(_, _, _).
 1193
 1194
 1195%!  foreign_present(+PackDir) is semidet.
 1196%
 1197%   True if we find one or more modules  in the pack `lib` directory for
 1198%   the current architecture. Does not check   that these can be loaded,
 1199%   nor whether all required modules are present.
 1200
 1201foreign_present(PackDir) :-
 1202    current_prolog_flag(arch, Arch),
 1203    atomic_list_concat([PackDir, '/lib'], ForeignBaseDir),
 1204    exists_directory(ForeignBaseDir),
 1205    !,
 1206    atomic_list_concat([PackDir, '/lib/', Arch], ForeignDir),
 1207    exists_directory(ForeignDir),
 1208    current_prolog_flag(shared_object_extension, Ext),
 1209    atomic_list_concat([ForeignDir, '/*.', Ext], Pattern),
 1210    expand_file_name(Pattern, Files),
 1211    Files \== [].
 1212
 1213%!  is_foreign_pack(+PackDir, -Type) is nondet.
 1214%
 1215%   True when PackDir contains  files  that   indicate  the  need  for a
 1216%   specific class of build tools indicated by Type.
 1217
 1218is_foreign_pack(PackDir, Type) :-
 1219    foreign_file(File, Type),
 1220    directory_file_path(PackDir, File, Path),
 1221    exists_file(Path).
 1222
 1223foreign_file('CMakeLists.txt', cmake).
 1224foreign_file('configure',      configure).
 1225foreign_file('configure.in',   autoconf).
 1226foreign_file('configure.ac',   autoconf).
 1227foreign_file('Makefile.am',    automake).
 1228foreign_file('Makefile',       make).
 1229foreign_file('makefile',       make).
 1230foreign_file('conanfile.txt',  conan).
 1231foreign_file('conanfile.py',   conan).
 1232
 1233
 1234                 /*******************************
 1235                 *           AUTOLOAD           *
 1236                 *******************************/
 1237
 1238%!  post_install_autoload(+PackDir, +Options)
 1239%
 1240%   Create an autoload index if the package demands such.
 1241
 1242post_install_autoload(PackDir, Options) :-
 1243    option(autoload(true), Options, true),
 1244    pack_info_term(PackDir, autoload(true)),
 1245    !,
 1246    directory_file_path(PackDir, prolog, PrologLibDir),
 1247    make_library_index(PrologLibDir).
 1248post_install_autoload(_, _).
 1249
 1250
 1251                 /*******************************
 1252                 *            UPGRADE           *
 1253                 *******************************/
 1254
 1255%!  pack_upgrade(+Pack) is semidet.
 1256%
 1257%   Try to upgrade the package Pack.
 1258%
 1259%   @tbd    Update dependencies when updating a pack from git?
 1260
 1261pack_upgrade(Pack) :-
 1262    pack_info(Pack, _, directory(Dir)),
 1263    directory_file_path(Dir, '.git', GitDir),
 1264    exists_directory(GitDir),
 1265    !,
 1266    print_message(informational, pack(git_fetch(Dir))),
 1267    git([fetch], [ directory(Dir) ]),
 1268    git_describe(V0, [ directory(Dir) ]),
 1269    git_describe(V1, [ directory(Dir), commit('origin/master') ]),
 1270    (   V0 == V1
 1271    ->  print_message(informational, pack(up_to_date(Pack)))
 1272    ;   confirm(upgrade(Pack, V0, V1), yes, []),
 1273        git([merge, 'origin/master'], [ directory(Dir) ]),
 1274        pack_rebuild(Pack)
 1275    ).
 1276pack_upgrade(Pack) :-
 1277    once(pack_info(Pack, _, version(VersionAtom))),
 1278    atom_version(VersionAtom, Version),
 1279    pack_info(Pack, _, download(URL)),
 1280    (   wildcard_pattern(URL)
 1281    ->  true
 1282    ;   github_url(URL, _User, _Repo)
 1283    ),
 1284    !,
 1285    available_download_versions(URL, [Latest-LatestURL|_Versions]),
 1286    (   Latest @> Version
 1287    ->  confirm(upgrade(Pack, Version, Latest), yes, []),
 1288        pack_install(Pack,
 1289                     [ url(LatestURL),
 1290                       upgrade(true),
 1291                       pack(Pack)
 1292                     ])
 1293    ;   print_message(informational, pack(up_to_date(Pack)))
 1294    ).
 1295pack_upgrade(Pack) :-
 1296    print_message(warning, pack(no_upgrade_info(Pack))).
 1297
 1298
 1299                 /*******************************
 1300                 *            REMOVE            *
 1301                 *******************************/
 1302
 1303%!  pack_remove(+Name) is det.
 1304%
 1305%   Remove the indicated package.
 1306
 1307pack_remove(Pack) :-
 1308    update_dependency_db,
 1309    (   setof(Dep, pack_depends_on(Dep, Pack), Deps)
 1310    ->  confirm_remove(Pack, Deps, Delete),
 1311        forall(member(P, Delete), pack_remove_forced(P))
 1312    ;   pack_remove_forced(Pack)
 1313    ).
 1314
 1315pack_remove_forced(Pack) :-
 1316    catch('$pack_detach'(Pack, BaseDir),
 1317          error(existence_error(pack, Pack), _),
 1318          fail),
 1319    !,
 1320    print_message(informational, pack(remove(BaseDir))),
 1321    delete_directory_and_contents(BaseDir).
 1322pack_remove_forced(Pack) :-
 1323    unattached_pacth(Pack, BaseDir),
 1324    !,
 1325    delete_directory_and_contents(BaseDir).
 1326pack_remove_forced(Pack) :-
 1327    print_message(informational, error(existence_error(pack, Pack),_)).
 1328
 1329confirm_remove(Pack, Deps, Delete) :-
 1330    print_message(warning, pack(depends(Pack, Deps))),
 1331    menu(pack(resolve_remove),
 1332         [ [Pack]      = remove_only(Pack),
 1333           [Pack|Deps] = remove_deps(Pack, Deps),
 1334           []          = cancel
 1335         ], [], Delete, []),
 1336    Delete \== [].
 1337
 1338
 1339                 /*******************************
 1340                 *           PROPERTIES         *
 1341                 *******************************/
 1342
 1343%!  pack_property(?Pack, ?Property) is nondet.
 1344%
 1345%   True when Property  is  a  property   of  an  installed  Pack.  This
 1346%   interface is intended for programs that   wish  to interact with the
 1347%   package manager. Defined properties are:
 1348%
 1349%     - directory(Directory)
 1350%     Directory into which the package is installed
 1351%     - version(Version)
 1352%     Installed version
 1353%     - title(Title)
 1354%     Full title of the package
 1355%     - author(Author)
 1356%     Registered author
 1357%     - download(URL)
 1358%     Official download URL
 1359%     - readme(File)
 1360%     Package README file (if present)
 1361%     - todo(File)
 1362%     Package TODO file (if present)
 1363
 1364pack_property(Pack, Property) :-
 1365    findall(Pack-Property, pack_property_(Pack, Property), List),
 1366    member(Pack-Property, List).            % make det if applicable
 1367
 1368pack_property_(Pack, Property) :-
 1369    pack_info(Pack, _, Property).
 1370pack_property_(Pack, Property) :-
 1371    \+ \+ info_file(Property, _),
 1372    '$pack':pack(Pack, BaseDir),
 1373    access_file(BaseDir, read),
 1374    directory_files(BaseDir, Files),
 1375    member(File, Files),
 1376    info_file(Property, Pattern),
 1377    downcase_atom(File, Pattern),
 1378    directory_file_path(BaseDir, File, InfoFile),
 1379    arg(1, Property, InfoFile).
 1380
 1381info_file(readme(_), 'readme.txt').
 1382info_file(readme(_), 'readme').
 1383info_file(todo(_),   'todo.txt').
 1384info_file(todo(_),   'todo').
 1385
 1386
 1387                 /*******************************
 1388                 *             GIT              *
 1389                 *******************************/
 1390
 1391%!  git_url(+URL, -Pack) is semidet.
 1392%
 1393%   True if URL describes a git url for Pack
 1394
 1395git_url(URL, Pack) :-
 1396    uri_components(URL, Components),
 1397    uri_data(scheme, Components, Scheme),
 1398    nonvar(Scheme),                         % must be full URL
 1399    uri_data(path, Components, Path),
 1400    (   Scheme == git
 1401    ->  true
 1402    ;   git_download_scheme(Scheme),
 1403        file_name_extension(_, git, Path)
 1404    ;   git_download_scheme(Scheme),
 1405        catch(git_ls_remote(URL, _, [refs(['HEAD']), error(_)]), _, fail)
 1406    ->  true
 1407    ),
 1408    file_base_name(Path, PackExt),
 1409    (   file_name_extension(Pack, git, PackExt)
 1410    ->  true
 1411    ;   Pack = PackExt
 1412    ),
 1413    (   safe_pack_name(Pack)
 1414    ->  true
 1415    ;   domain_error(pack_name, Pack)
 1416    ).
 1417
 1418git_download_scheme(http).
 1419git_download_scheme(https).
 1420
 1421%!  safe_pack_name(+Name:atom) is semidet.
 1422%
 1423%   Verifies that Name is a valid   pack  name. This avoids trickery
 1424%   with pack file names to make shell commands behave unexpectly.
 1425
 1426safe_pack_name(Name) :-
 1427    atom_length(Name, Len),
 1428    Len >= 3,                               % demand at least three length
 1429    atom_codes(Name, Codes),
 1430    maplist(safe_pack_char, Codes),
 1431    !.
 1432
 1433safe_pack_char(C) :- between(0'a, 0'z, C), !.
 1434safe_pack_char(C) :- between(0'A, 0'Z, C), !.
 1435safe_pack_char(C) :- between(0'0, 0'9, C), !.
 1436safe_pack_char(0'_).
 1437
 1438
 1439                 /*******************************
 1440                 *         VERSION LOGIC        *
 1441                 *******************************/
 1442
 1443%!  pack_version_file(-Pack, -Version, +File) is semidet.
 1444%
 1445%   True if File is the  name  of  a   file  or  URL  of a file that
 1446%   contains Pack at Version. File must   have  an extension and the
 1447%   basename  must  be  of   the    form   <pack>-<n>{.<m>}*.  E.g.,
 1448%   =|mypack-1.5|=.
 1449
 1450pack_version_file(Pack, Version, GitHubRelease) :-
 1451    atomic(GitHubRelease),
 1452    github_release_url(GitHubRelease, Pack, Version),
 1453    !.
 1454pack_version_file(Pack, Version, Path) :-
 1455    atomic(Path),
 1456    file_base_name(Path, File),
 1457    no_int_file_name_extension(Base, _Ext, File),
 1458    atom_codes(Base, Codes),
 1459    (   phrase(pack_version(Pack, Version), Codes),
 1460        safe_pack_name(Pack)
 1461    ->  true
 1462    ).
 1463
 1464no_int_file_name_extension(Base, Ext, File) :-
 1465    file_name_extension(Base0, Ext0, File),
 1466    \+ atom_number(Ext0, _),
 1467    !,
 1468    Base = Base0,
 1469    Ext = Ext0.
 1470no_int_file_name_extension(File, '', File).
 1471
 1472
 1473
 1474%!  github_release_url(+URL, -Pack, -Version) is semidet.
 1475%
 1476%   True when URL is the URL of a GitHub release.  Such releases are
 1477%   accessible as
 1478%
 1479%     ==
 1480%     https:/github.com/<owner>/<pack>/archive/[vV]?<version>.zip'
 1481%     ==
 1482
 1483github_release_url(URL, Pack, Version) :-
 1484    uri_components(URL, Components),
 1485    uri_data(authority, Components, 'github.com'),
 1486    uri_data(scheme, Components, Scheme),
 1487    download_scheme(Scheme),
 1488    uri_data(path, Components, Path),
 1489    github_archive_path(Archive,Pack,File),
 1490    atomic_list_concat(Archive, /, Path),
 1491    file_name_extension(Tag, Ext, File),
 1492    github_archive_extension(Ext),
 1493    tag_version(Tag, Version),
 1494    !.
 1495
 1496github_archive_path(['',_User,Pack,archive,File],Pack,File).
 1497github_archive_path(['',_User,Pack,archive,refs,tags,File],Pack,File).
 1498
 1499github_archive_extension(tgz).
 1500github_archive_extension(zip).
 1501
 1502tag_version(Tag, Version) :-
 1503    version_tag_prefix(Prefix),
 1504    atom_concat(Prefix, AtomVersion, Tag),
 1505    atom_version(AtomVersion, Version).
 1506
 1507version_tag_prefix(v).
 1508version_tag_prefix('V').
 1509version_tag_prefix('').
 1510
 1511
 1512:- public
 1513    atom_version/2. 1514
 1515%!  atom_version(?Atom, ?Version)
 1516%
 1517%   Translate   between   atomic   version   representation   and   term
 1518%   representation.  The  term  representation  is  a  list  of  version
 1519%   components as integers and can be compared using `@>`
 1520
 1521atom_version(Atom, version(Parts)) :-
 1522    (   atom(Atom)
 1523    ->  atom_codes(Atom, Codes),
 1524        phrase(version(Parts), Codes)
 1525    ;   atomic_list_concat(Parts, '.', Atom)
 1526    ).
 1527
 1528pack_version(Pack, version(Parts)) -->
 1529    string(Codes), "-",
 1530    version(Parts),
 1531    !,
 1532    { atom_codes(Pack, Codes)
 1533    }.
 1534
 1535version([_|T]) -->
 1536    "*",
 1537    !,
 1538    (   "."
 1539    ->  version(T)
 1540    ;   []
 1541    ).
 1542version([H|T]) -->
 1543    integer(H),
 1544    (   "."
 1545    ->  version(T)
 1546    ;   { T = [] }
 1547    ).
 1548
 1549                 /*******************************
 1550                 *       QUERY CENTRAL DB       *
 1551                 *******************************/
 1552
 1553%!  pack_inquiry(+URL, +DownloadFile, +Info, +Options) is semidet.
 1554%
 1555%   Query the status of a package  with   the  central repository. To do
 1556%   this, we POST a Prolog document  containing   the  URL, info and the
 1557%   SHA1 hash to http://www.swi-prolog.org/pack/eval. The server replies
 1558%   using a list of Prolog terms, described  below. The only member that
 1559%   is always included is downloads (with default value 0).
 1560%
 1561%     - alt_hash(Count, URLs, Hash)
 1562%       A file with the same base-name, but a different hash was
 1563%       found at URLs and downloaded Count times.
 1564%     - downloads(Count)
 1565%       Number of times a file with this hash was downloaded.
 1566%     - rating(VoteCount, Rating)
 1567%       User rating (1..5), provided based on VoteCount votes.
 1568%     - dependency(Token, Pack, Version, URLs, SubDeps)
 1569%       Required tokens can be provided by the given provides.
 1570
 1571pack_inquiry(_, _, _, Options) :-
 1572    option(inquiry(false), Options),
 1573    !.
 1574pack_inquiry(URL, DownloadFile, Info, Options) :-
 1575    setting(server, ServerBase),
 1576    ServerBase \== '',
 1577    atom_concat(ServerBase, query, Server),
 1578    (   option(inquiry(true), Options)
 1579    ->  true
 1580    ;   confirm(inquiry(Server), yes, Options)
 1581    ),
 1582    !,
 1583    (   DownloadFile = git(SHA1)
 1584    ->  true
 1585    ;   file_sha1(DownloadFile, SHA1)
 1586    ),
 1587    query_pack_server(install(URL, SHA1, Info), Reply, Options),
 1588    inquiry_result(Reply, URL, Options).
 1589pack_inquiry(_, _, _, _).
 1590
 1591
 1592%!  query_pack_server(+Query, -Result, +Options)
 1593%
 1594%   Send a Prolog query  to  the   package  server  and  process its
 1595%   results.
 1596
 1597query_pack_server(Query, Result, Options) :-
 1598    setting(server, ServerBase),
 1599    ServerBase \== '',
 1600    atom_concat(ServerBase, query, Server),
 1601    format(codes(Data), '~q.~n', Query),
 1602    info_level(Informational, Options),
 1603    print_message(Informational, pack(contacting_server(Server))),
 1604    setup_call_cleanup(
 1605        http_open(Server, In,
 1606                  [ post(codes(application/'x-prolog', Data)),
 1607                    header(content_type, ContentType)
 1608                  ]),
 1609        read_reply(ContentType, In, Result),
 1610        close(In)),
 1611    message_severity(Result, Level, Informational),
 1612    print_message(Level, pack(server_reply(Result))).
 1613
 1614read_reply(ContentType, In, Result) :-
 1615    sub_atom(ContentType, 0, _, _, 'application/x-prolog'),
 1616    !,
 1617    set_stream(In, encoding(utf8)),
 1618    read(In, Result).
 1619read_reply(ContentType, In, _Result) :-
 1620    read_string(In, 500, String),
 1621    print_message(error, pack(no_prolog_response(ContentType, String))),
 1622    fail.
 1623
 1624info_level(Level, Options) :-
 1625    option(silent(true), Options),
 1626    !,
 1627    Level = silent.
 1628info_level(informational, _).
 1629
 1630message_severity(true(_), Informational, Informational).
 1631message_severity(false, warning, _).
 1632message_severity(exception(_), error, _).
 1633
 1634
 1635%!  inquiry_result(+Reply, +File, +Options) is semidet.
 1636%
 1637%   Analyse the results  of  the  inquiry   and  decide  whether  to
 1638%   continue or not.
 1639
 1640inquiry_result(Reply, File, Options) :-
 1641    findall(Eval, eval_inquiry(Reply, File, Eval, Options), Evaluation),
 1642    \+ member(cancel, Evaluation),
 1643    select_option(git(_), Options, Options1, _),
 1644    forall(member(install_dependencies(Resolution), Evaluation),
 1645           maplist(install_dependency(Options1), Resolution)).
 1646
 1647eval_inquiry(true(Reply), URL, Eval, _) :-
 1648    include(alt_hash, Reply, Alts),
 1649    Alts \== [],
 1650    print_message(warning, pack(alt_hashes(URL, Alts))),
 1651    (   memberchk(downloads(Count), Reply),
 1652        (   git_url(URL, _)
 1653        ->  Default = yes,
 1654            Eval = with_git_commits_in_same_version
 1655        ;   Default = no,
 1656            Eval = with_alt_hashes
 1657        ),
 1658        confirm(continue_with_alt_hashes(Count, URL), Default, [])
 1659    ->  true
 1660    ;   !,                          % Stop other rules
 1661        Eval = cancel
 1662    ).
 1663eval_inquiry(true(Reply), _, Eval, Options) :-
 1664    include(dependency, Reply, Deps),
 1665    Deps \== [],
 1666    select_dependency_resolution(Deps, Eval, Options),
 1667    (   Eval == cancel
 1668    ->  !
 1669    ;   true
 1670    ).
 1671eval_inquiry(true(Reply), URL, true, Options) :-
 1672    file_base_name(URL, File),
 1673    info_level(Informational, Options),
 1674    print_message(Informational, pack(inquiry_ok(Reply, File))).
 1675eval_inquiry(exception(pack(modified_hash(_SHA1-URL, _SHA2-[URL]))),
 1676             URL, Eval, Options) :-
 1677    (   confirm(continue_with_modified_hash(URL), no, Options)
 1678    ->  Eval = true
 1679    ;   Eval = cancel
 1680    ).
 1681
 1682alt_hash(alt_hash(_,_,_)).
 1683dependency(dependency(_,_,_,_,_)).
 1684
 1685
 1686%!  select_dependency_resolution(+Deps, -Eval, +Options)
 1687%
 1688%   Select a resolution.
 1689%
 1690%   @tbd    Exploit backtracking over resolve_dependencies/2.
 1691
 1692select_dependency_resolution(Deps, Eval, Options) :-
 1693    resolve_dependencies(Deps, Resolution),
 1694    exclude(local_dep, Resolution, ToBeDone),
 1695    (   ToBeDone == []
 1696    ->  !, Eval = true
 1697    ;   print_message(warning, pack(install_dependencies(Resolution))),
 1698        (   memberchk(_-unresolved, Resolution)
 1699        ->  Default = cancel
 1700        ;   Default = install_deps
 1701        ),
 1702        menu(pack(resolve_deps),
 1703             [ install_deps    = install_deps,
 1704               install_no_deps = install_no_deps,
 1705               cancel          = cancel
 1706             ], Default, Choice, Options),
 1707        (   Choice == cancel
 1708        ->  !, Eval = cancel
 1709        ;   Choice == install_no_deps
 1710        ->  !, Eval = install_no_deps
 1711        ;   !, Eval = install_dependencies(Resolution)
 1712        )
 1713    ).
 1714
 1715local_dep(_-resolved(_)).
 1716
 1717
 1718%!  install_dependency(+Options, +TokenResolution)
 1719%
 1720%   Install dependencies for the given resolution.
 1721%
 1722%   @tbd: Query URI to use
 1723
 1724install_dependency(Options,
 1725                   _Token-resolve(Pack, VersionAtom, [_URL|_], SubResolve)) :-
 1726    atom_version(VersionAtom, Version),
 1727    current_pack(Pack),
 1728    pack_info(Pack, _, version(InstalledAtom)),
 1729    atom_version(InstalledAtom, Installed),
 1730    Installed == Version,               % already installed
 1731    !,
 1732    maplist(install_dependency(Options), SubResolve).
 1733install_dependency(Options,
 1734                   _Token-resolve(Pack, VersionAtom, [URL|_], SubResolve)) :-
 1735    !,
 1736    atom_version(VersionAtom, Version),
 1737    merge_options([ url(URL),
 1738                    version(Version),
 1739                    interactive(false),
 1740                    inquiry(false),
 1741                    info(list),
 1742                    pack(Pack)
 1743                  ], Options, InstallOptions),
 1744    pack_install(Pack, InstallOptions),
 1745    maplist(install_dependency(Options), SubResolve).
 1746install_dependency(_, _-_).
 1747
 1748
 1749                 /*******************************
 1750                 *        WILDCARD URIs         *
 1751                 *******************************/
 1752
 1753%!  available_download_versions(+URL, -Versions) is det.
 1754%
 1755%   Deal with wildcard URLs, returning a  list of Version-URL pairs,
 1756%   sorted by version.
 1757%
 1758%   @tbd    Deal with protocols other than HTTP
 1759
 1760available_download_versions(URL, Versions) :-
 1761    wildcard_pattern(URL),
 1762    github_url(URL, User, Repo),
 1763    !,
 1764    findall(Version-VersionURL,
 1765            github_version(User, Repo, Version, VersionURL),
 1766            Versions).
 1767available_download_versions(URL, Versions) :-
 1768    wildcard_pattern(URL),
 1769    !,
 1770    file_directory_name(URL, DirURL0),
 1771    ensure_slash(DirURL0, DirURL),
 1772    print_message(informational, pack(query_versions(DirURL))),
 1773    setup_call_cleanup(
 1774        http_open(DirURL, In, []),
 1775        load_html(stream(In), DOM,
 1776                  [ syntax_errors(quiet)
 1777                  ]),
 1778        close(In)),
 1779    findall(MatchingURL,
 1780            absolute_matching_href(DOM, URL, MatchingURL),
 1781            MatchingURLs),
 1782    (   MatchingURLs == []
 1783    ->  print_message(warning, pack(no_matching_urls(URL)))
 1784    ;   true
 1785    ),
 1786    versioned_urls(MatchingURLs, VersionedURLs),
 1787    keysort(VersionedURLs, SortedVersions),
 1788    reverse(SortedVersions, Versions),
 1789    print_message(informational, pack(found_versions(Versions))).
 1790available_download_versions(URL, [Version-URL]) :-
 1791    (   pack_version_file(_Pack, Version0, URL)
 1792    ->  Version = Version0
 1793    ;   Version = unknown
 1794    ).
 1795
 1796%!  github_url(+URL, -User, -Repo) is semidet.
 1797%
 1798%   True when URL refers to a github repository.
 1799
 1800github_url(URL, User, Repo) :-
 1801    uri_components(URL, uri_components(https,'github.com',Path,_,_)),
 1802    atomic_list_concat(['',User,Repo|_], /, Path).
 1803
 1804
 1805%!  github_version(+User, +Repo, -Version, -VersionURI) is nondet.
 1806%
 1807%   True when Version is a release version and VersionURI is the
 1808%   download location for the zip file.
 1809
 1810github_version(User, Repo, Version, VersionURI) :-
 1811    atomic_list_concat(['',repos,User,Repo,tags], /, Path1),
 1812    uri_components(ApiUri, uri_components(https,'api.github.com',Path1,_,_)),
 1813    setup_call_cleanup(
 1814      http_open(ApiUri, In,
 1815                [ request_header('Accept'='application/vnd.github.v3+json')
 1816                ]),
 1817      json_read_dict(In, Dicts),
 1818      close(In)),
 1819    member(Dict, Dicts),
 1820    atom_string(Tag, Dict.name),
 1821    tag_version(Tag, Version),
 1822    atom_string(VersionURI, Dict.zipball_url).
 1823
 1824wildcard_pattern(URL) :- sub_atom(URL, _, _, _, *).
 1825wildcard_pattern(URL) :- sub_atom(URL, _, _, _, ?).
 1826
 1827ensure_slash(Dir, DirS) :-
 1828    (   sub_atom(Dir, _, _, 0, /)
 1829    ->  DirS = Dir
 1830    ;   atom_concat(Dir, /, DirS)
 1831    ).
 1832
 1833absolute_matching_href(DOM, Pattern, Match) :-
 1834    xpath(DOM, //a(@href), HREF),
 1835    uri_normalized(HREF, Pattern, Match),
 1836    wildcard_match(Pattern, Match).
 1837
 1838versioned_urls([], []).
 1839versioned_urls([H|T0], List) :-
 1840    file_base_name(H, File),
 1841    (   pack_version_file(_Pack, Version, File)
 1842    ->  List = [Version-H|T]
 1843    ;   List = T
 1844    ),
 1845    versioned_urls(T0, T).
 1846
 1847
 1848                 /*******************************
 1849                 *          DEPENDENCIES        *
 1850                 *******************************/
 1851
 1852%!  update_dependency_db
 1853%
 1854%   Reload dependency declarations between packages.
 1855
 1856update_dependency_db :-
 1857    retractall(pack_requires(_,_)),
 1858    retractall(pack_provides_db(_,_)),
 1859    forall(current_pack(Pack),
 1860           (   findall(Info, pack_info(Pack, dependency, Info), Infos),
 1861               update_dependency_db(Pack, Infos)
 1862           )).
 1863
 1864update_dependency_db(Name, Info) :-
 1865    retractall(pack_requires(Name, _)),
 1866    retractall(pack_provides_db(Name, _)),
 1867    maplist(assert_dep(Name), Info).
 1868
 1869assert_dep(Pack, provides(Token)) :-
 1870    !,
 1871    assertz(pack_provides_db(Pack, Token)).
 1872assert_dep(Pack, requires(Token)) :-
 1873    !,
 1874    assertz(pack_requires(Pack, Token)).
 1875assert_dep(_, _).
 1876
 1877%!  validate_dependencies is det.
 1878%
 1879%   Validate all dependencies, reporting on failures
 1880
 1881validate_dependencies :-
 1882    unsatisfied_dependencies(Unsatisfied),
 1883    !,
 1884    print_message(warning, pack(unsatisfied(Unsatisfied))).
 1885validate_dependencies.
 1886
 1887
 1888unsatisfied_dependencies(Unsatisfied) :-
 1889    findall(Req-Pack, pack_requires(Pack, Req), Reqs0),
 1890    keysort(Reqs0, Reqs1),
 1891    group_pairs_by_key(Reqs1, GroupedReqs),
 1892    exclude(satisfied_dependency, GroupedReqs, Unsatisfied),
 1893    Unsatisfied \== [].
 1894
 1895satisfied_dependency(Needed-_By) :-
 1896    pack_provides(_, Needed),
 1897    !.
 1898satisfied_dependency(Needed-_By) :-
 1899    compound(Needed),
 1900    Needed =.. [Op, Pack, ReqVersion],
 1901    (   pack_provides(Pack, Pack)
 1902    ->  pack_info(Pack, _, version(PackVersion)),
 1903        version_data(PackVersion, PackData)
 1904    ;   Pack == prolog
 1905    ->  current_prolog_flag(version_data, swi(Major,Minor,Patch,_)),
 1906        PackData = [Major,Minor,Patch]
 1907    ),
 1908    version_data(ReqVersion, ReqData),
 1909    cmp(Op, Cmp),
 1910    call(Cmp, PackData, ReqData).
 1911
 1912%!  pack_provides(?Package, ?Token) is multi.
 1913%
 1914%   True if Pack provides Token.  A package always provides itself.
 1915
 1916pack_provides(Pack, Pack) :-
 1917    current_pack(Pack).
 1918pack_provides(Pack, Token) :-
 1919    pack_provides_db(Pack, Token).
 1920
 1921%!  pack_depends_on(?Pack, ?Dependency) is nondet.
 1922%
 1923%   True if Pack requires Dependency, direct or indirect.
 1924
 1925pack_depends_on(Pack, Dependency) :-
 1926    (   atom(Pack)
 1927    ->  pack_depends_on_fwd(Pack, Dependency, [Pack])
 1928    ;   pack_depends_on_bwd(Pack, Dependency, [Dependency])
 1929    ).
 1930
 1931pack_depends_on_fwd(Pack, Dependency, Visited) :-
 1932    pack_depends_on_1(Pack, Dep1),
 1933    \+ memberchk(Dep1, Visited),
 1934    (   Dependency = Dep1
 1935    ;   pack_depends_on_fwd(Dep1, Dependency, [Dep1|Visited])
 1936    ).
 1937
 1938pack_depends_on_bwd(Pack, Dependency, Visited) :-
 1939    pack_depends_on_1(Dep1, Dependency),
 1940    \+ memberchk(Dep1, Visited),
 1941    (   Pack = Dep1
 1942    ;   pack_depends_on_bwd(Pack, Dep1, [Dep1|Visited])
 1943    ).
 1944
 1945pack_depends_on_1(Pack, Dependency) :-
 1946    atom(Dependency),
 1947    !,
 1948    pack_provides(Dependency, Token),
 1949    pack_requires(Pack, Token).
 1950pack_depends_on_1(Pack, Dependency) :-
 1951    pack_requires(Pack, Token),
 1952    pack_provides(Dependency, Token).
 1953
 1954
 1955%!  resolve_dependencies(+Dependencies, -Resolution) is multi.
 1956%
 1957%   Resolve dependencies as reported by the remote package server.
 1958%
 1959%   @param  Dependencies is a list of
 1960%           dependency(Token, Pack, Version, URLs, SubDeps)
 1961%   @param  Resolution is a list of items
 1962%           - Token-resolved(Pack)
 1963%           - Token-resolve(Pack, Version, URLs, SubResolve)
 1964%           - Token-unresolved
 1965%   @tbd    Watch out for conflicts
 1966%   @tbd    If there are different packs that resolve a token,
 1967%           make an intelligent choice instead of using the first
 1968
 1969resolve_dependencies(Dependencies, Resolution) :-
 1970    maplist(dependency_pair, Dependencies, Pairs0),
 1971    keysort(Pairs0, Pairs1),
 1972    group_pairs_by_key(Pairs1, ByToken),
 1973    maplist(resolve_dep, ByToken, Resolution).
 1974
 1975dependency_pair(dependency(Token, Pack, Version, URLs, SubDeps),
 1976                Token-(Pack-pack(Version,URLs, SubDeps))).
 1977
 1978resolve_dep(Token-Pairs, Token-Resolution) :-
 1979    (   resolve_dep2(Token-Pairs, Resolution)
 1980    *-> true
 1981    ;   Resolution = unresolved
 1982    ).
 1983
 1984resolve_dep2(Token-_, resolved(Pack)) :-
 1985    pack_provides(Pack, Token).
 1986resolve_dep2(_-Pairs, resolve(Pack, VersionAtom, URLs, SubResolves)) :-
 1987    keysort(Pairs, Sorted),
 1988    group_pairs_by_key(Sorted, ByPack),
 1989    member(Pack-Versions, ByPack),
 1990    Pack \== (-),
 1991    maplist(version_pack, Versions, VersionData),
 1992    sort(VersionData, ByVersion),
 1993    reverse(ByVersion, ByVersionLatest),
 1994    member(pack(Version,URLs,SubDeps), ByVersionLatest),
 1995    atom_version(VersionAtom, Version),
 1996    include(dependency, SubDeps, Deps),
 1997    resolve_dependencies(Deps, SubResolves).
 1998
 1999version_pack(pack(VersionAtom,URLs,SubDeps),
 2000             pack(Version,URLs,SubDeps)) :-
 2001    atom_version(VersionAtom, Version).
 2002
 2003
 2004
 2005%!  pack_attach(+Dir, +Options) is det.
 2006%
 2007%   Attach a single package in Dir.  The Dir is expected to contain
 2008%   the file `pack.pl` and a `prolog` directory.  Options processed:
 2009%
 2010%     - duplicate(+Action)
 2011%     What to do if the same package is already installed in a different
 2012%     directory.  Action is one of
 2013%       - warning
 2014%       Warn and ignore the package
 2015%       - keep
 2016%       Silently ignore the package
 2017%       - replace
 2018%       Unregister the existing and insert the new package
 2019%     - search(+Where)
 2020%     Determines the order of searching package library directories.
 2021%     Default is `last`, alternative is `first`.
 2022%
 2023%   @see attach_packs/2 to attach multiple packs from a directory.
 2024
 2025pack_attach(Dir, Options) :-
 2026    '$pack_attach'(Dir, Options).
 2027
 2028
 2029                 /*******************************
 2030                 *        USER INTERACTION      *
 2031                 *******************************/
 2032
 2033:- multifile prolog:message//1. 2034
 2035%!  menu(Question, +Alternatives, +Default, -Selection, +Options)
 2036
 2037menu(_Question, _Alternatives, Default, Selection, Options) :-
 2038    option(interactive(false), Options),
 2039    !,
 2040    Selection = Default.
 2041menu(Question, Alternatives, Default, Selection, _) :-
 2042    length(Alternatives, N),
 2043    between(1, 5, _),
 2044       print_message(query, Question),
 2045       print_menu(Alternatives, Default, 1),
 2046       print_message(query, pack(menu(select))),
 2047       read_selection(N, Choice),
 2048    !,
 2049    (   Choice == default
 2050    ->  Selection = Default
 2051    ;   nth1(Choice, Alternatives, Selection=_)
 2052    ->  true
 2053    ).
 2054
 2055print_menu([], _, _).
 2056print_menu([Value=Label|T], Default, I) :-
 2057    (   Value == Default
 2058    ->  print_message(query, pack(menu(default_item(I, Label))))
 2059    ;   print_message(query, pack(menu(item(I, Label))))
 2060    ),
 2061    I2 is I + 1,
 2062    print_menu(T, Default, I2).
 2063
 2064read_selection(Max, Choice) :-
 2065    get_single_char(Code),
 2066    (   answered_default(Code)
 2067    ->  Choice = default
 2068    ;   code_type(Code, digit(Choice)),
 2069        between(1, Max, Choice)
 2070    ->  true
 2071    ;   print_message(warning, pack(menu(reply(1,Max)))),
 2072        fail
 2073    ).
 2074
 2075%!  confirm(+Question, +Default, +Options) is semidet.
 2076%
 2077%   Ask for confirmation.
 2078%
 2079%   @param Default is one of =yes=, =no= or =none=.
 2080
 2081confirm(_Question, Default, Options) :-
 2082    Default \== none,
 2083    option(interactive(false), Options, true),
 2084    !,
 2085    Default == yes.
 2086confirm(Question, Default, _) :-
 2087    between(1, 5, _),
 2088       print_message(query, pack(confirm(Question, Default))),
 2089       read_yes_no(YesNo, Default),
 2090    !,
 2091    format(user_error, '~N', []),
 2092    YesNo == yes.
 2093
 2094read_yes_no(YesNo, Default) :-
 2095    get_single_char(Code),
 2096    code_yes_no(Code, Default, YesNo),
 2097    !.
 2098
 2099code_yes_no(0'y, _, yes).
 2100code_yes_no(0'Y, _, yes).
 2101code_yes_no(0'n, _, no).
 2102code_yes_no(0'N, _, no).
 2103code_yes_no(_, none, _) :- !, fail.
 2104code_yes_no(C, Default, Default) :-
 2105    answered_default(C).
 2106
 2107answered_default(0'\r).
 2108answered_default(0'\n).
 2109answered_default(0'\s).
 2110
 2111
 2112                 /*******************************
 2113                 *            MESSAGES          *
 2114                 *******************************/
 2115
 2116:- multifile prolog:message//1. 2117
 2118prolog:message(pack(Message)) -->
 2119    message(Message).
 2120
 2121:- discontiguous
 2122    message//1,
 2123    label//1. 2124
 2125message(invalid_info(Term)) -->
 2126    [ 'Invalid package description: ~q'-[Term] ].
 2127message(directory_exists(Dir)) -->
 2128    [ 'Package target directory exists and is not empty:', nl,
 2129      '\t~q'-[Dir]
 2130    ].
 2131message(already_installed(pack(Pack, Version))) -->
 2132    { atom_version(AVersion, Version) },
 2133    [ 'Pack `~w'' is already installed @~w'-[Pack, AVersion] ].
 2134message(already_installed(Pack)) -->
 2135    [ 'Pack `~w'' is already installed. Package info:'-[Pack] ].
 2136message(invalid_name(File)) -->
 2137    [ '~w: A package archive must be named <pack>-<version>.<ext>'-[File] ],
 2138    no_tar_gz(File).
 2139
 2140no_tar_gz(File) -->
 2141    { sub_atom(File, _, _, 0, '.tar.gz') },
 2142    !,
 2143    [ nl,
 2144      'Package archive files must have a single extension.  E.g., \'.tgz\''-[]
 2145    ].
 2146no_tar_gz(_) --> [].
 2147
 2148message(kept_foreign(Pack)) -->
 2149    [ 'Found foreign libraries for target platform.'-[], nl,
 2150      'Use ?- pack_rebuild(~q). to rebuild from sources'-[Pack]
 2151    ].
 2152message(no_pack_installed(Pack)) -->
 2153    [ 'No pack ~q installed.  Use ?- pack_list(Pattern) to search'-[Pack] ].
 2154message(no_packages_installed) -->
 2155    { setting(server, ServerBase) },
 2156    [ 'There are no extra packages installed.', nl,
 2157      'Please visit ~wlist.'-[ServerBase]
 2158    ].
 2159message(remove_with(Pack)) -->
 2160    [ 'The package can be removed using: ?- ~q.'-[pack_remove(Pack)]
 2161    ].
 2162message(unsatisfied(Packs)) -->
 2163    [ 'The following dependencies are not satisfied:', nl ],
 2164    unsatisfied(Packs).
 2165message(depends(Pack, Deps)) -->
 2166    [ 'The following packages depend on `~w\':'-[Pack], nl ],
 2167    pack_list(Deps).
 2168message(remove(PackDir)) -->
 2169    [ 'Removing ~q and contents'-[PackDir] ].
 2170message(remove_existing_pack(PackDir)) -->
 2171    [ 'Remove old installation in ~q'-[PackDir] ].
 2172message(install_from(Pack, Version, git(URL))) -->
 2173    [ 'Install ~w@~w from GIT at ~w'-[Pack, Version, URL] ].
 2174message(install_from(Pack, Version, URL)) -->
 2175    [ 'Install ~w@~w from ~w'-[Pack, Version, URL] ].
 2176message(select_install_from(Pack, Version)) -->
 2177    [ 'Select download location for ~w@~w'-[Pack, Version] ].
 2178message(install_downloaded(File)) -->
 2179    { file_base_name(File, Base),
 2180      size_file(File, Size) },
 2181    [ 'Install "~w" (~D bytes)'-[Base, Size] ].
 2182message(git_post_install(PackDir, Pack)) -->
 2183    (   { is_foreign_pack(PackDir, _) }
 2184    ->  [ 'Run post installation scripts for pack "~w"'-[Pack] ]
 2185    ;   [ 'Activate pack "~w"'-[Pack] ]
 2186    ).
 2187message(no_meta_data(BaseDir)) -->
 2188    [ 'Cannot find pack.pl inside directory ~q.  Not a package?'-[BaseDir] ].
 2189message(inquiry(Server)) -->
 2190    [ 'Verify package status (anonymously)', nl,
 2191      '\tat "~w"'-[Server]
 2192    ].
 2193message(search_no_matches(Name)) -->
 2194    [ 'Search for "~w", returned no matching packages'-[Name] ].
 2195message(rebuild(Pack)) -->
 2196    [ 'Checking pack "~w" for rebuild ...'-[Pack] ].
 2197message(upgrade(Pack, From, To)) -->
 2198    [ 'Upgrade "~w" from '-[Pack] ],
 2199    msg_version(From), [' to '-[]], msg_version(To).
 2200message(up_to_date(Pack)) -->
 2201    [ 'Package "~w" is up-to-date'-[Pack] ].
 2202message(query_versions(URL)) -->
 2203    [ 'Querying "~w" to find new versions ...'-[URL] ].
 2204message(no_matching_urls(URL)) -->
 2205    [ 'Could not find any matching URL: ~q'-[URL] ].
 2206message(found_versions([Latest-_URL|More])) -->
 2207    { length(More, Len),
 2208      atom_version(VLatest, Latest)
 2209    },
 2210    [ '    Latest version: ~w (~D older)'-[VLatest, Len] ].
 2211message(process_output(Codes)) -->
 2212    { split_lines(Codes, Lines) },
 2213    process_lines(Lines).
 2214message(contacting_server(Server)) -->
 2215    [ 'Contacting server at ~w ...'-[Server], flush ].
 2216message(server_reply(true(_))) -->
 2217    [ at_same_line, ' ok'-[] ].
 2218message(server_reply(false)) -->
 2219    [ at_same_line, ' done'-[] ].
 2220message(server_reply(exception(E))) -->
 2221    [ 'Server reported the following error:'-[], nl ],
 2222    '$messages':translate_message(E).
 2223message(cannot_create_dir(Alias)) -->
 2224    { findall(PackDir,
 2225              absolute_file_name(Alias, PackDir, [solutions(all)]),
 2226              PackDirs0),
 2227      sort(PackDirs0, PackDirs)
 2228    },
 2229    [ 'Cannot find a place to create a package directory.'-[],
 2230      'Considered:'-[]
 2231    ],
 2232    candidate_dirs(PackDirs).
 2233message(no_match(Name)) -->
 2234    [ 'No registered pack matches "~w"'-[Name] ].
 2235message(conflict(version, [PackV, FileV])) -->
 2236    ['Version mismatch: pack.pl: '-[]], msg_version(PackV),
 2237    [', file claims version '-[]], msg_version(FileV).
 2238message(conflict(name, [PackInfo, FileInfo])) -->
 2239    ['Pack ~w mismatch: pack.pl: ~p'-[PackInfo]],
 2240    [', file claims ~w: ~p'-[FileInfo]].
 2241message(no_prolog_response(ContentType, String)) -->
 2242    [ 'Expected Prolog response.  Got content of type ~p'-[ContentType], nl,
 2243      '~s'-[String]
 2244    ].
 2245message(pack(no_upgrade_info(Pack))) -->
 2246    [ '~w: pack meta-data does not provide an upgradable URL'-[Pack] ].
 2247
 2248candidate_dirs([]) --> [].
 2249candidate_dirs([H|T]) --> [ nl, '    ~w'-[H] ], candidate_dirs(T).
 2250
 2251                                                % Questions
 2252message(resolve_remove) -->
 2253    [ nl, 'Please select an action:', nl, nl ].
 2254message(create_pack_dir) -->
 2255    [ nl, 'Create directory for packages', nl ].
 2256message(menu(item(I, Label))) -->
 2257    [ '~t(~d)~6|   '-[I] ],
 2258    label(Label).
 2259message(menu(default_item(I, Label))) -->
 2260    [ '~t(~d)~6| * '-[I] ],
 2261    label(Label).
 2262message(menu(select)) -->
 2263    [ nl, 'Your choice? ', flush ].
 2264message(confirm(Question, Default)) -->
 2265    message(Question),
 2266    confirm_default(Default),
 2267    [ flush ].
 2268message(menu(reply(Min,Max))) -->
 2269    (  { Max =:= Min+1 }
 2270    -> [ 'Please enter ~w or ~w'-[Min,Max] ]
 2271    ;  [ 'Please enter a number between ~w and ~w'-[Min,Max] ]
 2272    ).
 2273
 2274% Alternate hashes for found for the same file
 2275
 2276message(alt_hashes(URL, _Alts)) -->
 2277    { git_url(URL, _)
 2278    },
 2279    !,
 2280    [ 'GIT repository was updated without updating version' ].
 2281message(alt_hashes(URL, Alts)) -->
 2282    { file_base_name(URL, File)
 2283    },
 2284    [ 'Found multiple versions of "~w".'-[File], nl,
 2285      'This could indicate a compromised or corrupted file', nl
 2286    ],
 2287    alt_hashes(Alts).
 2288message(continue_with_alt_hashes(Count, URL)) -->
 2289    [ 'Continue installation from "~w" (downloaded ~D times)'-[URL, Count] ].
 2290message(continue_with_modified_hash(_URL)) -->
 2291    [ 'Pack may be compromised.  Continue anyway'
 2292    ].
 2293message(modified_hash(_SHA1-URL, _SHA2-[URL])) -->
 2294    [ 'Content of ~q has changed.'-[URL]
 2295    ].
 2296
 2297alt_hashes([]) --> [].
 2298alt_hashes([H|T]) --> alt_hash(H), ( {T == []} -> [] ; [nl], alt_hashes(T) ).
 2299
 2300alt_hash(alt_hash(Count, URLs, Hash)) -->
 2301    [ '~t~d~8| ~w'-[Count, Hash] ],
 2302    alt_urls(URLs).
 2303
 2304alt_urls([]) --> [].
 2305alt_urls([H|T]) -->
 2306    [ nl, '    ~w'-[H] ],
 2307    alt_urls(T).
 2308
 2309% Installation dependencies gathered from inquiry server.
 2310
 2311message(install_dependencies(Resolution)) -->
 2312    [ 'Package depends on the following:' ],
 2313    msg_res_tokens(Resolution, 1).
 2314
 2315msg_res_tokens([], _) --> [].
 2316msg_res_tokens([H|T], L) --> msg_res_token(H, L), msg_res_tokens(T, L).
 2317
 2318msg_res_token(Token-unresolved, L) -->
 2319    res_indent(L),
 2320    [ '"~w" cannot be satisfied'-[Token] ].
 2321msg_res_token(Token-resolve(Pack, Version, [URL|_], SubResolves), L) -->
 2322    !,
 2323    res_indent(L),
 2324    [ '"~w", provided by ~w@~w from ~w'-[Token, Pack, Version, URL] ],
 2325    { L2 is L+1 },
 2326    msg_res_tokens(SubResolves, L2).
 2327msg_res_token(Token-resolved(Pack), L) -->
 2328    !,
 2329    res_indent(L),
 2330    [ '"~w", provided by installed pack ~w'-[Token,Pack] ].
 2331
 2332res_indent(L) -->
 2333    { I is L*2 },
 2334    [ nl, '~*c'-[I,0'\s] ].
 2335
 2336message(resolve_deps) -->
 2337    [ nl, 'What do you wish to do' ].
 2338label(install_deps) -->
 2339    [ 'Install proposed dependencies' ].
 2340label(install_no_deps) -->
 2341    [ 'Only install requested package' ].
 2342
 2343
 2344message(git_fetch(Dir)) -->
 2345    [ 'Running "git fetch" in ~q'-[Dir] ].
 2346
 2347% inquiry is blank
 2348
 2349message(inquiry_ok(Reply, File)) -->
 2350    { memberchk(downloads(Count), Reply),
 2351      memberchk(rating(VoteCount, Rating), Reply),
 2352      !,
 2353      length(Stars, Rating),
 2354      maplist(=(0'*), Stars)
 2355    },
 2356    [ '"~w" was downloaded ~D times.  Package rated ~s (~D votes)'-
 2357      [ File, Count, Stars, VoteCount ]
 2358    ].
 2359message(inquiry_ok(Reply, File)) -->
 2360    { memberchk(downloads(Count), Reply)
 2361    },
 2362    [ '"~w" was downloaded ~D times'-[ File, Count ] ].
 2363
 2364                                                % support predicates
 2365unsatisfied([]) --> [].
 2366unsatisfied([Needed-[By]|T]) -->
 2367    [ '  - "~w" is needed by package "~w"'-[Needed, By], nl ],
 2368    unsatisfied(T).
 2369unsatisfied([Needed-By|T]) -->
 2370    [ '  - "~w" is needed by the following packages:'-[Needed], nl ],
 2371    pack_list(By),
 2372    unsatisfied(T).
 2373
 2374pack_list([]) --> [].
 2375pack_list([H|T]) -->
 2376    [ '    - Package "~w"'-[H], nl ],
 2377    pack_list(T).
 2378
 2379process_lines([]) --> [].
 2380process_lines([H|T]) -->
 2381    [ '~s'-[H] ],
 2382    (   {T==[]}
 2383    ->  []
 2384    ;   [nl], process_lines(T)
 2385    ).
 2386
 2387split_lines([], []) :- !.
 2388split_lines(All, [Line1|More]) :-
 2389    append(Line1, [0'\n|Rest], All),
 2390    !,
 2391    split_lines(Rest, More).
 2392split_lines(Line, [Line]).
 2393
 2394label(remove_only(Pack)) -->
 2395    [ 'Only remove package ~w (break dependencies)'-[Pack] ].
 2396label(remove_deps(Pack, Deps)) -->
 2397    { length(Deps, Count) },
 2398    [ 'Remove package ~w and ~D dependencies'-[Pack, Count] ].
 2399label(create_dir(Dir)) -->
 2400    [ '~w'-[Dir] ].
 2401label(install_from(git(URL))) -->
 2402    !,
 2403    [ 'GIT repository at ~w'-[URL] ].
 2404label(install_from(URL)) -->
 2405    [ '~w'-[URL] ].
 2406label(cancel) -->
 2407    [ 'Cancel' ].
 2408
 2409confirm_default(yes) -->
 2410    [ ' Y/n? ' ].
 2411confirm_default(no) -->
 2412    [ ' y/N? ' ].
 2413confirm_default(none) -->
 2414    [ ' y/n? ' ].
 2415
 2416msg_version(Version) -->
 2417    { atom(Version) },
 2418    !,
 2419    [ '~w'-[Version] ].
 2420msg_version(VersionData) -->
 2421    !,
 2422    { atom_version(Atom, VersionData) },
 2423    [ '~w'-[Atom] ]