test_xpce.pl

/*  Part of XPCE/SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (c)  2018-2023, University of Amsterdam
                              SWI-Prolog Solutions b.v.
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

:- module(test_xpce,
          [ test_xpce/0
          ]).
:- encoding(utf8).

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
XPCE/SWI-Prolog test file.  A test is a clause of the form:

        <TestSet>(<Name>-<Number>) :- Body.

If the body fails, an appropriate  error   message  is  printed. So, all
goals are supposed to  succeed.  The   predicate  testset/1  defines the
available test sets. The public goals are:

        ?- runtest(+TestSet).
        ?- test_xpce.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

:- if(exists_source(library(pce))).
% Load XPCE from the development environment

:- use_module(library(pce)).
:- get(@pce, version, V),
   format('XPCE/SWI-Prolog test suite. (XPCE version ~w)~n\c
          To run all tests run ?- test.~n~n', [V]).



                 /*******************************
                 *            NAMES             *
                 *******************************/

name(name-1) :-
    Atom = foobar,
    get(chain(Atom), head, Copy),
    Copy == Atom.


                 /*******************************
                 *             FORMAT           *
                 *******************************/

fmt(fmt-1) :-
    get(string('hello %s', world), value, X),
    X == 'hello world'.
fmt(fmt-2) :-
    get(string('hello %d', 42), value, X),
    X == 'hello 42'.
fmt(fmt-3) :-
    get(string('%4dxx', 42), value, X),
    X == '  42xx'.
fmt(fmt-4) :-
    get(string('%-4dxx', 42), value, X),
    X == '42  xx'.
fmt(fmt-5) :-
    get(string('|%8s|', hello), value, X),
    X == '|   hello|'.
fmt(fmt-6) :-
    get(string('|%-8s|', hello), value, X),
    X == '|hello   |'.




                 /*******************************
                 *          WIDE NAMES          *
                 *******************************/

watom(Atom) :-
    numlist(1050, 1080, L),
    atom_codes(Atom, L).

wname(wname-1) :-                       % Create wide character name
    numlist(1050, 1080, L),
    atom_codes(Atom, L),
    forall(between(0, 30, I),
           ( get(Atom, character, I, C),
             C =:= I+1050)).
wname(wname-2) :-                       % get it back as an atom
    watom(Atom),
    get(chain(Atom), head, Copy),
    Copy == Atom.
wname(append-1) :-
    atom_codes(X, [1100]),
    get('', append, X, Y),
    Y == X.


                 /*******************************
                 *         WIDE STRINGS         *
                 *******************************/

wstring(create-1) :-
    numlist(1050, 1080, L),
    new(S, string(L)),
    forall(between(0, 30, I),
           ( get(S, character, I, C),
             C =:= I+1050)).
wstring(cvt-1) :-
    numlist(1050, 1080, L),
    new(S, string(L)),
    get(S, value, Atom),
    atom_codes(Atom, L).
wstring(fmt-1) :-
    watom(A),
    get(string('hello %s', A), value, A2),
    atom_concat('hello ', A, A2).
wstring(append-1) :-
    new(S, string([97,98])),
    send(S, append, string([1060,1061])),
    get(S, value, V),
    atom_codes(V, [97,98,1060,1061]).
wstring(char-1) :-
    new(S, string(x)),
    send(S, character, 0, 1000),
    get(S, size, 1),
    get(S, character, 0, X),
    X == 1000.
wstring(tr-1) :-
    new(S, string(abc)),
    send(S, translate, b, 1060),
    get(S, value, N),
    atom_codes(N, [97,1060,99]).
wstring(sub-1) :-
    new(S, string([60,61,1060])),
    get(S, sub, 0, 2, S2),
    send(S2, equal, string([60,61])).
wstring(split-1) :-
    List = ["aap", [1060,1061], "noot"],
    maplist(atom_codes, Atoms, List),
    atomic_list_concat(Atoms, -, Text),
    get(Text, split, -, Chain),
    chain_list(Chain, Splitted),
    Splitted == Atoms.
