is( scalar @v2, 2, "Added a global relationship with two instances" );
@v1 = $c->del_relationship( 'n22', 'n21' );
is( scalar @v1, 1, "Deleted first relationship" );
-@v2 = $c->del_relationship( 'n12', 'n13' );
+@v2 = $c->del_relationship( 'n12', 'n13', 1 );
is( scalar @v2, 2, "Deleted second global relationship" );
my @v3 = $c->del_relationship( 'n1', 'n2' );
is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
+my @v4 = $c->add_relationship( 'n24', 'n23',
+ { 'type' => 'spelling', 'scope' => 'global' } );
+is( @v4, 2, "Re-added global relationship" );
+@v4 = $c->del_relationship( 'n12', 'n13' );
+is( @v4, 1, "Only specified relationship deleted this time" );
+ok( $c->get_relationship( 'n24', 'n23' ), "Other globally-added relationship exists" );
}
# Test group 5: relationship transitivity.
my $t5 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/john.xml' );
my $c5 = $t5->collation;
+# Test 5.0: propagate all existing transitive rels and make sure it succeeds
+my $orignumrels = scalar $c5->relationships();
+try {
+ $c5->relations->propagate_all_relationships();
+ ok( 1, "Propagated all existing transitive relationships" );
+} catch ( Text::Tradition::Error $err ) {
+ ok( 0, "Failed to propagate all existing relationships: " . $err->message );
+}
+ok( scalar( $c5->relationships ) > $orignumrels, "Added some relationships in propagation" );
# Test 5.1: make a grammatical link to an orthographically-linked reading
$c5->add_relationship( 'r13.5', 'r13.2', { type => 'orthographic' } );
}
}
-# Test 5.4: add a parallel but not sibling relationship
+# Test 5.4: delete a spelling relationship, add it again, make sure it doesn't
+# throw and make sure all the relationships are the same
+my $numrel = scalar $c5->relationships;
+$c5->del_relationship( 'r13.4', 'r13.2' );
+try {
+ $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
+ ok( 1, "Managed not to throw an exception re-adding the relationship" );
+} catch( Text::Tradition::Error $e ) {
+ ok( 0, "Threw an exception trying to re-add our intermediate relationship: " . $e->message );
+}
+is( $numrel, scalar $c5->relationships, "Number of relationships did not change" );
+foreach my $rdg ( qw/ r13.2 r13.3 r13.5 / ) {
+ my $newspel = $c5->get_relationship( 'r13.4', $rdg );
+ ok( $newspel, 'Relationship was made between indirectly linked readings' );
+ if( $newspel ) {
+ is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' );
+ }
+}
+my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' );
+ok( $stillgram, 'Relationship was made between indirectly linked readings' );
+if( $stillgram ) {
+ is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' );
+}
+
+# Test 5.5: add a parallel but not sibling relationship
$c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
"Lexical relationship did not affect grammatical" );
}
}
-# Test 5.5: try it with non-colocated relationships
-my $numrel = scalar $c5->relationships;
+# Test 5.6: try it with non-colocated relationships
+$numrel = scalar $c5->relationships;
$c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
is( scalar $c5->relationships, $numrel+1,
"Adding non-colo relationship did not propagate" );
}
is( scalar $c5->relationships, $numrel+4,
"Adding non-colo relationship only propagated on non-colos" );
+
+# Test 5.7: ensure that attempts to cross boundaries on bindlevel-equal
+# relationships fail.
+try {
+ $c5->add_relationship( 'r39.6', 'r41.1', { type => 'grammatical', propagate => 1 } );
+ ok( 0, "Did not prevent add of conflicting relationship level" );
+} catch( Text::Tradition::Error $err ) {
+ like( $err->message, qr/Conflicting existing relationship/, "Got correct error message trying to add conflicting relationship level" );
+}
+
+# Test 5.8: ensure that weak relationships don't interfere
+$c5->add_relationship( 'r50.1', 'r50.2', { type => 'collated' } );
+$c5->add_relationship( 'r50.3', 'r50.4', { type => 'orthographic' } );
+try {
+ $c5->add_relationship( 'r50.4', 'r50.1', { type => 'grammatical', propagate => 1 } );
+ ok( 1, "Collation did not interfere with new relationship add" );
+} catch( Text::Tradition::Error $err ) {
+ ok( 0, "Collation interfered with new relationship add: " . $err->message );
+}
+my $crel = $c5->get_relationship( 'r50.1', 'r50.2' );
+ok( $crel, "Original relationship still exists" );
+if( $crel ) {
+ is( $crel->type, 'collated', "Original relationship still a collation" );
+}
+
+try {
+ $c5->add_relationship( 'r50.1', 'r51.1', { type => 'spelling', propagate => 1 } );
+ ok( 1, "Collation did not interfere with relationship re-ranking" );
+} catch( Text::Tradition::Error $err ) {
+ ok( 0, "Collation interfered with relationship re-ranking: " . $err->message );
+}
+$crel = $c5->get_relationship( 'r50.1', 'r50.2' );
+ok( !$crel, "Collation relationship now gone" );
+
+# Test 5.9: ensure that strong non-transitive relationships don't interfere
+$c5->add_relationship( 'r66.1', 'r66.4', { type => 'grammatical' } );
+$c5->add_relationship( 'r66.2', 'r66.4', { type => 'uncertain', propagate => 1 } );
+try {
+ $c5->add_relationship( 'r66.1', 'r66.3', { type => 'grammatical', propagate => 1 } );
+ ok( 1, "Non-transitive relationship did not block grammatical add" );
+} catch( Text::Tradition::Error $err ) {
+ ok( 0, "Non-transitive relationship blocked grammatical add: " . $err->message );
+}
+is( scalar $c5->related_readings( 'r66.4' ), 3, "Reading 66.4 has all its links" );
+is( scalar $c5->related_readings( 'r66.2' ), 1, "Reading 66.2 has only one link" );
+is( scalar $c5->related_readings( 'r66.1' ), 2, "Reading 66.1 has all its links" );
+is( scalar $c5->related_readings( 'r66.3' ), 2, "Reading 66.3 has all its links" );
}
projects / scpubgit/stemmatology.git / blobdiff