use strict;
use warnings;
use constant DONE => 1;
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More qw(no_plan);
use Data::Dumper;
$Data::Dumper::Indent = 1;
sub _chomp {
my $s = shift;
chomp $s;
return $s;
}
use TM;
use TM::PSI;
sub _parse {
my $text = shift;
my $ms = new TM (baseuri => 'tm:');
use TM::CTM::Parser;
my $p = new TM::CTM::Parser (store => $ms);
my $i = $p->parse ($text);
return $ms;
}
sub die_ok {
my $ctm = shift;
my $err = shift;
eval {
_parse ($ctm);
fail ("exc: expected $@");
};
chomp ($@);
my $verr = $@;
$verr =~ s/\n/\n /g; # create blanks/comments on multiline complaints
like ($@, qr/$err/, "exc: found '$verr'");
}
sub _q_players {
my $ms = shift;
my @res = $ms->match (TM->FORALL, @_);
# warn "res no filter ".Dumper \@res;
@res = grep ($_ !~ m|^tm:|, map { ref($_) ? ${$_} : $_ } map { @{$_->[TM->PLAYERS]} } $ms->match (TM->FORALL, @_));
# warn "res ".Dumper \@res;
return \@res;
}
my $warn = shift @ARGV;
unless ($warn) {
close STDERR;
open (STDERR, ">/dev/null");
select (STDERR); $| = 1;
}
#== TESTS ===========================================================================
my $npa = scalar keys %{$TM::infrastructure->{assertions}};
my $npt = scalar keys %{$TM::infrastructure->{mid2iid}};
if (DONE) { # 3.2.1. Topic with an Item Identifier
my $ms = _parse (q|
john.
|);
#warn Dumper $ms;
ok ($ms->tids ('john'), '3.2.1. Topic with an Item Identifier');
is ($ms->toplets, $npt+1, ' one additional');
}
if (DONE) { # 3.2.2. Typed Topic - Using Item Identifiers
my $ms = _parse (q|
john isa person.
|);
#warn Dumper $ms;
ok ($ms->tids ('john'), '3.2.2. Typed Topic - Using Item Identifiers');
ok ($ms->tids ('person'), '3.2.2. Typed Topic - Using Item Identifiers');
is ($ms->toplets, $npt+2, ' additional');
ok (eq_set ([ $ms->instances ('tm:person') ], [ 'tm:john' ]), ' instances');
}
if (DONE) { # 3.2.3. Typed Topic - Using Subject Identifiers
my $ms = _parse (q|
john isa http://psi.example.org/music/guitarist.
paul isa http://psi.example.org/music/guitarist .
george isa http://psi.example.org/music/guitarist .
|);
#warn Dumper $ms;
ok ($ms->tids ('john'), '3.2.3. Typed Topic - Using Subject Identifiers');
ok ($ms->tids ('paul'), '3.2.3. Typed Topic - Using Subject Identifiers');
ok ($ms->tids ('george'), '3.2.3. Typed Topic - Using Subject Identifiers');
is ($ms->toplets, $npt+4, ' additional');
ok (eq_set ([ $ms->types ('tm:john') ], [ 'tm:uuid-0000000000' ]), ' types');
ok (eq_set ($ms->toplet ('tm:uuid-0000000000')->[TM->INDICATORS],
[
'http://psi.example.org/music/guitarist'
]), ' indicators');
ok (eq_set ([ $ms->instances ('tm:uuid-0000000000') ],
[ 'tm:john', 'tm:paul', 'tm:george' ]
), ' instances');
}
if (DONE) { # 3.2.3. Typed Topic - Using Subject Identifiers, using the "prefix" directive
my $ms = _parse (q|
%prefix music http://psi.example.org/music/
john isa music:guitarist.
paul isa music:guitarist .
george isa music:guitarist .
|);
#warn Dumper $ms;
ok ($ms->tids ('john'), '3.2.3. Typed Topic - Using Subject Identifiers, prefixed');
ok ($ms->tids ('paul'), '3.2.3. Typed Topic - Using Subject Identifiers, prefixed');
ok ($ms->tids ('george'), '3.2.3. Typed Topic - Using Subject Identifiers, prefixed');
is ($ms->toplets, $npt+4, ' additional');
my $guitarman = $ms->mids (\ 'http://psi.example.org/music/guitarist');
ok (eq_set ($ms->toplet ($guitarman)->[TM->INDICATORS],
[
'http://psi.example.org/music/guitarist'
]), ' indicators');
ok (eq_set ([ $ms->instances ($guitarman) ], [ 'tm:john', 'tm:paul', 'tm:george' ]), ' instances');
}
if (DONE) { # 3.2.4. Multityped Topic - Using Item Identifiers
my $ms = _parse (q|
john isa singer;
isa guitarist.
|);
#warn Dumper $ms;
ok ($ms->tids ('john'), '3.2.4. Multityped Topic - Using Item Identifiers');
ok ($ms->tids ('singer'), '3.2.4. Multityped Topic - Using Item Identifiers');
ok ($ms->tids ('guitarist'), '3.2.4. Multityped Topic - Using Item Identifiers');
is ($ms->toplets, $npt+3, ' additional');
ok (eq_set ([ $ms->instances ('tm:singer') ], [ 'tm:john' ]), ' instances');
ok (eq_set ([ $ms->instances ('tm:guitarist') ], [ 'tm:john' ]), ' instances');
}
if (DONE) { # 3.2.5. Multityped Topic - Using Subject Identifiers
my $ms = _parse (q|
http://psi.example.org/beatles/john isa singer; isa guitarist.
|);
#warn Dumper $ms;
my $john = $ms->tids (\ 'http://psi.example.org/beatles/john');
ok ($john, '3.2.5. Multityped Topic - Using Subject Identifiers');
ok ($ms->tids ('singer'), '3.2.5. Multityped Topic - Using Subject Identifiers');
ok ($ms->tids ('guitarist'), '3.2.5. Multityped Topic - Using Subject Identifiers');
is ($ms->toplets, $npt+3, ' additional');
ok (eq_set ([ $ms->instances ('tm:singer') ], [ $john ]), ' instances');
ok (eq_set ([ $ms->instances ('tm:guitarist') ], [ $john ]), ' instances');
}
if (DONE) { # 3.3.1. Topic with an Item Identifier and Topic Name
my $ms = _parse (q|
john - "John Lennon".
|);
#warn Dumper $ms;
ok ($ms->tids ('john'), '3.3.1. Topic with an Item Identifier and Topic Name');
is ($ms->toplets, $npt+1, ' additional');
is ($ms->asserts, $npa+1, ' additional');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match_forall (char => 1, topic => $ms->tids ('john')) ] ,
[ 'John Lennon' ]), ' names of john');
}
if (DONE) { # 3.3.2. Topic with a Subject Identifier and Topic Name
my $ms = _parse (q|
%prefix beatles http://psi.beatles.example.org/
beatles:john - "John Lennon" .
|);
#warn Dumper $ms;
my $john = $ms->tids (\ 'http://psi.beatles.example.org/john' );
ok ($john, '3.3.2. Topic with a Subject Identifier and Topic Name');
is ($ms->toplets, $npt+1, ' additional');
is ($ms->asserts, $npa+1, ' additional');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match_forall (char => 1, topic => $john) ] ,
[ 'John Lennon' ]), ' names of john');
}
if (DONE) { # 3.3.3. Topic with a Subject Locator and a Topic Name
my $ms = _parse (q|
= http://beatles.com/ - "Official website of The Beatles".
|);
#warn Dumper $ms;
my $beatles = $ms->tids ( 'http://beatles.com/' );
ok ($beatles, '3.3.3. Topic with a Subject Locator and a Topic Name');
is ($ms->toplets, $npt+1, ' additional');
is ($ms->asserts, $npa+1, ' additional');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match_forall (char => 1, topic => $beatles) ] ,
[ 'Official website of The Beatles' ]), ' name of beatles');
}
if (DONE) { # 3.3.4. Typed Topic Name - Using Item Identifiers
my $ms = _parse (q|
john - fullname: "John Ono Lennon".
|);
#warn Dumper $ms;
my $john = $ms->tids ( 'john' );
ok ($john, '3.3.4. Typed Topic Name - Using Item Identifiers');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq 'tm:fullname'}
$ms->match_forall (char => 1, topic => $john) ] ,
[ 'John Ono Lennon' ]), ' fullname of john');
ok (eq_set ([ map { $_->[TM->TYPE] } $ms->retrieve ( $ms->instances ('name') ) ] ,
[ 'tm:fullname' ]), ' fullname of john (name subtype)');
}
if (DONE) { # 3.3.5. Typed Topic Names - Using Subject Identifiers
my $ms = _parse (q|
john - http://psi.example.org/fullname: "John Ono Lennon".
|);
#warn Dumper $ms;
my $john = $ms->tids ( 'john' );
ok ($john, '3.3.5. Typed Topic Names - Using Subject Identifiers');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
my $fn = $ms->tids (\ 'http://psi.example.org/fullname');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq $fn }
$ms->match_forall (char => 1, topic => $john) ] ,
[ 'John Ono Lennon' ]), ' fullname of john');
ok (eq_set ([ map { $_->[TM->TYPE] } $ms->retrieve ( $ms->instances ('name') ) ] ,
[ $fn ]), ' fullname of john (name subtype)');
}
if (DONE) { # 3.3.6. Scoped Topic Name - Using Item Identifiers
my $ms = _parse (q|
john - "John Ono Lennon" @fullname.
|);
#warn Dumper $ms;
my $john = $ms->tids ( 'john' );
ok ($john, '3.3.6. Scoped Topic Name - Using Item Identifiers');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->SCOPE] eq 'tm:fullname' }
grep { $_->[TM->TYPE] eq 'name' }
$ms->match_forall (char => 1, topic => $john) ] ,
[ 'John Ono Lennon' ]), ' name of john (scoped)');
ok (eq_set ([ $ms->instances ('scope') ] ,
[ 'tm:fullname', 'us' ]), ' fullname of john isa scope');
}
if (DONE) { # 3.3.7. Scoped Topic Name - Using Subject Itentifiers
my $ms = _parse (q|
%prefix ex http://blabla.org/
john - "John Ono Lennon" @ex:fullname.
|);
#warn Dumper $ms;
my $john = $ms->tids ( 'john' );
ok ($john, '3.3.7. Scoped Topic Name - Using Subject Itentifiers');
my $fn = $ms->tids (\ 'http://blabla.org/fullname');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->SCOPE] eq $fn }
grep { $_->[TM->TYPE] eq 'name' }
$ms->match_forall (char => 1, topic => $john) ] ,
[ 'John Ono Lennon' ]), ' name of john (scoped)');
ok (eq_set ([ $ms->instances ('scope') ] ,
[ $fn, 'us' ]), ' fullname of john isa scope');
}
if (DONE) { # 3.3.8. Multi Scoped Topic Name
eval {
my $ms = _parse (q|
%prefix ex http://blabla.org/
beatles
- "The Beatles";
- "Fab Four" @nickname short .
|);
}; like ($@, qr/unparseable/, 'multipled scopes NOT supported here');
}
if (DONE) { # 3.3.9. Typed and Scoped Names
my $ms = _parse (q|
john - fullname: "John Ono Lennon" @yoko.
|);
#warn Dumper $ms;
my $john = $ms->tids ( 'john' );
ok ($john, ' 3.3.9. Typed and Scoped Names');
is ($ms->toplets, $npt+3, ' additional');
is ($ms->asserts, $npa+3, ' additional');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->SCOPE] eq 'tm:yoko' }
grep { $_->[TM->TYPE] eq 'tm:fullname' }
$ms->match_forall (char => 1, topic => $john) ] ,
[ 'John Ono Lennon' ]), ' name of john (scoped)');
ok (eq_set ([ $ms->subclasses ('name') ] ,
[ 'tm:fullname' ]), ' fullname of john ako name');
ok (eq_set ([ $ms->instances ('scope') ] ,
[ 'tm:yoko', 'us' ]), ' fullname of john isa scope');
}
if (DONE) { # 3.3.10. Topic Name with Variant of datatype String
eval {
my $ms = _parse (q|
john - "John Lennon" ("lennon, john" @tm:sort).
|);
}; like ($@, qr/unparseable/, 'variants NOT supported here');
}
if (DONE) { # 3.3.11. Topic Name with Variant of datatype XML
eval {
my $ms = _parse (q|
john - "John Lennon"
( "<b>John Lennon</b>"^^xsd:anyType @markup).
|);
}; like ($@, qr/unparseable/, 'variants NOT supported here');
}
if (DONE) { # 3.3.12. Topic Name with Variant of datatype URI
eval {
my $ms = _parse (q|
john - "John Lennon" (http://link/to/an/image.jpg @image).
|);
}; like ($@, qr/unparseable/, 'variants NOT supported here');
}
if (DONE) { # 3.3.13. Topic Name with Variant with non-TMDM datatype
eval {
my $ms = _parse (q|
revolution-nine - "Revolution No. 9" (9 @number).
|);
}; like ($@, qr/unparseable/, 'variants NOT supported here');
}
if (DONE) { # template-simple
my $ms = _parse (q|
def template ()
topic.
topic2 .
created (person : mccartney, song : yesterday)
end
template()
|);
ok ($ms->mids ('topic'), 'template-simple');
ok ($ms->mids ('topic2'), ' 2. topic');
ok (eq_array ([ map { @{ $_->[TM->PLAYERS] } }
grep { $_->[TM->TYPE] eq 'tm:created' }
$ms->match_forall (iplayer => 'tm:yesterday') ],
[ 'tm:mccartney', 'tm:yesterday' ]), ' template-simple: players');
}
if (DONE) { # templates with parameters
my $ms = _parse (q|
def has-shoesize($person, $size)
$person
shoesize: $size.
end
has-shoesize (aaa, 42)
has-shoesize (bbb, 43)
|);
ok (1, 'template params');
ok ($ms->mids ('aaa'), ' aaa');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match_forall (char => 1, topic => $ms->tids ('aaa')) ] ,
[ '42' ]), ' shoesize aaa');
ok ($ms->mids ('bbb'), ' bbb');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match_forall (char => 1, topic => $ms->tids ('bbb')) ] ,
[ '43' ]), ' shoesize bbb');
is ($ms->toplets, $npt+3, ' additional');
is ($ms->asserts, $npa+3, ' additional');
}
if (DONE)
{
eval {
my $ms = _parse (q|
def template()
topic .
end
def template ()
topic2.
end
|);
}; like ($@, qr/template.*defined/, 'templates: double defed');
}
if (DONE)
{
eval {
my $ms = _parse (q|
def template ()
topic.
end
templtae()
|);
}; like ($@, qr/unparseable/, 'templates: undefed');
}
if (DONE)
{
eval {
my $ms = _parse (q|
def template ($a, $b)
topic.
end
template(23)
|);
}; like ($@, qr/too few/, 'templates: too few arguments');
}
if (DONE)
{
eval {
my $ms = _parse (q|
def template ($a, $b)
topic.
end
template(23, aaa, bbb)
|);
}; like ($@, qr/too many/, 'templates: too many arguments');
}
if (DONE)
{ #-- topic template invocation
my $ms = _parse (q|
def has-shoesize($person, $size)
$person
shoesize: $size.
end
def is-member-of($member, $group)
is-member-of(member: $member, group: $group)
end
http://psi.example.org/beatles/paul isa person;
has-shoesize(45);
is-member-of(the-beatles);
homepage: http://www.paulmccartney.com/ .
|);
ok (1, 'topic template invocation');
my $t = $ms->mids (\ 'http://psi.example.org/beatles/paul');
ok ($t, ' paul');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq 'tm:shoesize' }
$ms->match_forall (char => 1, topic => $ms->tids ($t)) ] ,
[ '45' ]), ' shoesize paul');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq 'tm:homepage' }
$ms->match_forall (char => 1, topic => $ms->tids ($t)) ] ,
[ 'http://www.paulmccartney.com/' ]), ' homepage paul');
ok (eq_array ([ map { @{ $_->[TM->PLAYERS] } }
grep { $_->[TM->TYPE] eq 'tm:is-member-of' }
$ms->match_forall (iplayer => $t) ],
[ 'tm:the-beatles', $t ]), ' players');
is ($ms->toplets, $npt+8, ' additional');
is ($ms->asserts, $npa+6, ' additional');
}
if (DONE) {
my $ms = _parse (q|
topic
occtype: "Occurrence" ~ [ - "reifier"].
|);
#warn Dumper $ms;
ok ($ms->mids ('topic'), 'embedding topic');
my @oc = $ms->match_forall (char => 1, topic => $ms->tids ('topic'));
is (scalar @oc, 1, ' only one occ');
is ($oc[0]->[TM->TYPE], 'tm:occtype', ' occtype');
my ($re) = $ms->is_reified ($oc[0]);
like ($re, qr/uuid-\d{10}/, ' generated topic');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match_forall (char => 1, topic => $re) ] ,
[ 'reifier' ]), ' name of reifier');
}
if (DONE) { # 3.4.2. Typed Occurrence of datatype String - Using Item Identifiers
my $ms = _parse (q|
a-day-in-the-life
lyrics: "I read ...".
|);
#warn Dumper $ms;
ok ('tm:a-day-in-the-life', ' 3.4.2. Typed Occurrence of datatype String - Using Item Identifiers');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq 'tm:lyrics' }
$ms->match_forall (char => 1, topic => 'tm:a-day-in-the-life') ] ,
[ 'I read ...' ]), ' occ types');
ok (eq_set ([ $ms->subclasses ('occurrence') ] ,
[ 'tm:lyrics' ]), ' lyrics ako occurrence');
}
if (DONE)
{ # 3.4.3. Typed Occurrence of datatype String - Using Subject Identifiers
my $ms = _parse (q|
%prefix ex http://www.blabla.org/
a-day-in-the-life
ex:lyrics: "I read ...".
|);
#warn Dumper $ms;
ok ('tm:a-day-in-the-life', ' 3.4.2. Typed Occurrence of datatype String - Using Item Identifiers');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq $ms->tids (\ 'http://www.blabla.org/lyrics') }
$ms->match_forall (char => 1, topic => 'tm:a-day-in-the-life') ] ,
[ 'I read ...' ]), ' occ types');
ok (eq_set ([ $ms->subclasses ('occurrence') ] ,
[ $ms->tids (\ 'http://www.blabla.org/lyrics') ]),
' lyrics ako occurrence');
}
if (DONE) { # 3.4.4. Scoped Occurrence of datatype String - Using Item Identifiers
my $ms = _parse (q|
a-day-in-the-life
lyrics: "I read ..." @en.
|);
#warn Dumper $ms;
ok ('tm:a-day-in-the-life', '3.4.4. Scoped Occurrence of datatype String - Using Item Identifiers');
is ($ms->toplets, $npt+3, ' additional');
is ($ms->asserts, $npa+3, ' additional');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->SCOPE] eq 'tm:en' }
grep { $_->[TM->TYPE] eq 'tm:lyrics' }
$ms->match_forall (char => 1, topic => 'tm:a-day-in-the-life') ] ,
[ 'I read ...' ]), ' occ types');
ok (eq_set ([ $ms->subclasses ('occurrence') ] ,
[ 'tm:lyrics' ]),
' lyrics ako occurrence');
ok (eq_set ([ $ms->instances ('scope') ] ,
[ 'tm:en', 'us' ]), ' en isa scope');
}
if (DONE) { # 3.4.5. Scoped Occurrence of datatype String - Using Subject Identifiers
my $ms = _parse (q|
%prefix ex http://bla.org/
%prefix lang http://language.org
a-day-in-the-life
ex:lyrics: "I read ..." @lang:en.
|);
#warn Dumper $ms;
ok ('tm:a-day-in-the-life', '3.4.4. Scoped Occurrence of datatype String - Using Item Identifiers');
is ($ms->toplets, $npt+3, ' additional');
is ($ms->asserts, $npa+3, ' additional');
ok (eq_set ([ map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->SCOPE] eq $ms->tids (\ 'http://language.orgen') }
grep { $_->[TM->TYPE] eq $ms->tids (\ 'http://bla.org/lyrics') }
$ms->match_forall (char => 1, topic => 'tm:a-day-in-the-life') ] ,
[ 'I read ...' ]), ' occ types');
ok (eq_set ([ $ms->subclasses ('occurrence') ] ,
[ $ms->tids (\ 'http://bla.org/lyrics') ]),
' lyrics ako occurrence');
ok (eq_set ([ $ms->instances ('scope') ] ,
[ $ms->tids (\ 'http://language.orgen'), 'us' ]), ' en isa scope');
}
if (DONE) { # 3.4.6. Occurrence of datatype XML
my $ms = _parse (q|
a-day-in-the-life
lyrics: """<html>
<head>[...]</head>
<body id="lyrics">[...]</body>
</html>"""^^xsd:anyType.
|);
#warn Dumper $ms;
ok ('tm:a-day-in-the-life', '3.4.6. Occurrence of datatype XML');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
# ok (eq_set ([ map { $_->[0] }
my ($v) = map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq 'tm:lyrics' }
$ms->match_forall (char => 1, topic => 'tm:a-day-in-the-life');
like ($v->[0], qr/<html>.*html>/s, ' XML value');
ok (eq_set ([ $ms->subclasses ('occurrence') ] ,
[ 'tm:lyrics' ]),
' lyrics ako occurrence');
}
if (DONE) { # 3.4.7. Occurrence of datatype IRI
my $ms = _parse (q|
beatles website: http://www.beatles.com/ .
|);
#warn Dumper $ms;
ok ('tm:beatles', '3.4.7. Occurrence of datatype IRI');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
my ($v) = map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq 'tm:website' }
$ms->match_forall (char => 1, topic => 'tm:beatles');
is ($v->[0], 'http://www.beatles.com/', ' value');
is ($v->[1], TM::Literal->URI, ' datatype');
ok (eq_set ([ $ms->subclasses ('occurrence') ] ,
[ 'tm:website' ]),
' website ako occurrence');
}
if (DONE) { # 3.4.7. Occurrence of datatype IRI, explict
my $ms = _parse (q|
beatles website: "http://www.beatles.com/"^^xsd:anyURI.
|);
#warn Dumper $ms;
ok ('tm:beatles', '3.4.7. Occurrence of datatype IRI, explicit');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
my ($v) = map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq 'tm:website' }
$ms->match_forall (char => 1, topic => 'tm:beatles');
is ($v->[0], 'http://www.beatles.com/', ' value');
is ($v->[1], TM::Literal->URI, ' datatype');
ok (eq_set ([ $ms->subclasses ('occurrence') ] ,
[ 'tm:website' ]),
' website ako occurrence');
}
if (DONE) { # 3.4.8. Occurrence of non-TMDM datatype
my $ms = _parse (q|
pennylane track-number: 2.
|);
#warn Dumper $ms;
ok ('tm:pennylane', '3.4.8. Occurrence of non-TMDM datatype');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
my ($v) = map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq 'tm:track-number' }
$ms->match_forall (char => 1, topic => 'tm:pennylane');
is ($v->[0], '2', ' value');
is ($v->[1], TM::Literal->INTEGER, ' datatype');
ok (eq_set ([ $ms->subclasses ('occurrence') ] ,
[ 'tm:track-number' ]),
' website ako occurrence');
}
if (DONE) { # 3.4.8. Occurrence of non-TMDM datatype, explicit
my $ms = _parse (q|
pennylane track-number: "2"^^xsd:integer.
|);
#warn Dumper $ms;
ok ('tm:pennylane', '3.4.8. Occurrence of non-TMDM datatype, explicit');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+2, ' additional');
my ($v) = map { $_->[TM->PLAYERS]->[1] }
grep { $_->[TM->TYPE] eq 'tm:track-number' }
$ms->match_forall (char => 1, topic => 'tm:pennylane');
is ($v->[0], '2', ' value');
is ($v->[1], TM::Literal->INTEGER, ' datatype');
ok (eq_set ([ $ms->subclasses ('occurrence') ] ,
[ 'tm:track-number' ]),
' website ako occurrence');
}
if (DONE) {
for (q|
created(person : mccartney, song : yesterday)
|,
q|
def created($creator, $song)
created(person : $creator, song : $song)
end
mccartney created(yesterday).
|,
q|
def created($creator, $song)
created(person : $creator, song : $song)
end
created(mccartney, yesterday)
|
) { # 3.5.1. Creating Associations
my $ms = _parse ($_);
#warn Dumper $ms;
ok ('tm:created', '3.5.1. Creating Associations');
ok ('tm:mcartney', '3.5.1. Creating Associations');
is ($ms->toplets, $npt+5, ' additional');
is ($ms->asserts, $npa+1, ' additional');
ok (eq_array ([ map { @{ $_->[TM->PLAYERS] } }
grep { $_->[TM->TYPE] eq 'tm:created' }
$ms->match_forall (iplayer => 'tm:yesterday') ],
[ 'tm:mccartney', 'tm:yesterday' ]), ' players');
}
}
if (DONE) { # 3.5.2. Scoped Association
my $ms = _parse (q|
created(person : mccartney, song : yesterday) @music
|);
#warn Dumper $ms;
ok ('tm:created', '3.5.2. Scoped Association');
ok ('tm:mcartney', '3.5.2. Scoped Association');
is ($ms->toplets, $npt+6, ' additional');
is ($ms->asserts, $npa+2, ' additional');
ok (eq_array ([ map { @{ $_->[TM->PLAYERS] } }
grep { $_->[TM->SCOPE] eq 'tm:music' }
grep { $_->[TM->TYPE] eq 'tm:created' }
$ms->match_forall (iplayer => 'tm:yesterday') ],
[ 'tm:mccartney', 'tm:yesterday' ]), ' players');
ok (eq_set ([ $ms->instances ('scope') ] ,
[ 'tm:music', 'us' ]), ' music isa scope');
}
if (DONE) { # 3.5.5. Supertype-Subtype relationship - Using Item Identifiers
my $ms = _parse (q|
song ako musical-work.
|);
#warn Dumper $ms;
ok ('tm:song', '3.5.5. Supertype-Subtype relationship - Using Item Identifiers');
ok ('tm:musical-work', '3.5.5. Supertype-Subtype relationship - Using Item Identifiers');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+1, ' additional');
ok (eq_set ([ $ms->subclasses ('tm:musical-work') ] ,
[ 'tm:song' ]), ' ako');
}
if (DONE) { # 3.5.6. Supertype-Subtype relationship - Using Subject Identifiers
my $ms = _parse (q|
%prefix ex http://something/
ex:song ako ex:musical-work.
|);
#warn Dumper $ms;
my $song = $ms->tids (\ 'http://something/song');
my $work = $ms->tids (\ 'http://something/musical-work');
ok ($song, '3.5.6. Supertype-Subtype relationship - Using Subject Identifiers');
ok ($work, '3.5.6. Supertype-Subtype relationship - Using Subject Identifiers');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+1, ' additional');
ok (eq_set ([ $ms->subclasses ($work) ] ,
[ $song ]), ' ako');
}
if (DONE) { # 3.6.1 Reification of a Topic Map
TODO: {
local $TODO = "reification of map";
eval {
my $ms = _parse (q|
~ [- "Beatlestopicmap"]
|);
};
ok (0);
}
}
if (DONE) { # 3.6.2. Reification of a Topic Name
my $ms = _parse (q|
john - "John Ono Lennon" ~ name-of-john-lennon.
|);
#warn Dumper $ms;
ok ($ms->tids ('john'), '3.6.2. Reification of a Topic Name');
ok ($ms->tids ('name-of-john-lennon'), '3.6.2. Reification of a Topic Name');
is ($ms->toplets, $npt+2, ' additional');
is ($ms->asserts, $npa+1, ' additional');
my $a = $ms->reifies ('tm:name-of-john-lennon');
is ($a->[TM->KIND], TM->NAME, ' reified name');
is (($ms->is_reified ($a))[0], 'tm:name-of-john-lennon', ' reifying topic');
}
if (DONE) { # 3.6.3. Reification of a Variant
TODO: {
local $TODO = "reification of variant";
eval {
my $ms = _parse (q|
john - "John Ono Lennon"
("lennon, john" @sort ~ sortname-of-john-lennon).
|);
};
ok (0);
}
}
if (DONE) { # 3.6.4. Reification of a Occurrence
my $ms = _parse (q|
john website: http://www.lennon.com/ ~ lennons-website.
|);
#warn Dumper $ms;
ok ($ms->tids ('john'), '3.6.4. Reification of a Occurrence');
ok ($ms->tids ('lennons-website'), '3.6.4. Reification of a Occurrence');
is ($ms->toplets, $npt+3, ' additional');
is ($ms->asserts, $npa+2, ' additional');
my $a = $ms->reifies ('tm:lennons-website');
is ($a->[TM->KIND], TM->OCC, ' reified occ');
is (($ms->is_reified ($a))[0], 'tm:lennons-website', ' reifying topic');
}
for (q|
partnership(person: lennon, person: mc-cartney) ~ lennon-mccartney
lennon-mccartney - "Lennon / McCartney".
|,
#q|
# partnership(person: lennon, person: mc-cartney) ~ [- "Lennon / McCartney"]
#|
) {
if (DONE) { # 3.6.5. Reification of an Association
my $ms = _parse ($_);
#warn Dumper $ms;
ok ($ms->tids ('lennon-mccartney'), '3.6.5. Reification of an Association');
is ($ms->toplets, $npt+5, ' additional');
is ($ms->asserts, $npa+2, ' additional');
my $a = $ms->reifies ('tm:lennon-mccartney');
is ($a->[TM->KIND], TM->ASSOC, ' reified assoc');
is (($ms->is_reified ($a))[0], 'tm:lennon-mccartney', ' reifying topic');
}
}
if (DONE)
{ # (anonymous) wildcard
my $ms = _parse (q|
?xxx
- "James Bond" .
?xxx = http://topic.one/
website: http://www.lennon.com/ .
?yyy = http://topic.two/
- "John Lennon" .
? = http://topic.three/
website: http://www.lennon3.com/ .
? = http://topic.four/
website: http://www.lennon4.com/ .
?yyy
website: http://www.lennon2.com/ .
?xxx
website: http://www.lennon1.com/ .
|);
#warn Dumper $ms;
my $one = $ms->tids('http://topic.one/');
like ($one, qr/uuid-\d{10}/, 'named wildcard');
ok (eq_set([
map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
$ms->match_forall (char => 1, topic => $one)
],
[
'James Bond',
'http://www.lennon.com/',
'http://www.lennon1.com/'
]), ' one chars');
my $two = $ms->tids('http://topic.two/');
like ($two, qr/uuid-\d{10}/, 'named wildcard');
ok (eq_set([
map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
$ms->match_forall (char => 1, topic => $two)
],
[
'John Lennon',
'http://www.lennon2.com/'
]), ' two chars');
my $thr = $ms->tids('http://topic.three/');
like ($thr, qr/uuid-\d{10}/, 'named wildcard');
ok (eq_set([
map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
$ms->match_forall (char => 1, topic => $thr)
],
[
'http://www.lennon3.com/'
]), ' thr chars');
my $fou = $ms->tids('http://topic.four/');
like ($fou, qr/uuid-\d{10}/, 'named wildcard');
ok (eq_set([
map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
$ms->match_forall (char => 1, topic => $fou)
],
[
'http://www.lennon4.com/'
]), ' fou chars');
is ($ms->toplets, $npt+5, ' additional');
is ($ms->asserts, $npa+8, ' additional');
}
if (DONE)
{ # (anonymous) wildcard
my $ms = _parse (q|
?xxx = http://topic.one/
- "James Bond" .
def TEMP ($l)
?yyy = http://topic.two/
website: $l .
?yyy
website: http://www.lennon3.com/ .
end
?xxx
website: http://www.lennon1.com/ .
TEMP ("http://www.lennon2.com/")
?yyy http://topic.three/
website: http://www.lennon4.com/ .
def TEMP2 ($l)
?yyy = http://topic.four/
website: $l .
?yyy
website: http://www.lennon5.com/ .
end
TEMP2 ("http://www.lennon4.com/")
|);
#warn Dumper $ms;
my $one = $ms->tids('http://topic.one/');
like ($one, qr/uuid-\d{10}/, 'named wildcard in template');
ok (eq_set([
map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
$ms->match_forall (char => 1, topic => $one)
],
[
'James Bond',
'http://www.lennon1.com/'
]), ' one chars');
my $two = $ms->tids('http://topic.two/');
like ($two, qr/uuid-\d{10}/, ' instantiated topic');
ok (eq_set([
map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
$ms->match_forall (char => 1, topic => $two)
],
[
'http://www.lennon2.com/',
'http://www.lennon3.com/',
# 'http://www.lennon4.com/'
]), ' two chars');
my $thr = $ms->tids( \ 'http://topic.three/');
isnt ($thr, $two, ' wildcarded different');
like ($thr, qr/uuid-\d{10}/, ' instantiated topic');
ok (eq_set([
map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
$ms->match_forall (char => 1, topic => $thr)
],
[
'http://www.lennon4.com/',
]), ' thr chars');
my $fou = $ms->tids( 'http://topic.four/');
isnt ($fou, $two, ' wildcarded different');
isnt ($fou, $thr, ' wildcarded different');
like ($fou, qr/uuid-\d{10}/, ' instantiated topic');
ok (eq_set([
map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] }
$ms->match_forall (char => 1, topic => $fou)
],
[
'http://www.lennon4.com/',
'http://www.lennon5.com/',
]), ' fou chars');
is ($ms->toplets, $npt+5, ' additional');
is ($ms->asserts, $npa+8, ' additional');
}
if (DONE)
{
my $ms = _parse (q|
xxx .
%include inline:aaa .
yyy .
|);
#warn Dumper $ms;
ok ($ms->tids('xxx'), 'include: topics');
ok ($ms->tids('aaa'), 'include: topics');
ok ($ms->tids('yyy'), 'include: topics');
}
__END__
3.7.1. Singe line comment
-------------------------
::ctm
# a single line with comments
3.7.2. Multiline comment
------------------------
::ctm
#( one comment
line 2
)#
map reify
wildcard
__END__
require_ok( 'TM::Materialized::LTM' );
{
my $tm = new TM::Materialized::LTM (inline => '
');
ok ($tm->isa('TM::Materialized::Stream'), 'correct class');
ok ($tm->isa('TM::Materialized::LTM'), 'correct class');
}
{ # comments
my $ms = _parse (q|
[ aaa ]
/* some comment [ bbb ]
*/
[ ccc ]
|);
#warn Dumper $ms;
ok ($ms->tids ('aaa'), 'comment: outside');
ok (!$ms->tids ('bbb'), 'comment: inside');
ok ($ms->tids ('ccc'), 'comment: outside');
}
die_ok (q{
/* [ aaa ]
*/ */
}, 'unparseable', 'invalid comment nesting');
{ # encoding
my $ms = _parse (q|
@"utf-8"
[ aaa ]
|);
ok (1, 'encoding: ignored');
}
{ # topic address
my $ms = _parse (q|
[aaa % "urn:aaa" ]
|);
# warn Dumper $ms;
is ($ms->tids ('aaa'), $ms->tids ('urn:aaa'), 'reification: subject identifier ok');
}
{ # subject indicators
my $ms = _parse (q|
[aaa % "urn:aaa" @ "urn:xxx" @ "urn:yyy" ]
|);
# warn Dumper $ms;
ok (eq_set ($ms->midlet ($ms->tids ('urn:aaa'))->[TM->INDICATORS],
[ 'urn:xxx', 'urn:yyy' ]), 'indication: all found');
}
{ # topics types
my $ms = _parse (q|
[aaa: bbb ccc ]
|);
#warn Dumper $ms;
my @res = $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:aaa');
ok (eq_set ([ map { $_->[TM->PLAYERS]->[0] } @res ],
[ 'tm:bbb', 'tm:ccc' ]), 'topic: class values');
}
{ # topic basename
my $ms = _parse (q|
[aaa: bbb ccc = "AAA" ]
|);
#warn Dumper $ms;
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'name', iplayer => 'tm:aaa' ) ] ,
[ 'AAA' ]), 'topic: AAA basename');
}
{ # topic scoped basename
my $ms = _parse (q|
[aaa: bbb ccc = "AAAS" / sss ]
|);
#warn Dumper $ms;
ok (eq_set ([ map {$_->[0]} map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, scope => 'tm:sss', type => 'name', iplayer => 'tm:aaa' ) ] ,
[ 'AAAS' ]), 'topic: AAA basename (scoped)');
ok (scalar $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:sss' ) == 1, 'scope isa scope');
}
{ # topic, basename, sortname
my $ms = _parse (q|
[aaa: bbb ccc = "AAA" ; "SORTAAA" ]
[xxx: yyy = "XXX"; "SORTXXX"; "DISPXXX" ]
[uuu = "UUU"; "SORTUUU"; "DISPUUU" ]
[vvv = "VVV"; "SORTVVV"; "DISPVVV" / sss ]
|);
#warn Dumper $ms;
ok (eq_set ([ map {$_->[0]} map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'name', iplayer => 'tm:aaa' ) ] ,
[ 'AAA' ]), 'topic: AAA basename');
# ok (eq_set ([ map {$_->[0]} map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'name', iplayer => 'tm:aaa' ) ] ,
# [ 'SORTAAA' ]), 'topic: SORTAAA basename');
}
{ # topic external occurrence (typed)
my $ms = _parse (q|
{aaa, bbb, "http://xxxt/" }
|);
#warn Dumper $ms;
ok (eq_set ([ map {$_->[0]} map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'tm:bbb', iplayer => 'tm:aaa' ) ] ,
[ 'http://xxxt/' ]), 'topic: occurr typed');
ok (eq_set ([ map {$_->[0]} map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'occurrence', iplayer => 'tm:aaa' ) ] ,
[ 'http://xxxt/' ]), 'topic: occurr (typed)');
}
# untyped is not allowed in LTM?
{ # topic internal occurrence
my $ms = _parse (q|
{aaa, bbb, [[http://xxxt/]] }
|);
#warn Dumper $ms;
ok (eq_set ([ map {$_->[0]} map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'tm:bbb', iplayer => 'tm:aaa' ) ] ,
[ 'http://xxxt/' ]), 'topic: int occurr typed');
ok (eq_set ([ map {$_->[0]} map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'occurrence', iplayer => 'tm:aaa' ) ] ,
[ 'http://xxxt/' ]), 'topic: int occurr (typed)');
}
{ # mix occurrences with topics
my $ms = _parse (q|
[ aaa : bbb ]
{ aaa, xxx, "http://xxx/" }
{ ccc, yyy, "http://yyy/" }
[ ccc : ddd ]
|);
#warn Dumper $ms;
ok (scalar $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:aaa' ) == 1, 'topic+occur: class');
ok (scalar $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:ccc' ) == 1, 'topic+occur: class');
ok (eq_set ([ map {$_->[0]} map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'occurrence', iplayer => 'tm:aaa' ) ] ,
[ 'http://xxx/' ]), 'topic+occur: occurr');
ok (eq_set ([ map {$_->[0]} map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'occurrence', iplayer => 'tm:ccc' ) ] ,
[ 'http://yyy/' ]), 'topic+occur: occurr');
}
#-- assocs --------------
{
my $ms = _parse (q|
aaa (play1: role1, play2: role2)
bbb (play1: role1, play2: role2)
ccc (play1, play2: role2)
|);
#warn Dumper $ms;
my @res = $ms->match (TM->FORALL, type => 'tm:aaa');
ok (eq_set ([ map { @{$_->[TM->PLAYERS]} } @res ],
[ 'tm:play1', 'tm:play2' ]), 'assoc: players');
ok (eq_set ([ map { @{$_->[TM->ROLES]} } @res ],
[ 'tm:role1', 'tm:role2' ]), 'assoc: roles');
@res = $ms->match (TM->FORALL, type => 'tm:bbb');
ok (scalar @res == 1, 'assoc: separate');
@res = $ms->match (TM->FORALL, type => 'tm:ccc');
ok (eq_set ([ map { @{$_->[TM->PLAYERS]} } @res ],
[ 'tm:play1', 'tm:play2' ]), 'assoc: players');
ok (eq_set ([ map { @{$_->[TM->ROLES]} } @res ],
[ 'thing', 'tm:role2' ]), 'assoc: roles (default)');
}
{ # scoped assoc
my $ms = _parse (q|
aaa (play1: role1, play2: role2) / sss
aaa (play1: role1, play2: role2)
aaa (play1: role1, play2: role2) / ttt
|);
##warn Dumper $ms;
my @res = $ms->match (TM->FORALL, type => 'tm:aaa');
ok (scalar @res == 3, 'scoped mixed assoc: number');
ok (grep ($_->[TM->SCOPE] eq 'tm:ttt', @res), 'scoped mixed assoc: scoping');
ok (grep ($_->[TM->SCOPE] eq 'tm:sss', @res), 'scoped mixed assoc: scoping');
ok (grep ($_->[TM->SCOPE] eq 'us', @res), 'scoped mixed assoc: scoping');
foreach my $r (@res) {
ok (eq_set ([ @{$r->[TM->PLAYERS]} ],
[ 'tm:play1', 'tm:play2' ]), 'scoped mixed assoc: players');
ok (eq_set ([ @{$r->[TM->ROLES]} ],
[ 'tm:role1', 'tm:role2' ]), 'scoped mixed assoc: roles');
}
}
{ # assoc with nested topic
my $ms = _parse (q|
aaa ( [ play1: ccc ]: role1, play2: role2)
|);
#warn Dumper $ms;
my @res = $ms->match (TM->FORALL, type => 'tm:aaa');
ok (eq_set ([ map { @{$_->[TM->PLAYERS]} } @res ],
[ 'tm:play1', 'tm:play2' ]), 'assoc + embed: players');
ok (eq_set ([ map { @{$_->[TM->ROLES]} } @res ],
[ 'tm:role1', 'tm:role2' ]), 'assoc + embed: roles');
@res = $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:play1');
ok (eq_set ([ map { @{$_->[TM->PLAYERS]} } @res ],
[ 'tm:play1', 'tm:ccc' ]), 'assoc + embed: types');
}
# reifications
{ # reified assocs
my $ms = _parse (q|
aaa ( play1: role1, play2: role2) ~ xxx
|);
#warn Dumper $ms;
my ($a) = $ms->match (TM->FORALL, type => 'tm:aaa');
is ($a->[TM->LID], $ms->midlet ('tm:xxx')->[TM->ADDRESS], 'assoc reification');
}
{ # reified occurrence
my $ms = _parse (q|
{aaa, bbb, "http://xxxt/" } ~ xxx
|);
#warn Dumper $ms;
my ($a) = $ms->match (TM->FORALL, type => 'tm:bbb');
is ($a->[TM->LID], $ms->midlet ('tm:xxx')->[TM->ADDRESS], 'occurrence reification');
}
{ # reified basename
my $ms = _parse (q|
[ aaa = "AAA" ~ xxx ]
|);
#warn Dumper $ms;
my ($a) = $ms->match (TM->FORALL, type => 'name');
is ($a->[TM->LID], $ms->midlet ('tm:xxx')->[TM->ADDRESS], 'basename reification');
}
#== Directives ========================
{ # wrong VERSION format
die_ok (q|
#VERSION "123"
|, 'not supported');
}
{ # wrong VERSION
die_ok (q|
#VERSION "1.4"
|, 'not supported');
}
{ # VERSION
my $ms = _parse (q|
#VERSION "1.3"
[ aaa ]
|);
ok (1, 'version supported');
}
{ # TOPICMAP
die_ok (q|
#TOPICMAP ~ xxxx
|, 'use proper');
}
{ # INCLUDE
die_ok (q|
[aaa]
#INCLUDE "xyz:abc"
|, 'unable to load');
}
{ # INCLUDE
my $ms = _parse (q|
[ aaa ]
#INCLUDE "inline: [ bbb ]"
[ ccc ]
|);
# warn Dumper $ms;
ok ($ms->midlet ('tm:aaa'), 'include: topic');
ok ($ms->midlet ('tm:bbb'), 'include: topic');
ok ($ms->midlet ('tm:ccc'), 'include: topic');
}
{
die_ok (q|
aa:uuu (bbb:play: bbb:role)
|, 'unparseable');
}
{ # PREFIXES
my $ms = _parse (q|
#PREFIX aaa @ "http://xxxx/#"
#PREFIX bbb @ "http://yyyy/#"
aaa:uuu (play: bbb:role)
|);
# warn Dumper $ms;
my @res = $ms->match (TM->FORALL, type => $ms->tids ('http://xxxx/#uuu'));
ok (scalar @res == 1, 'prefixed assoc name: found');
ok (eq_set ([ map { @{$_->[TM->PLAYERS]} } @res ],
[ 'tm:play' ]), 'unprefixed player name');
my $id = $ms->tids ('http://yyyy/#role');
ok (eq_set ([ map { @{$_->[TM->ROLES]} } @res ],
[ $id ]), 'prefixed role name');
}
die_ok (q{
#MERGEMAP "inline: [ bbb ]" "rumsti"
}, 'unsupported', 'invalid TM format');
{ # MERGEMAP
my $ms = _parse (q|
#MERGEMAP "inline: [ bbb ]" "ltm"
[ aaa ]
[ ccc ]
|);
# warn Dumper $ms;
TODO: {
local $TODO = "merging";
ok ($ms->tids ('aaa'), 'merge: topic');
ok ($ms->tids ('bbb'), 'merge: topic');
ok ($ms->tids ('ccc'), 'merge: topic');
}
}
{ # MERGEMAP (default
my $ms = _parse (q|
#MERGEMAP "inline: [ bbb ]"
[ aaa ]
[ ccc ]
|);
# warn Dumper $ms;
TODO: {
local $TODO = "merging (default)";
ok ($ms->tids ('aaa'), 'merge: topic');
ok ($ms->tids ('bbb'), 'merge: topic');
ok ($ms->tids ('ccc'), 'merge: topic');
}
}
__END__
__END__
die_ok (q{
format-for ([ ltm ] : standard, topic-maps )
@"abssfsdf"
}, 1, 'invalid encoding');
$tm = new XTM (tie => new XTM::LTM ( text => q{
@"iso8859-1"
{ ltm , test , [[Ich chan Glaas ässe, das tuet mir nöd weeh]] }
}));
like ($tm->topic ('ltm')->occurrences->[0]->resource->data, qr/\x{E4}sse/, 'encoding from iso8859-1');
die_ok (q{
format-for ([ ltm ] : standard, topic-maps )
xxxx
{ ltm , test , "http://rumsti/" }
}, 1, 'unknown keyword');
die_ok (q{
format-for ([ ltm ] : standard, topic-maps
}, 1, 'missing terminator 1');
die_ok (q{
[ ltm : format <= "The linear topic map notation" @ "http://something1/" @ "http://something2/" ]
}, 1, 'invalid terminator 1');
die_ok ('
{ ltm , test , "http://rumsti/" '
, 1, 'missing terminator 2');
die_ok ('
{ ltm , test , "http://rumsti/" } abc'
, 1, 'additional nonparsable text');
$tm = new XTM (tie => new XTM::LTM ( text => q{
[ ltm ]
{ ltm , test , [[http://rumsti/
ramsti romsti ]] }
}));
is (@{$tm->topics('occurrence regexps /rumsti/')}, 1, 'occurrence with topic');
is (@{$tm->topics('occurrence regexps /romsti/')}, 1, 'occurrence with topic, multiline');
#print Dumper $tm;
$tm = new XTM (tie => new XTM::LTM ( text => q{
[ ltm ]
{ ltm , test , "http://rumsti/" }
}));
is (@{$tm->topics('occurrence regexps /rumsti/')}, 1, 'occurrence with topic');
is (@{$tm->topics()}, 2, 'occurrence with topic, 2');
#print Dumper $tm;
$tm = new XTM (tie => new XTM::LTM ( text => q{
{ ltm , test , "http://rumsti/" }
{ ltm , test2 , "http://ramsti/" }
{ ltm2, test , "http://rumsti/" }
}));
is (@{$tm->topics('occurrence regexps /rumsti/')}, 2, 'occurrence wo topic');
$tm = new XTM (tie => new XTM::LTM ( text => q{
[ ltm : format = "The linear topic map notation" @ "http://something1/" @ "http://something2/" ]
}));
is (@{$tm->topics('indicates regexps /something1/')}, 1, 'subject indication1');
is (@{$tm->topics('indicates regexps /something2/')}, 1, 'subject indication2');
$tm = new XTM (tie => new XTM::LTM ( text => q{
[ ltm : format = "The linear topic map notation" % "http://something/" ]
}));
is (@{$tm->topics('reifies regexps /something/')}, 1, 'subject reification');
#__END__
$tm = new XTM (tie => new XTM::LTM ( text => q{
[ ltm : format = "The linear topic map notation" ]
}));
is (@{$tm->topics('baseName regexps /linear/')}, 1, 'basename wo scope');
$tm = new XTM (tie => new XTM::LTM ( text => q{
[ ltm : format = "The linear topic map notation / scope1" ]
}));
is (@{$tm->topics('baseName regexps /linear/')}, 1, 'basename with scope');
#__END__
# with types
my @types = qw(format1 format2 format3);
$tm = new XTM (tie => new XTM::LTM ( text => q{
[ ltm : }.join (" ", @types).q{ ]
}));
is (@{$tm->topics()}, 4, 'topic with types');
foreach my $t (@types) {
is (@{$tm->topics("is-a $t")}, 1, "finding $t");
}
__END__
use strict;
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More qw(no_plan);
use Data::Dumper;
$Data::Dumper::Indent = 1;
sub _chomp {
my $s = shift;
chomp $s;
return $s;
}
use TM;
use TM::PSI;
ok (1);
__END__
sub _parse {
my $text = shift;
my $ms = new TM (baseuri => 'tm:');
my $p = new TM::AsTMa::Fact (store => $ms);
my $i = $p->parse ("$text\n");
return $ms;
}
sub _q_players {
my $ms = shift;
# my @res = $ms->match (TM->FORALL, @_);
# warn "res no filter ".Dumper \@res;
my @res = grep ($_ !~ m|^tm:|, map { ref($_) ? $_->[0] : $_ } map { @{$_->[TM->PLAYERS]} } $ms->match (TM->FORALL, @_));
# warn "res ".Dumper \@res;
return \@res;
}
##===================================================================================
#== TESTS ===========================================================================
require_ok( 'TM::AsTMa::Fact' );
{ # class ok
my $p = new TM::AsTMa::Fact;
ok (ref($p) eq 'TM::AsTMa::Fact', 'class ok');
}
{ #-- structural
my $ms = _parse ('aaa (bbb)
ccc (bbb)
');
#warn Dumper $ms; exit;
is (scalar $ms->match_forall (type => 'isa', irole => 'class', iplayer => 'tm:bbb'), 2, 'two types for bbb');
ok (eq_array ([
$ms->mids ('aaa', 'bbb', 'ccc')
],
[
'tm:aaa', 'tm:bbb', 'tm:ccc'
]), 'aaa, bbb, ccc internalized');
}
{ #-- structural
my $ms = _parse ('aaa (bbb)
');
#warn Dumper $ms;
is (scalar $ms->match (TM->FORALL, type => 'isa', arole => 'instance', aplayer => 'tm:aaa',
brole => 'class', bplayer => 'tm:bbb'), 1, 'one type for aaa');
ok (eq_array ([
$ms->mids ('aaa', 'bbb')
],
[
'tm:aaa', 'tm:bbb'
]), 'aaa, bbb internalized');
}
{
my $ms = _parse ('aaa
');
#warn Dumper $ms;
is ($ms->mids ('aaa'), 'tm:aaa', 'aaa implicitely internalized');
}
{ # structural topic
my $ms = _parse (q|
aaa is-a bbb
bn: AAA
oc: http://BBB
in: blabla bla
|);
#warn Dumper $ms;
is (scalar $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:aaa' ), 1, 'one type for aaa');
is (scalar $ms->match (TM->FORALL, irole => 'thing', iplayer => 'tm:aaa' ), 4, 'chars for aaa');
is (scalar $ms->match (TM->FORALL, type => 'name', irole => 'thing', iplayer => 'tm:aaa' ), 1, 'basenames for aaa');
is (scalar $ms->match (TM->FORALL, type => 'occurrence', irole => 'thing', iplayer => 'tm:aaa' ), 2, 'occurrences for aaa 1');
}
#-- syntactic issues ----------------------------------------------------------------
my $npa = scalar keys %{$TM::infrastructure->{assertions}};
my $npt = scalar keys %{$TM::infrastructure->{mid2iid}};
{
my $ms = _parse (q|
# this is AsTMa
|);
#warn Dumper $ms;
is (scalar $ms->match(), $npa, 'empty map 1 (assertions)');
is ($ms->toplets, $npt, 'empty map 2 (toplets)');
}
{ # empty line with blanks
my $ms = _parse (q|
topic1
topic2
|);
##warn Dumper $ms;
is (scalar $ms->toplets(), $npt+2, 'empty line contains blanks');
}
{ # empty lines with \r
my $ms = _parse (q|
topic1
topic2
topic3
|);
is (scalar $ms->toplets(), $npt+3, 'empty line \r contains blanks');
}
{ # using TABs as separators
my $ms = _parse (q|
topic1 ( topic2 )
# comment
|);
#warn Dumper $ms;
is (scalar $ms->toplets, $npt+2, 'using TABs as separators');
}
{
my $ms = _parse (q|
# comment1
aaa (bbbbb cccc dddd)
#comment2
#comment4
ccc (bbb)
#comment3
#comment4
ddd (xxxx)
#comment5
|);
##warn Dumper $ms;
is (scalar $ms->toplets, $npt+8, 'test comment/separation');
is (scalar $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:aaa' ), 3, 'types for aaa');
is (scalar $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:ccc' ), 1, 'type for ccc');
is (scalar $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:ddd' ), 1, 'type for ddd');
}
{ # line continuation with comments
my $ms = _parse (q|
topic1
# comment \
topic2
|);
is (scalar $ms->toplets, $npt+1, 'continuation in comment');
}
{ # line continuation with comments
my $ms = _parse (q|
topic1
# comment \
topic2
|);
is (scalar $ms->toplets, $npt+2, 'continuation in comment, not 1');
}
{ # line continuation with comments
my $ms = _parse (q|
topic1
# comment \
topic2
|);
is (scalar $ms->toplets, $npt+2, 'continuation in comment, not 2');
}
{ # line continuation
my $ms = _parse (q|
aaa (bbbbb \
cccc \
dddd)
|
);
is (scalar $ms->toplets, $npt+4, 'line continuation');
is (scalar $ms->match (TM->FORALL, type => 'isa', irole => 'instance', iplayer => 'tm:aaa' ), 3, 'types for aaa');
}
{ # line continuation, not
my $ms = _parse (q|
aaa
bn: AAA
in: a \ within the text is ok
in: also one with a \\ followed by a blank: \\
in: this is a new one \\
in: this is not a new one
|);
##warn Dumper $ms;
my @res = $ms->match (TM->FORALL, type => 'occurrence', irole => 'thing', iplayer => 'tm:aaa' );
is (scalar @res, 3, 'ins for aaa');
##warn Dumper \@res;
##warn Dumper [ map { ${$_->[TM->PLAYERS]->[1]}} @res ];
ok (eq_set ([
map { $_->[0] }
map { $_->[TM->PLAYERS]->[1] } @res ],
[ 'a \ within the text is ok',
'also one with a \ followed by a blank: \\', # blank is gone now
'this is a new one in: this is not a new one']), 'same text');
}
{ # line continuation, not \\
my $ms = _parse (q|
aaa (bbbb \
) # this is a continuation
bn: but not this \\\\
in: should be separate
|
);
##warn Dumper $ms;
is (scalar $ms->match, $npa+3, 'line continuation, =3');
}
{ # string detection
my $ms = _parse (q|
aaa
in: AAA
bbb
in: <<<
xxxxxxxxxxxxx
yyyyyyyyyy
zzzzzz
<<<
ccc
in: <<EOM
rumsti
ramsti
romsti
<<EOM
|);
## warn Dumper $ms;
is (scalar $ms->match, $npa+3, 'string detection');
my @res = $ms->match (TM->FORALL, type => 'occurrence', irole => 'thing', iplayer => 'tm:bbb' );
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } @res ],
[ 'xxxxxxxxxxxxx
yyyyyyyyyy
zzzzzz',
]), 'same text [<<<]');
@res = $ms->match (TM->FORALL, type => 'occurrence', irole => 'thing', iplayer => 'tm:ccc' );
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } @res ],
[ 'rumsti
ramsti
romsti',
]), 'same text [<<EOM]');
}
#-- line separation -----------------------------------------------
{ # line separation
my $ms = _parse (q|
aaa (bbb) ~ bn: AAA ~ in: rumsti
ccc (ddd) ~ bn: CCC
|);
## warn Dumper $ms;
is (scalar $ms->match, $npa+5, '~ separation: assertion');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'name', iplayer => 'tm:aaa' ) ] ,
[ 'AAA' ]), '~ separation: AAA basename');
}
{ # line no separation
my $ms = _parse (q|
aaa (bbb) ~ bn: AAA ~ in: rumsti is using ~~ in: text
|);
## warn Dumper $ms;
is (scalar $ms->match, $npa+3, '~~ no-separation: assertions');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'occurrence', iplayer => 'tm:aaa' ) ] ,
[ 'rumsti is using ~ in: text' ]), 'getting back ~ text');
}
{ # inline comments
my $ms = _parse (q|
aaa
bn: AAA # comment
bn: AAA# no-comment
oc: http://rumsti#no-comment
|);
## warn Dumper $ms;
is (scalar $ms->match, $npa+3, 'comment + assertions');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'name', iplayer => 'tm:aaa' ) ] ,
[ 'AAA',
'AAA# no-comment' ]), 'getting back commented basename');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'occurrence', iplayer => 'tm:aaa' ) ] ,
[ 'http://rumsti#no-comment' ]), 'getting back commented occ');
}
#-- structural: assocs ----------------------------------------------------------
{
my $ms = _parse (q|
(xxx)
role : player
|);
##warn Dumper $ms;
is (scalar $ms->match, $npa+1, 'basic association');
is (scalar $ms->match (TM->FORALL, iplayer => 'tm:player' ), 1, 'finding basic association 1');
is (scalar $ms->match (TM->FORALL, type => 'tm:xxx', iplayer => 'tm:player' ), 1, 'finding basic association 2');
is (scalar $ms->match (TM->FORALL, type => 'tm:xxx', irole => 'tm:role', iplayer => 'tm:player' ), 1, 'finding basic association 3');
}
{
my $ms = _parse (q|
(xxx)
role : p1 p2 p3
|);
## warn Dumper $ms;
is (scalar $ms->match, $npa+1, 'basic association');
is (scalar $ms->match (TM->FORALL, iplayer => 'tm:p1' ), 1, 'finding basic association 4');
is (scalar $ms->match (TM->FORALL, type => 'tm:xxx', iplayer => 'tm:p2' ), 1, 'finding basic association 5');
is (scalar $ms->match (TM->FORALL, type => 'tm:xxx', irole => 'tm:role', iplayer => 'tm:p3' ), 1, 'finding basic association 6');
}
{
my $ms = _parse (q|
(xxx)
role : aaa bbb
(xxx)
role : aaa
|);
## warn Dumper $ms;
is (scalar $ms->match, $npa+2, 'basic association');
is (scalar $ms->match (TM->FORALL, iplayer => 'tm:aaa' ), 2, 'finding basic association 7');
is (scalar $ms->match (TM->FORALL, type => 'tm:xxx', iplayer => 'tm:bbb' ), 1, 'finding basic association 8');
}
{
my $ms = _parse (q|
(xxx)
role1 : aaa bbb
role2 : ccc
|);
##warn Dumper $ms;
is (scalar $ms->match, $npa+1, 'basic association');
is (scalar $ms->match (TM->FORALL, iplayer => 'tm:aaa' ), 1, 'finding basic association 10');
is (scalar $ms->match (TM->FORALL, type => 'tm:xxx', iplayer => 'tm:ccc' ), 1, 'finding basic association 11');
is (scalar $ms->match (TM->FORALL, type => 'tm:xxx', irole => 'tm:role2', iplayer => 'tm:ccc' ), 1, 'finding basic association 12');
}
{
my $ms = _parse (q|
(aaa) @ sss
role : player
|);
#warn Dumper $ms;
# ok ($ms->is_subclass ('aaa', 'association'), 'association: subclassed');
# is (scalar $ms->match (TM->FORALL, type=> 'isa', iplayer => 'tm:sss' ), 1, 'association scoped 1');
is (scalar $ms->match, $npa+2, 'association scoped');
is (scalar $ms->match (TM->FORALL, iplayer => 'tm:player' ), 1, 'association scoped 2');
is (scalar $ms->match (TM->FORALL, scope => 'tm:sss', iplayer => 'tm:player' ), 1, 'association scoped 3');
}
#-- reification --------------------------------------
{
my $ms = _parse (q|
http://rumsti.com/ is-a website
urn:x-rumsti:xxx is-a rumsti
|);
#warn Dumper $ms;
ok (eq_array ([
$ms->mids ('http://rumsti.com/','urn:x-rumsti:xxx')
],
[
'tm:uuid-0000000000', 'tm:uuid-0000000001'
]),
'reification: identifiers');
is (scalar $ms->match, $npa+2, 'external reification: association');
is (scalar $ms->match (TM->FORALL, iplayer => 'tm:uuid-0000000001' ), 1, 'reification: finding');
is (scalar $ms->match (TM->FORALL, type => 'isa', iplayer => 'tm:uuid-0000000000' ), 1, 'finding basic association');
}
{
my $ms = _parse (q|
cpan reifies http://cpan.org/
(xxx)
aaa: cpan
bbb: ccc
|);
#warn Dumper $ms;
is (scalar $ms->match, $npa+1, 'reification: association');
is (scalar $ms->match (TM->FORALL, type => 'tm:xxx', iplayer => $ms->mids ('http://cpan.org/') ), 1, 'reification: finding basic association');
is (scalar $ms->match (TM->FORALL, type => 'tm:xxx', iplayer => 'tm:cpan' ), 1, 'reification: finding basic association');
ok (eq_set (
[ $ms->match (TM->FORALL, type => 'tm:xxx', iplayer => $ms->mids ('http://cpan.org/') ) ],
[ $ms->match (TM->FORALL, type => 'tm:xxx', iplayer => 'tm:cpan' ) ]
), 'reification: finding, same');
}
{
my $ms = _parse (q|
(http://xxx)
http://role1 : aaa http://bbb
http://role2 : ccc
|);
#warn Dumper $ms;
is (scalar $ms->match, $npa+1, 'reification: association');
is (scalar $ms->match (TM->FORALL, type => $ms->mids('http://xxx'),
roles => [ $ms->mids ('http://role1', 'http://role2', 'http://role1') ],
players => [ $ms->mids ('tm:aaa', undef, 'http://bbb') ] ), 1, 'reification: association');
}
{ # reification explicit
my $ms = _parse (q|
xxx (http://www.topicmaps.org/xtm/1.0/#psi-topic)
|);
#warn Dumper $ms;
is (scalar $ms->match, $npa+1, 'reification: type');
ok ($ms->is_asserted (Assertion->new (scope => 'us',
type => 'isa',
roles => [ 'class', 'instance' ],
players => [ 'http://www.topicmaps.org/xtm/1.0/#psi-topic', 'tm:xxx' ])), 'xxx is-a found');
my $m = $ms->tids ('http://www.topicmaps.org/xtm/1.0/#psi-topic');
ok ($ms->is_asserted (Assertion->new (scope => 'us',
type => 'isa',
roles => [ 'class', 'instance' ],
players => [ $m, 'tm:xxx' ])), 'xxx is-a found (via mids)');
}
{
my $ms = _parse (q|
(xxx) is-reified-by aaa
role : player
|);
#warn Dumper $ms;
my ($a) = $ms->match (TM->FORALL, type => 'tm:xxx');
is_deeply ([ $ms->is_reified ($a) ], [ 'tm:aaa' ], 'assoc reified: regained');
is ($ms->reifies ('tm:aaa'), $a, 'assoc reified: regained 2');
}
eval {
my $ms = _parse (q|
(xxx) reifies aaa
role : player
|);
}; like ($@, qr/must be a URI/i, _chomp($@));
#{
# my $ms = _parse (q|
#(xxx) reifies http://rumsti/
# role : player
#|);
##warn Dumper $ms;
#
# my ($a) = $ms->match (TM->FORALL, type => 'tm:xxx');
# is ($ms->reified_by ($a->[TM->LID]), 'http://rumsti/', 'assoc reified: regained 3');
#}
eval {
my $ms = _parse (q|
(xxx) is-reified-by http://aaa/
role : player
|);
}; like ($@, qr/local identifier/i, _chomp($@));
#-- syntax errors -------------------------------------------------------------------
eval {
my $ms = _parse (q|
(xxx zzz)
member : aaa
|);
}; like ($@, qr/syntax error/i, _chomp($@));
eval {
my $ms = _parse (q|
(xxx)
|);
}; like ($@, qr/syntax error/i, _chomp($@));
eval {
my $ms = _parse (q|
(xxx)
role : aaa
role2 :
|);
}; like ($@, qr/syntax error/i, _chomp($@));
eval {
my $ms = _parse (q|
(xxx)
rumsti
|);
}; like ($@, qr/syntax error/i, _chomp($@));
eval {
my $ms = _parse (q|
()
role : player
|);
}; like ($@, qr/syntax error/i, _chomp($@));
#-- autogenerating ids
{
my $ms = _parse (q|
* (aaa)
* (aaa)
|);
## warn Dumper $ms;
is (scalar $ms->match, $npa+2, 'autogenerating ids');
is (scalar (
grep /tm:uuid-\d{10}/,
map {$_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'isa', iplayer => 'tm:aaa' ) ), 2, 'generated ids ok');
}
#-- structural: toplets/characteristics -----------------------------------------
#- negative tests
eval {
my $ms = _parse (q|
ttt
bn:
|);
warn Dumper $ms;
}; ok ($@, "raises except on empty bn:");
eval {
my $ms = _parse (q|
ttt
oc:
|);
}; ok ($@, "raises except on empty oc:");
eval {
my $ms = _parse (q|
ttt
in:
|);
}; ok ($@, "raises except on empty in:");
eval {
my $ms = _parse (q|
(aaa)
aaa :
|);
fail ("raises except on empty role");
}; ok ($@, "raises except on empty role");
eval {
my $ms = _parse (q|
(aaa)
aaa:bbb
|);
fail ("raises except on empty role 2");
}; ok ($@, "raises except on empty role 2");
eval {
my $ms = _parse (q|
(ddd)
bbb:aaa:ccc
|);
fail ("raises except on empty role 3");
}; ok ($@, "raises except on empty role 3");
eval {
my $ms = _parse (q|
aaa
sin (ttt): urn:xxx
|);
fail ("raises except on subject indicator");
}; ok ($@, "raises except on subject indicator");
eval {
my $ms = _parse (q|
aaa
sin @ sss : urn:xxx
|);
fail ("raises except on subject indicator");
}; ok ($@, "raises except on subject indicator");
#-- positive tests -----------------------------------
{
# testing toplets with characteristics
my $ms = _parse (q|
xxx
bn: XXX
|);
##warn Dumper $ms;
is (scalar $ms->match (TM->FORALL, type => 'name', roles => [ 'value', 'thing' ], players => [ undef, 'tm:xxx' ]), 1, 'basename characteristics');
}
{
# testing toplets with URI
my $ms = _parse (q|
http://xxx
bn: XXX
|);
##warn Dumper $ms;
is (scalar $ms->match (TM->FORALL, type => 'name', roles => [ 'value', 'thing' ],
players => [ $ms->mids (undef, 'http://xxx') ]), 1, 'basename characterisistics (reification)');
}
{
my $ms = _parse (q|
aaa (bbbbb)
bn: AAA
in: blabla
|);
##warn Dumper $ms;
ok (eq_set ([ map { map { $_->[0] } $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'occurrence', iplayer => 'tm:aaa' ) ] ,
[ 'blabla' ]), 'test blanks in resourceData 1');
}
{
my $ms = _parse (q|
xxx
bn: XXX
oc: http://xxx.com
ex: http://yyy.com
|);
##warn Dumper $ms;
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'occurrence', iplayer => 'tm:xxx' ) ] ,
[ 'http://yyy.com', 'http://xxx.com' ]), 'occurrence char, value ok');
}
#- adding types
{
my $ms = _parse (q|
aaa
bn: AAA
bn (rumsti) : AAAT
in: III
in (bumsti) : IIIT
oc: http://xxx/
oc (ramsti) : http://xxxt/
oc (rimsti) : http://yyy/
bn (remsti) : http://zzz/
in (remsti) : bla
|);
#warn Dumper $ms;
#warn "occurrences of aaa ".Dumper [ $ms->match (TemplateIPlayerType->new ( type => 'tm:occurrence', iplayer => 'tm:aaa' )) ];
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] }
grep ($_->[TM->TYPE] eq 'name',
$ms->match (TM->FORALL, type => 'name', iplayer => 'tm:aaa' )) ] ,
[ 'AAA' ]), 'basename untyped char, value ok');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'tm:rumsti', iplayer => 'tm:aaa' ) ] ,
[ 'AAAT' ]), 'basename typed char, value ok');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'occurrence', iplayer => 'tm:aaa' ) ] ,
[ 'http://xxxt/',
'http://yyy/',
'http://zzz/', # yes, this is also now an occurrence, since remsti is that too!
'III',
'IIIT',
'bla',
'http://xxx/' ]), 'occurr typed char, value ok');
ok (eq_set ([ map { $_->[0] } map { $_->[TM->PLAYERS]->[1] } $ms->match (TM->FORALL, type => 'tm:bumsti', iplayer => 'tm:aaa' ) ] ,
[ 'IIIT' ]), 'occurr typed char, value ok');
ok (eq_set (_q_players ($ms, type => 'tm:ramsti', iplayer => 'tm:aaa' ) ,
[ 'http://xxxt/' ]), 'occurr typed char, value ok');
ok (eq_set (_q_players ($ms, type => 'tm:remsti', iplayer => 'tm:aaa' ) ,
[
'http://zzz/',
'bla' ]), 'occurr typed char, value ok');
}
{ # subject indication
my $ms = _parse (q|
aaa
bn: AAA
sin: http://AAA
sin: http://BBB
|);
#warn Dumper $ms;
my $t = $ms->midlet ('tm:aaa');
ok (eq_set (
$t->[TM->INDICATORS],
[
'http://AAA',
'http://BBB',
]), 'indicators');
is (scalar $ms->match (TM->FORALL, type => 'name', irole => 'thing', iplayer => $ms->mids (\ 'http://AAA') ), 1, 'names for aaa via indication');
is (scalar $ms->match (TM->FORALL, type => 'name', irole => 'thing', iplayer => $ms->mids (\ 'http://BBB') ), 1, 'names for aaa via indication');
}
#-- associations with URIs
{
my $ms = _parse (q|
(aaa)
aaa:bbb : ccc
(ddd)
bbb: aaa:ccc
|);
## warn Dumper $ms;
ok (eq_set ([ map { $_->[TM->PLAYERS]->[0] } $ms->match (TM->FORALL, type => 'tm:aaa', irole => $ms->mids ('aaa:bbb') ) ] ,
[ 'tm:ccc' ]), 'assoc with URIs 1');
ok (eq_set ([ map { $_->[TM->PLAYERS]->[0] } $ms->match (TM->FORALL, type => 'tm:ddd', irole => 'tm:bbb' ) ] ,
[ $ms->mids ('aaa:ccc') ]), 'assoc with URIs 2');
}
#- adding scopes
{
my $ms = _parse (q|
aaa
bn: AAA
bn @ sss : AAAS
in: III
in @ sss : IIIS
oc: http://xxx/
oc @ sss : http://xxxs/
|);
## warn Dumper $ms;
ok (eq_set (_q_players ($ms, type => 'name', iplayer => 'tm:aaa' ),
[ 'AAA', 'AAAS' ]), 'basename untyped, scoped, value ok');
ok (eq_set (_q_players ($ms, scope => 'us', type => 'name', iplayer => 'tm:aaa' ),
[ 'AAA' ]), 'basename untyped, scoped, value ok');
ok (eq_set (_q_players ($ms, scope => 'tm:sss', type => 'name', iplayer => 'tm:aaa' ),
[ 'AAAS' ]), 'basename untyped, scoped, value ok');
ok (eq_set (_q_players ($ms, type => 'occurrence', iplayer => 'tm:aaa' ),
[ 'III', 'IIIS', 'http://xxx/', 'http://xxxs/' ]), 'occurrences untyped, mixscoped, value ok');
ok (eq_set (_q_players ($ms, scope => 'tm:sss', type => 'occurrence', iplayer => 'tm:aaa' ),
[ 'IIIS', 'http://xxxs/' ]), 'occurrences untyped, scoped, value ok');
}
{ # typed and scoped characteristics
my $ms = _parse (q|
aaa
bn (ramsti): AAA
bn @ sss (rumsti): AAAS
in: III
in @ sss (ramsti): IIIS
oc: http://xxx/
oc @ sss (ramsti): http://xxxs/
xxx (yyy)
|);
# warn Dumper $ms;
ok (eq_set (_q_players ($ms, type => 'tm:ramsti', iplayer => 'tm:aaa' ),
[ 'AAA', 'IIIS', 'http://xxxs/' ]), 'basename typed, mixscoped, value ok');
ok (eq_set (_q_players ($ms, scope => 'us', type => 'tm:ramsti', iplayer => 'tm:aaa' ),
[ 'AAA' ]), 'basename untyped, scoped, value ok');
ok (eq_set (_q_players ($ms, scope => 'tm:sss', type => 'tm:rumsti', iplayer => 'tm:aaa' ),
[ 'AAAS' ]), 'basename untyped, scoped, value ok');
ok (eq_set (_q_players ($ms, type => 'name', iplayer => 'tm:aaa' ),
[ 'http://xxxs/', 'AAA', 'IIIS', 'AAAS' ]), 'basenames typed, mixscoped, value ok');
ok (eq_set (_q_players ($ms, type => 'occurrence', iplayer => 'tm:aaa' ),
[ 'http://xxxs/', 'http://xxx/', 'AAA', 'IIIS', 'III' ]), 'occurrences typed, mixscoped, value ok');
ok (eq_set (_q_players ($ms, kind => TM->OCC, type => 'occurrence', iplayer => 'tm:aaa' ),
[ 'http://xxx/', 'http://xxxs/', 'IIIS', 'III' ]), 'occurrences untyped, mixscoped, value ok');
}
#-- inlined
{ # checking inlined subclassing
my $ms = _parse (q|
aaa is-subclass-of bbb
(is-subclass-of)
superclass: ddd
subclass: ccc
eee is-subclass-of fff is-subclass-of ggg
hhh subclasses iii is-subclass-of jjj
|);
##warn Dumper $ms;
is (scalar $ms->match(TM->FORALL, type => 'is-subclass-of', roles => [ 'subclass', 'superclass' ], players => [ 'tm:aaa', 'tm:bbb' ] ), 1, 'intrinsic is-subclass-of, different forms 1');
is (scalar $ms->match(TM->FORALL, type => 'is-subclass-of', roles => [ 'subclass', 'superclass' ], players => [ 'tm:ccc', 'tm:ddd' ] ), 1, 'intrinsic is-subclass-of, different forms 2');
is (scalar $ms->match(TM->FORALL, type => 'is-subclass-of', roles => [ 'subclass', 'superclass' ], players => [ 'tm:eee', 'tm:fff' ] ), 1, 'intrinsic is-subclass-of, different forms 3');
is (scalar $ms->match(TM->FORALL, type => 'is-subclass-of', roles => [ 'subclass', 'superclass' ], players => [ 'tm:eee', 'tm:ggg' ] ), 1, 'intrinsic is-subclass-of, different forms 4');
is (scalar $ms->match(TM->FORALL, type => 'is-subclass-of', roles => [ 'subclass', 'superclass' ], players => [ 'tm:hhh', 'tm:iii' ] ), 1, 'intrinsic is-subclass-of, different forms 5');
is (scalar $ms->match(TM->FORALL, type => 'is-subclass-of', roles => [ 'subclass', 'superclass' ], players => [ 'tm:hhh', 'tm:jjj' ] ), 1, 'intrinsic is-subclass-of, different forms 6');
}
{
my $ms = _parse (q|
aaa
bbb is-a thing
bbb is-a ccc
ddd ( )
eee is-a bbb is-a ccc is-a ddd
xxx has-a aaa
|);
##warn Dumper $ms;
is (scalar $ms->match(TM->FORALL, type => 'isa', roles => [ 'class', 'instance' ], players => [ 'tm:xxx', 'tm:aaa' ] ), 1, 'explicit is-a');
is (scalar $ms->match(TM->FORALL, type => 'isa', roles => [ 'class', 'instance' ], players => [ 'tm:ccc', 'tm:bbb' ] ), 1, 'explicit is-a 2');
is (scalar $ms->match(TM->FORALL, type => 'isa', roles => [ 'class', 'instance' ], players => [ 'tm:ddd', 'tm:eee' ] ), 1, 'explicit is-a 3');
is (scalar $ms->match(TM->FORALL, type => 'isa', roles => [ 'class', 'instance' ], players => [ 'tm:ccc', 'tm:eee' ] ), 1, 'explicit is-a 4');
is (scalar $ms->match(TM->FORALL, type => 'isa', roles => [ 'class', 'instance' ], players => [ 'tm:bbb', 'tm:eee' ] ), 1, 'explicit is-a 5');
}
#-- templates --------------------
eval {
my $ms = _parse (q|
xxx bbb zzz
|);
}; ok ($@, "raises except on undefined inline assoc");
{
my $ms = _parse (q|
[ (bbb)
ccc: ddd
eee: fff ]
xxx bbb zzz
uuu bbb vvv
|);
#warn Dumper $ms;
is (scalar $ms->match(TM->FORALL, type => 'tm:bbb', roles => [ 'tm:ccc', 'tm:eee' ], players => [ 'tm:ddd', 'tm:fff' ] ), 1, 'template: static');
}
{
my $ms = _parse (q|
[ (bbb)
ccc: http://psi.tm.bond.edu.au/astma/1.0/#psi-left
eee: fff ]
xxx bbb zzz
[ (bbb2)
ccc: http://psi.tm.bond.edu.au/astma/1.0/#psi-left
eee: http://psi.tm.bond.edu.au/astma/1.0/#psi-right ]
xxx bbb2 zzz
[ (bbb3)
http://psi.tm.bond.edu.au/astma/1.0/#psi-left : ccc
http://psi.tm.bond.edu.au/astma/1.0/#psi-right : eee ]
xxx bbb3 zzz
|);
#warn Dumper $ms;
is (scalar $ms->match(TM->FORALL, type => 'tm:bbb', roles => [ 'tm:ccc', 'tm:eee' ], players => [ 'tm:xxx', 'tm:fff' ] ), 1, 'template: dyn left');
is (scalar $ms->match(TM->FORALL, type => 'tm:bbb2', roles => [ 'tm:ccc', 'tm:eee' ], players => [ 'tm:xxx', 'tm:zzz' ] ), 1, 'template: dyn both, players');
is (scalar $ms->match(TM->FORALL, type => 'tm:bbb3', roles => [ 'tm:xxx', 'tm:zzz' ], players => [ 'tm:ccc', 'tm:eee' ] ), 1, 'template: dyn both, roles');
}
#-- scopes as dates
{
my $ms = _parse (q|
aaa
bn : AAA
bn @ 2004-01-12 : XXX
bn @ 2004-01-12 12:23 : YYY
|);
# warn Dumper $ms;
ok (eq_set (_q_players ($ms, scope => $ms->mids ('urn:x-date:2004-01-12:00:00'), type => 'name', iplayer => 'tm:aaa' ),
[ 'XXX' ]), 'date scoped 1');
ok (eq_set (_q_players ($ms, scope => $ms->mids ('urn:x-date:2004-01-12:12:23'), type => 'name', iplayer => 'tm:aaa' ),
[ 'YYY' ]), 'date scoped 2');
}
#-- directives ------------------------------------------------------------
#-- encoding
{ #-- default
my $ms = _parse (q|
aaa
in: Ich chan Glaas ässe, das tuet mir nöd weeh
bbb
in: Mohu jíst sklo, neublí?í mi
|);
ok (eq_set (_q_players ($ms, type => 'occurrence', iplayer => 'tm:aaa' ),
[ 'Ich chan Glaas ässe, das tuet mir nöd weeh' ]), 'encoding: same text');
ok (eq_set (_q_players ($ms, type => 'occurrence', iplayer => 'tm:bbb' ),
[ 'Mohu jíst sklo, neublí?í mi' ]), 'encoding: same text');
}
{ # -- explicit
my $ms = _parse (q|
%encoding iso-8859-1
aaa
in: Ich chan Glaas ässe, das tuet mir nöd weeh
|);
##warn Dumper $ms;
ok (eq_set (_q_players ($ms, type => 'occurrence', iplayer => 'tm:aaa' ),
[ 'Ich chan Glaas ässe, das tuet mir nöd weeh' ]), 'encoding: same text');
# ok (eq_set ([ $ms->toplets (new Toplet (characteristics => [ [ 'universal-scope',
# 'xtm-psi-occurrence',
# TM::Maplet::KIND_IN,
# '\x{E4}sse' ]])) ],
# [ 'aaa' ]), 'encoding: match in with umlaut');
}
{ #-- explicit different
my $ms = _parse (q|
%encoding iso-8859-2
aaa
in: Ich chan Glaas ässe, das tuet mir nöd weeh
|);
ok (eq_set (_q_players ($ms, type => 'occurrence', iplayer => 'tm:aaa' ),
[ 'Ich chan Glaas ässe, das tuet mir nöd weeh' ]), 'encoding: same text');
}
my ($tmp);
use IO::File;
use POSIX qw(tmpnam);
do { $tmp = tmpnam() ; } until IO::File->new ($tmp, O_RDWR|O_CREAT|O_EXCL);
END { unlink ($tmp) ; }
open (STDERR, ">$tmp");
{
my $ms = _parse (q|
aaa
%cancel
bbb
|);
is (scalar $ms->toplets, $npt+1, 'cancelling');
ERRexpect ("Cancelled");
##warn Dumper $ms;
}
{
my $ms = _parse (q|
aaa
%log xxx
bbb
|);
is (scalar $ms->toplets, $npt+2, 'logging');
ERRexpect ("Logging xxx");
}
{
my $ms = _parse (q|
aaa
%trace 1
bbb
(ddd)
eee : fff
%trace 0
ccc
|);
ERRexpect ("start tracing: level 1");
ERRexpect ("added toplet");
ERRexpect ("added assertion");
ERRexpect ("start tracing: level 0");
}
sub ERRexpect {
my $expect = shift;
open (ERR, $tmp);
undef $/; my $s = <ERR>;
like ($s, qr/$expect/, "STDERR: expected '$expect'");
close (ERR);
}
__END__
__END__
# testing corrupt TM
# testing TNC
my $text = '
aaa (bbb)
bn: AAA
';
foreach my $i (1..100) {
$text .= "
aaa$i (bbb)
bn: AAA$i
";
}
$tm = new TM (tie => new TM::Driver::AsTMa (auto_complete => 0, text => $text));
warn "Parse RecDescent inclusive: $Parse::RecDescent::totincl";
warn "Parse RecDescent exclusive: $Parse::RecDescent::totexcl";
#warn "instartrule: $Parse::RecDescent::namespace000001::totincl";
warn "instartrule: $TM::Driver::AsTMa::Parser::totincl";
#warn "instartrule: $TM::AsTMa::Parser::totexcl";
warn "namespace0001 instartrule: $Parse::RecDescent::namespace000001::astma";
warn "namespace0001 cparserincl: $Parse::RecDescent::namespace000001::cparserincl";
__END__
TODO: { # assoc with multiple scope
local $TODO = "assoc with multiple scope";
eval {
my $tm = new TM (tie => new TM::Driver::AsTMa (text => '
@ aaa bbb (is-ramsti-of)
ramsti : xxx
rumsti : yyy;
'));
};
ok (!$@);
}
__END__
##=========================================================