wstring(store-1) :-
    numlist(32, 1000, L),
    atom_codes(Watom, L),
    tmp_file(tb, Tmp),
    new(S, string('%s', Watom)),
    send(S, save_in_file, Tmp),
    get(file(Tmp), object, S2),
    get(S2, value, Value),
    Value == Watom.


                 /*******************************
                 *           SOURCE SINK        *
                 *******************************/

srcsink(contents-1) :-
    numlist(32, 1000, L),
    tmp_file(test, Tmp),
    open(Tmp, write, Out, [encoding(utf8)]),
    maplist(put_code(Out), L),
    close(Out),
    new(File, file(Tmp, utf8)),
    get(File, contents, String),
    delete_file(Tmp),
    get(String, value, Atom),
    atom_codes(Atom, L).
srcsink(read-1) :-
    numlist(32, 1000, L),
    tmp_file(test, Tmp),
    open(Tmp, write, Out, [encoding(utf8)]),
    maplist(put_code(Out), L),
    close(Out),
    new(File, file(Tmp, utf8)),
    send(File, open, read),
    get(File, read, String),
    send(File, close),
    delete_file(Tmp),
    get(String, value, Atom),
    atom_codes(Atom, L).


                 /*******************************
                 *             FILE             *
                 *******************************/

foreign(привіт).

file(env-1) :-
    new(F, file('$PCEHOME/Defaults')),
    send(F, exists),
    absolute_file_name(pce('Defaults'), PlName),
    get(F, name, PceName),
    same_file(PceName, PlName),
    send(F, same, PlName).
file(home-1) :-
    new(F, file('~/foobar')),
    get(F, name, PceName),
    expand_file_name('~/foobar', [PlName]),
    same_file(PceName, PlName).
file(abs-1) :-
    new(F, file(foobar)),
    get(F, absolute_path, Abs),
    is_absolute_file_name(Abs),
    file_directory_name(Abs, Here),
    working_directory(H,H),
    same_file(Here, H).
file(exists-1) :-
    expand_file_name(*, Files),
    forall(member(F, Files),
           (   exists_file(F)
           ->  send(file(F), exists)
           ;   \+ send(file(F), exists)
           )).


                 /*******************************
                 *         UNICODE FILE         *
                 *******************************/

foreign_creatable(Name) :-
    current_prolog_flag(tmp_dir, TmpDir),
    current_prolog_flag(pid, PID),
    foreign(Base),
    format(atom(Name), '~w/swipl-~w-~d', [TmpDir,Base,PID]).

unicode_file(utf8-1) :-
    foreign_creatable(Name),
    Text = 'Hello world\n',
    new(F, file(Name)),
    send(F, open, write),
    send(F, append, Text),
    send(F, close),
    new(F2, file(Name)),
    exists_file(Name),
    send(F2, exists),
    get(F2, contents, string(Text)),
    send(F2, remove).
unicode_file(backup-1) :-
    foreign(Name),
    get(file(Name), backup_file_name, Backup),
    atom_concat(Name, ~, Backup).


                 /*******************************
                 *            DIRECTORY         *
                 *******************************/

dir(cwd-1) :-
    new(D, directory(.)),
    get(D, path, Path),
    same_file(Path, '.').
dir(parent-1) :-
    new(D, directory(.)),
    get(D, parent, PD),
    get(PD, path, Parent),
    working_directory(CWD0, CWD0),
    (   sub_atom(CWD0, _, _, 0, /)
    ->  atom_concat(CWD, /, CWD0)
    ;   CWD = CWD0
    ),
    file_directory_name(CWD, PlParent),
    same_file(Parent, PlParent).
dir(members-1) :-
    new(D, directory(.)),
    get_chain(D, files, Files),
    forall(member(F, Files), send(file(F), exists)).
dir(members-2) :-
    new(D, directory(.)),
    get_chain(D, directories, Dirs),
    forall(member(F,Dirs), send(directory(F), exists)).
