:- module(test_xpce,

[ test_xpce/0

]).

:- encoding(utf8).

:- if(exists_source(library(pce))).

:- 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]).

/*******************************

name(name-1) :-

Atom = foobar,

get(chain(Atom), head, Copy),

Copy == Atom.

/*******************************

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 |'.

/*******************************

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.

/*******************************

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(copy-1) :- % string(Object) copies the text

new(S0, string(hello)),

new(S, string(S0)),

send(S, append, '!'),

get(S0, value, hello),

get(S, value, 'hello!').

wstring(copy-2) :- % ... of a term that makes one

new(S, string(string([1060,1061]))),

get(S, value, V),

atom_codes(V, [1060,1061]).

wstring(copy-3) :- % ... literally, as string(Atom)

new(S, string(string('a%%b'))),

get(S, value, 'a%%b').

wstring(copy-4) :- % ... and only of text

catch(( new(_, string(point(1,2))), fail ),

error(type_error(_,_),_),

true).

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.

/*******************************

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).

/*******************************

foreign(привіт).

file(env-1) :-

new(F, file('$PCEHOME/Defaults.user')),

send(F, exists),

absolute_file_name(pce('Defaults.user'), 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)

)).

/*******************************

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).

/*******************************

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_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).

/*******************************

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(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.

real(store-2) :- % a num that is not an int32

new(L, line(0, 0, 10, 10)),

send(L, pen, 1.5),

send(L, attribute, big, 3000000000),

tmp_file(store, Tmp),

send(L, save_in_file, Tmp),

get(file(Tmp), object, L2),

get(L2, pen, Pen),

get(L2, attribute, big, Big),

Pen == 1.5,

Big == 3000000000.

/*******************************

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-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).

/*******************************

plterm(print_name-1) :-

new(C, chain(prolog(bar(foo)))),

get(C?head, print_name, string(X)),

X == 'bar(foo)'.

/*******************************

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.

/*******************************

/*******************************

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).

/*******************************

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(Low, High)),

Low =:= 0.2,

High =:= 32.

/*******************************

:- 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))).

/*******************************

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 :-

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 :-

current_prolog_flag(encoding, utf8),

!.

display_present :-

catch(get(@display, size, _), _, fail).

:- multifile

testdir/1.

:- 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.