/* 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: (-) :- 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.