dir(members-3) :-
    new(D, directory(.)),
    get_chain(D, files, Files),
    get_chain(D, directories, Dirs),
    append(Files, Dirs, All),
    sort(All, S0),
    expand_file_name(*, PlAll),
    sort(PlAll, S1),
    S0 == S1.


                 /*******************************
                 *      UNICODE DIRECTORY       *
                 *******************************/

unicode_dir(foreign-1) :-
    foreign_creatable(Name),
    new(D, directory(Name)),
    send(D, make),
    send(D, exists),
    delete_directory(Name).
unicode_dir(foreign-2) :-
    foreign_creatable(Name),
    new(D, directory(Name)),
    send(D, make),
    send(D, exists),
    file_directory_name(Name, Dir),
    file_base_name(Name, Base),
    new(D2, directory(Dir)),
    get_chain(D2, directories, Dirs),
    memberchk(Base, Dirs),
    delete_directory(Name).
unicode_dir(foreign-3) :-
    foreign_creatable(Name),
    new(D, directory(Name)),
    send(D, make),
    send(D, exists),
    send(D, cd),
    new(D2, directory(.)),
    get(D2, path, PD2),
    file_directory_name(PD2, Old),
    working_directory(_, ..),
    same_file(Old, '.'),
    delete_directory(Name).


                 /*******************************
                 *          TEXT-BUFFER         *
                 *******************************/

textbuffer(promote-1) :-
    new(TB, text_buffer),
    send(TB, append, hello),
    watom(Wide),
    send(TB, append, Wide),
    get(TB, contents, string(New)),
    atom_concat(hello, Wide, New).
textbuffer(file-1) :-
    new(TB, text_buffer),
    numlist(32, 1000, L),
    atom_codes(WAtom, L),
    send(TB, append, WAtom),
    tmp_file(test, Tmp),
    send(TB, save, file(Tmp, utf8)),
    get(file(Tmp, utf8), contents, string(Copy)),
    delete_file(Tmp),
    Copy == WAtom.
textbuffer(store-1) :-
    tmp_file(tb, Tmp),
    new(TB, text_buffer('Hello world')),
    send(TB, save_in_file, Tmp),
    get(file(Tmp), object, TB2),
    get(TB2?contents, value, Value),
    Value == 'Hello world'.
textbuffer(store-2) :-
    numlist(32, 1000, L),
    atom_codes(WAtom, L),
    tmp_file(tb, Tmp),
    new(TB, text_buffer(WAtom)),
    send(TB, save_in_file, Tmp),
    get(file(Tmp), object, TB2),
    get(TB2?contents, value, Value),
    Value == WAtom.


                 /*******************************
                 *              REAL            *
                 *******************************/

real(itf-1) :-
    D = 213.4753,
    new(C, chain(D)),
    get(C, head, D2),
    D == D2.
real(add-1) :-
    D1 is 454.234, D2 is -373.33,
    new(R1, real(D1)),
    send(R1, plus, D2),
    get(R1, value, Sum),
    Sum =:= D1+D2.
real(store-1) :-
    D = 3783.3784378,
    new(R, real(D)),
    tmp_file(store, Tmp),
    send(R, save_in_file, Tmp),
    get(file(Tmp), object, R2),
    D == R2.

                 /*******************************
                 *        OBJECT-AS-FILE        *
                 *******************************/

asfile(tb-1) :-
    Term = hello('World'),
    new(TB, text_buffer),
    pce_open(TB, write, Out),
    format(Out, '~q', [Term]),
    close(Out),
    get(TB?contents, value, Atom),
    term_to_atom(Term, Atom).
asfile(tb-2) :-
    watom(Wide),
    Term = hello(Wide),
    new(TB, text_buffer),
    pce_open(TB, write, Out),
    format(Out, '~q', [Term]),
    close(Out),
    get(TB?contents, value, Atom),
    term_to_atom(Term, Atom).
asfile(tb-3) :-
    watom(Wide),
    Terms = [ aap, hello(Wide), hello(42) ],
    new(TB, text_buffer),
    pce_open(TB, write, Out),
    forall(member(T, Terms),
           format(Out, '~q.~n', [T])),
    close(Out),
    pce_open(TB, read, In),
    read_stream_to_terms(In, Read),
    close(In),
    Read =@= Terms.
