use strict; use warnings; use Test::More qw(no_plan); ##use Test::Deep; use Data::Dumper; $Data::Dumper::Indent = 1; use TM::Materialized::AsTMa; #== TESTS =========================================================================== my $tm = new TM::Materialized::AsTMa (baseuri=>"tm://", inline=> ' nackertes_topic atop bn: just a topic btop (ctop) bn: something bn@ascope: some other thing ctop bn: over the top! in: something in: somemore oc: http://somewhere in@ascope: scoped in@ascope (sometype): also typed oc (sometype): http://typedoc oc @ascope (sometype): http://typedandscopedoc (sucks-more-than) sucker: ctop winner: atop winner: others (sucks-more-than) @ascope sucker: nobody winner: nobody thistop reifies http://rumsti bn: reification in: reification sin: http://nowhere.never.ever sin: http://nowhere.ever.never (sucks-more-than) is-reified-by atop winner: nobody sucker: nobody ')->sync_in; Class::Trait->apply ($tm, "TM::Serializable::XTM"); can_ok $tm, 'serialize'; { my $content = $tm->serialize (version => '1.0'); #warn $content; use XML::LibXML; my $xp = XML::LibXML->new(); my $doc = $xp->parse_string($content); # use XML::LibXML::Dtd; my $dtd = XML::LibXML::Dtd->new("-//TopicMaps.Org//DTD XML Topic Map (XTM) 1.0//EN",'schemas/xtm10.dtd'); ok ( $doc->validate($dtd), 'validates XTM 1.0'); ok (eq_set ([ map { "tm://$_" } map { $_->nodeValue } $doc->findnodes('/topicMap/topic/@id') ], [ map { $_->[TM->LID] } $tm->toplets (\ '+all -infrastructure') ]), 'topic ids'); is ('#ctop', $doc->findnodes('/topicMap/topic[@id="btop"]/instanceOf/topicRef/@xlink:href'), 'instance btop'); ok ($doc->findnodes('/topicMap/association[@id="a068ce15eb7cf7cc4536d504c73a4c05c"]/instanceOf/topicRef[@xlink:href="#sucks-more-than"]'), 'found assoc'); ok ( eq_set ([ '#atop', '#others' ], [ map { $_->nodeValue } $doc->findnodes('/topicMap/association[@id="a4abe49897cefeb950e4affaab0418e4f"]/member[roleSpec/topicRef/@xlink:href = "#winner"]/topicRef/@xlink:href')]), 'found assoc'); ok ( eq_set ([ map { $_->nodeValue } $doc->findnodes('/topicMap/topic[@id="btop"]/baseName/baseNameString/text()') ], ['something', 'some other thing' ]), 'basename value'); ok ( eq_set ([ map { $_->nodeValue } $doc->findnodes('/topicMap/topic[@id="btop"]/baseName[scope/topicRef/@xlink:href = "#ascope"]/baseNameString/text()') ], ['some other thing' ]), 'basename value, scoped'); ok ( eq_set ([ map { $_->nodeValue } $doc->findnodes('/topicMap/topic[@id="ctop"]/occurrence[instanceOf/topicRef/@xlink:href = "#sometype"]/resourceRef/@xlink:href') ], [ 'http://typedoc', 'http://typedandscopedoc' ]), 'occ value, scoped and unscoped'); ok ( eq_set ([ map { $_->nodeValue } $doc->findnodes('/topicMap/topic[@id="ctop"]/occurrence[instanceOf/topicRef/@xlink:href = "#sometype"][scope/topicRef/@xlink:href = "#ascope"]/resourceRef/@xlink:href') ], [ 'http://typedandscopedoc' ]), 'occ value, scoped'); ok ( eq_set ([ map { $_->nodeValue } $doc->findnodes('/topicMap/topic[@id="thistop"]/subjectIdentity/subjectIndicatorRef/@xlink:href') ], [ 'http://nowhere.never.ever', 'http://nowhere.ever.never' ]), 'indicators'); ok ( eq_set ([ map { $_->nodeValue } $doc->findnodes('/topicMap/topic[@id="thistop"]/subjectIdentity/resourceRef/@xlink:href') ], [ 'http://rumsti' ]), 'address'); ok (! $doc->findnodes('/topicMap/topic[@id="ctop"]/subjectIdentity/resourceRef/@xlink:href'), 'no address'); ok (! $doc->findnodes('/topicMap/topic[@id="ctop"]/subjectIdentity/subjectIndicatorRef/@xlink:href'), 'no indicators'); my ($aid) = map { $_->nodeValue } $doc->findnodes('/topicMap/topic[@id="atop"]/subjectIdentity/topicRef/@xlink:href'); ok ($aid =~ /^\#a.{32}$/, 'internal reification'); $aid =~ s/\#//; ok ( eq_set ([ map { $_->nodeValue } $doc->findnodes(qq|/topicMap/association[\@id="$aid"]/member [roleSpec/topicRef/\@xlink:href = "#winner"] /topicRef/\@xlink:href|) ], [ '#nobody' ]), 'reified assoc, role + players'); ok ( eq_set ([ map { $_->nodeValue } $doc->findnodes(qq|/topicMap/association[\@id="$aid"]/member [roleSpec/topicRef/\@xlink:href = "#sucker"] /topicRef/\@xlink:href|) ], [ '#nobody' ]), 'reified assoc, role + players II'); ok ( eq_set ([ map { $_->nodeValue } $doc->findnodes('/topicMap/topic[count(*) = 0]/@id') ], [ 'nackertes_topic', 'nobody', 'others', 'sometype', 'sucker', 'sucks-more-than', 'winner' ]), 'empty topics'); #print Dumper [ # map { $_->nodeValue } $doc->findnodes('/topicMap/topic[count(*) = 0]/@id') # ]; } { my $content = $tm->serialize (omit_trivia => 1, version => '1.0'); use XML::LibXML; my $xp = XML::LibXML->new(); my $doc = $xp->parse_string($content); ok (eq_set ([ map { "tm://$_" } ( 'nackertes_topic', 'nobody', 'others', 'sometype', 'sucker', 'sucks-more-than', 'winner', map { $_->nodeValue } $doc->findnodes('/topicMap/topic/@id') ) ], [ map { $_->[TM->LID] } $tm->toplets (\ '+all -infrastructure') ]), 'topic ids'); } { my $tm2 = new TM (baseuri=>"tm://"); Class::Trait->apply ($tm2, "TM::Serializable::XTM"); can_ok $tm2, 'deserialize'; $tm2->deserialize ($tm->serialize (version => '1.0')); #warn Dumper $tm2; is_deeply( $tm->{mid2iid}, $tm2->{mid2iid}, 'toplet structure identical' ); is_deeply( $tm->{assertions}, $tm2->{assertions}, 'asserts structure identical' ); } { my $content = $tm->serialize (version => '1.0'); my $tm2 = new TM (baseuri=>"tm://"); Class::Trait->apply ($tm2, "TM::Serializable::XTM"); $tm2->deserialize ($tm->serialize (version => '1.0')); my $content2 = $tm2->serialize (version => '1.0'); is ($content, $content2, 'round tripping'); # use Text::Diff; # my $diff = diff \$content, \$content2, { STYLE => "Context" }; #, \%options; # warn Dumper $diff; } { #-- create name reification my ($name, $occ) = $tm->match_forall (char => 1, topic => $tm->tids ('thistop')); $tm->internalize ('thistop_name' => $name->[TM->LID]); # create a reification $tm->internalize ('thistop_occ' => $occ->[TM->LID]); # create a reification } { # version 1.0 cannot deal with name reification? my $tm2 = new TM; Class::Trait->apply ($tm2, 'TM::Serializable::XTM'); my $c = $tm->serialize (version => '1.0'); # warn $c; $tm2->deserialize ($c); TODO: { local $TODO = "name/occ reification support for XTM 1.0"; is_deeply( $tm->{mid2iid}, $tm2->{mid2iid}, 'toplet structure identical' ); is_deeply( $tm->{assertions}, $tm2->{assertions}, 'asserts structure identical' ); } } __END__ TODO: variants