asfile(tb-4) :-
    numlist(0, 20000, L),
    atom_codes(Atom, L),
    new(TB, text_buffer),
    send(TB, contents, Atom),
    pce_open(TB, read, In),
    get_code(In, 0),
    seek(In, 0, current, P1), P1 == 1,
    forall(member(Pos, [20, 5000, 10240]),
           (   seek(In, Pos, bof, P), P == Pos,
               get_code(In, Code), Code == Pos
           )),
    seek(In, 0, eof, EndPos), atom_length(Atom, EndPos),
    close(In),
    free(TB).

read_stream_to_terms(In, Terms) :-
    read(In, T0),
    read_stream_to_terms(T0, In, Terms).

read_stream_to_terms(end_of_file, _, []) :- !.
read_stream_to_terms(H, In, [H|T]) :-
    read(In, T0),
    read_stream_to_terms(T0, In, T).


                 /*******************************
                 *             BOM              *
                 *******************************/

bom(bom-1) :-
    tmp_file(bom, File),
    open(File, write, Out,
         [ encoding(unicode_le),
           bom(true)
         ]),
    forall(between(32, 1100, C), put_code(Out, C)),
    close(Out),
    new(V, view),
    send(V, load, file(File)),
    get(V?file, encoding, unicode_le),
    send(V, append, '\nHello world'),
    send(V, save),
    new(F, file(File)),
    send(F, open, read),
    get(F, encoding, unicode_le),
    get(F, bom, @on),
    send(F, close),
    delete_file(File).


                 /*******************************
                 *         PROLOG TERMS         *
                 *******************************/

plterm(print_name-1) :-
    new(C, chain(prolog(bar(foo)))),
    get(C?head, print_name, string(X)),
    X == 'bar(foo)'.


                 /*******************************
                 *           SELECTION          *
                 *******************************/

selection(cutpaste-1) :-
    Atom = 'hello world',
    send(@display, selection, primary, string(Atom)),
    get(@display, selection, primary, utf8_string, string(X)),
    X == Atom.
selection(cutpaste-2) :-
    watom(Atom),
    send(@display, selection, primary, string(Atom)),
    get(@display, selection, primary, utf8_string, string(X)),
    X == Atom.


                 /*******************************
                 *             IMAGE            *
                 *******************************/

image(bitmap-1) :-
    new(I, image(@nil, 100, 100, bitmap)),
    get(I, pixel, 10, 10, @off),
    send(I, pixel, 10, 10, @on),
    get(I, pixel, 10, 10, @on),
    free(I).


                 /*******************************
                 *             REGEX            *
                 *******************************/

re_tb(TB, From, GapAt) :-
    new(TB, text_buffer(From)),
    send(TB, insert, GapAt, x),
    send(TB, delete, GapAt, 1).

re_frag(Frag, From) :-
    new(TB, text_buffer),
    send(TB, append, 'leader '),
    get(TB, size, Start),
    send(TB, append, From),
    send(TB, append, ' trailer'),
    atom_length(From, Len),
    new(Frag, fragment(TB, Start, Len)).

re_target(In, atom, In).
re_target(In, text_buffer, TB) :-
    re_tb(TB, In, 0).
re_target(In, fragment, Frag) :-
    re_frag(Frag, In).

re_free(Atom) :-
    atom(Atom),
    !.
re_free(Frag) :-
    send(Frag, instance_of, fragment),
    !,
    get(Frag, text_buffer, TB),
    free(TB).
re_free(Obj) :-
    free(Obj).

re_match(regex(foo), @default, @default, 'aap foo bar', 4-7).
re_match(regex(foo), 4, @default, 'aap foo bar', 4-7).
re_match(regex(foo), 11, 0, 'aap foo bar', 4-7).
re_match(regex(foo, @off), @default, @default, 'aap FOO bar', 4-7).
re_match(regex(foo), @default, @default, String, 4-7) :-
    atom_codes(W, [1080]),
    atom_concat('aap foo bar', W, String).

regex(regex-1) :-
    State = state(ok),
    (   re_match(Term, Start, End, In, From-To),
        new(Re, Term),
        re_target(In, How, Target),
        (   send(Re, search, Target, Start, End),
            get(Re, register_start, From),
            get(Re, register_end, To)
        ->  re_free(Target),
            put(.), flush
        ;   format('~NRegex: failed ~w on ~w (~w)~n', [Term, In, How]),
            nb_setarg(1, State, error)
        ),
        fail
    ;   arg(1, State, ok)
    ).
regex(regex-2) :-                       % backref test
    send(regex('(.)x\\1'), match, 'axa').
regex(regex-3) :-                       % backward search
    get(regex('[({[]|:'), search, '{ ', 2, 0, X),
    X == 0.
regex(regex-4) :-                       % BOSONLY on branches
    \+ send(regex('foo|bar'), match, 'xx bar').
regex(regex-5) :-                       % end-of-line in partial-matches
    get(regex('^.'), search, 'hello', 5, 0, X),
    X == 0.
regex(regex-6) :-
    send(regex(hello), match, 'hello', 5, 0).
regex(regex-7) :-
    \+ send(regex(hello), match, 'hello ', 6, 0).


                 /*******************************
                 *             TYPES            *
                 *******************************/

type(type-1) :-
    get(@pce, convert, '0..3', type, Type),
    get(Type, kind, int_range),
    get(Type, context, tuple(0, 3)).
type(type-2) :-
    get(@pce, convert, '0.2..32', type, Type),
    get(Type, kind, real_range),
    get(Type, context, tuple(0.2, 32.0)).


                 /*******************************
                 *            SCRIPTS           *
                 *******************************/

:- dynamic
    script_dir/1.

set_script_dir :-
    script_dir(_),
    !.
set_script_dir :-
    find_script_dir(Dir),
    assert(script_dir(Dir)).

find_script_dir(Dir) :-
    prolog_load_context(file, File),
    follow_links(File, RealFile),
    file_directory_name(RealFile, Dir).

follow_links(File, RealFile) :-
    read_link(File, _, RealFile),
    !.
follow_links(File, File).


:- set_script_dir.

run_test_script(Script) :-
    file_base_name(Script, Base),
    file_name_extension(Pred, _, Base),
    load_files(Script, [silent(true)]),
    Pred.

run_test_scripts(Directory) :-
    (   script_dir(ScriptDir),
        atomic_list_concat([ScriptDir, /, Directory], Dir),
        exists_directory(Dir)
    ->  true
    ;   Dir = Directory
    ),
    atom_concat(Dir, '/*.pl', Pattern),
    expand_file_name(Pattern, Files),
    file_base_name(Dir, BaseDir),
    format('Running scripts from ~w ', [BaseDir]), flush,
    run_scripts(Files),
    format(' done~n').

run_scripts([]).
run_scripts([H|T]) :-
    (   catch(run_test_script(H), Except, true)
    ->  (   var(Except)
        ->  put(.), flush
        ;   Except = blocked(Reason)
        ->  assert(blocked(H, Reason)),
            put(!), flush
        ;   script_failed(H, Except)
        )
    ;   script_failed(H, fail)
    ),
    run_scripts(T).

script_failed(File, fail) :-
    format('~NScript ~w failed~n', [File]),
    assert(failed(script(File))).
script_failed(File, Except) :-
    message_to_string(Except, Error),
    format('~NScript ~w failed: ~w~n', [File, Error]),
    assert(failed(script(File))).


                 /*******************************
                 *        TEST MAIN-LOOP        *
                 *******************************/

testset(name).                          % XPCE names
testset(wname).                         % Names holding wide characters
testset(wstring) :-                     % Strings holding wide characters
    wide_character_types.
testset(fmt).                           % Formatting actions
testset(srcsink).                       % Source/Sink operations
testset(file).                          % file (-name) handling
testset(unicode_file) :-                % Unicode file (-name) handling
    unicode_file_locale.
testset(dir).                           % directory (-name) handling
testset(unicode_dir) :-                 % Unicode directory (-name) handling
    unicode_file_locale.
testset(bom) :-                         % Byte Order Mark hanling
    display_present.
testset(plterm).                        % Prolog terms in XPCE
testset(real).                          % floating point numbers
testset(textbuffer).
testset(asfile).                        % test pce_open and friends
testset(selection) :-                   % X11 selection
    display_present.
testset(image) :-                       % Simple image manipulation
    display_present.
testset(regex).                         % Regular expression matches
testset(type).                          % Check type logic

%       unicode_file_locale/0
%
%       True if out filesystem can   handle Unicode filenames. Difficult
%       to have a good test.

unicode_file_locale :-
    current_prolog_flag(encoding, utf8),
    !.
unicode_file_locale :-
    catch(file_name_extension(_,_,[1050]), E, true),
    (   var(E)
    ->  true
    ;   E \= error(representation_error(encoding), _)
    ).

%       wide_character_types
%
%       True if the  character  classification   routines  work  on wide
%       characters. Hard to say when this is  the case. On some machines
%       the wide character versions always work,  on others only for the
%       codepages covered by the locale.

wide_character_types :-
    current_prolog_flag(encoding, utf8),
    !.

%       display_present
%
%       True if the current user session is running under a windowed
%       environment.

display_present :-
    (   current_prolog_flag(windows, true)
    ->  true
    ;   getenv('DISPLAY', _)
    ).

%       testdir(Dir)
%
%       Enumerate directories holding tests.

:- multifile
    testdir/1.

%testdir('Tests/attvar').


:- dynamic
    failed/1,
    blocked/2.

test_xpce :-
    retractall(failed(_)),
    retractall(blocked(_,_)),
    forall(testset(Set),            % force XPCE incremental GC
           send(@prolog, call, 'xpce_runtest', Set)),
    scripts,
    report_blocked,
    report_failed.

scripts :-
    forall(testdir(Dir), run_test_scripts(Dir)).


report_blocked :-
    findall(Head-Reason, blocked(Head, Reason), L),
    (   L \== []
    ->  format('~nThe following tests are blocked:~n', []),
        (   member(Head-Reason, L),
            format('    ~p~t~40|~w~n', [Head, Reason]),
            fail
        ;   true
        )
    ;   true
    ).
report_failed :-
    findall(X, failed(X), L),
    length(L, Len),
    (   Len > 0
    ->  format('~n*** ~w tests failed ***~n', [Len]),
        fail
    ;   format('~nAll tests passed~n', [])
    ).

user:xpce_runtest(Name) :-
    format('Running test set "~w" ', [Name]),
    flush,
    functor(Head, Name, 1),
    nth_clause(Head, _N, R),
    clause(Head, _, R),
    (   catch(Head, Except, true)
    ->  (   var(Except)
        ->  put(.), flush
        ;   Except = blocked(Reason)
        ->  assert(blocked(Head, Reason)),
            put(!), flush
        ;   test_failed(R, Except)
        )
    ;   test_failed(R, fail)
    ),
    fail.
user:xpce_runtest(_) :-
    format(' done.~n').

test_failed(R, Except) :-
    clause(Head, _, R),
    functor(Head, Name, 1),
    arg(1, Head, TestName),
    clause_property(R, line_count(Line)),
    clause_property(R, file(File)),
    (   Except == fail
    ->  format('~N~w:~d: Test ~w(~w) failed~n',
               [File, Line, Name, TestName])
    ;   message_to_string(Except, Error),
        format('~N~w:~d: Test ~w(~w):~n~t~8|ERROR: ~w~n',
               [File, Line, Name, TestName, Error])
    ),
    assert(failed(Head)).

blocked(Reason) :-
    throw(blocked(Reason)).

:- else.

test_xpce :-
    format('Cannot find library(pce); skipping xpce tests.~n').

:- endif.