use strict;
use warnings;
use Text::Tradition::Parser::GraphML qw/ graphml_parse /;
+use Text::Tradition::UserStore;
+use TryCatch;
=head1 NAME
=begin testing
+use File::Temp;
+use Test::Warn;
use Text::Tradition;
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";
is( scalar $t->witnesses, 13, "Collation has all witnesses" );
}
-# TODO add a relationship, write graphml, reparse it, check that the rel
-# is still there
+# TODO add a relationship, add a stemma, write graphml, reparse it, check that
+# the new data is there
$t->language('Greek');
+$t->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
$t->collation->add_relationship( 'w12', 'w13',
{ 'type' => 'grammatical', 'scope' => 'global',
'annotation' => 'This is some note' } );
my $rel = $newt->collation->get_relationship( 'w12', 'w13' );
ok( $rel, "Found set relationship" );
is( $rel->annotation, 'This is some note', "Relationship has its properties" );
+ is( scalar $newt->stemmata, 1, "Tradition has its stemma" );
+ is( $newt->stemma(0)->witnesses, $t->stemma(0)->witnesses, "Stemma has correct length witness list" );
}
+# Test user save / restore
+my $fh = File::Temp->new();
+my $file = $fh->filename;
+$fh->close;
+my $dsn = "dbi:SQLite:dbname=$file";
+my $userstore = Text::Tradition::UserStore->new( { dsn => $dsn,
+ extra_args => { create => 1 } } );
+my $scope = $userstore->new_scope();
+my $testuser = $userstore->add_user( { url => 'http://example.com' } );
+is( ref( $testuser ), 'Text::Tradition::User', "Created test user via userstore" );
+$testuser->add_tradition( $newt );
+is( $newt->user->id, $testuser->id, "Assigned tradition to test user" );
+$graphml_str = $newt->collation->as_graphml;
+my $usert;
+warning_is {
+ $usert = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml_str );
+} 'DROPPING user assignment without a specified userstore',
+ "Got expected user drop warning on parse";
+$usert = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml_str,
+ 'userstore' => { 'dsn' => $dsn } );
+is( $usert->user->id, $testuser->id, "Parsed tradition with userstore points to correct user" );
+
=end testing
my $val = $graph_data->{'global'}->{$gkey};
if( $gkey eq 'version' ) {
$use_version = $val;
+ } elsif( $gkey eq 'stemmata' ) {
+ # Parse the stemmata into objects
+ foreach my $dotstr ( split( /\n/, $val ) ) {
+ $tradition->add_stemma( 'dot' => $dotstr );
+ }
+ } elsif( $gkey eq 'user' ) {
+ # Assign the tradition to the user if we can
+ if( exists $opts->{'userstore'} ) {
+ my $userdir;
+ try {
+ $userdir = Text::Tradition::UserStore->new( $opts->{'userstore'} );
+ } catch {
+ warn( "Could not connect to specified user store; DROPPING user assignment" );
+ }
+ my $user = $userdir->find_user( { username => $val } );
+ if( $user ) {
+ $user->add_tradition( $tradition );
+ } else {
+ warn( "Found no user with ID $val; DROPPING user assignment" );
+ }
+ } else {
+ warn( "DROPPING user assignment without a specified userstore" );
+ }
} elsif( $tmeta->has_attribute( $gkey ) ) {
$tradition->$gkey( $val );
} else {
}
}
- # Add the nodes to the graph.
+ # Add the nodes to the graph.
+ # Note any reading IDs that were changed in order to comply with XML
+ # name restrictions; we have to hardcode start & end.
+ my %namechange = ( '#START#' => '__START__', '#END#' => '__END__' );
# print STDERR "Adding collation readings\n";
foreach my $n ( @{$graph_data->{'nodes'}} ) {
next;
}
my $gnode = $collation->add_reading( $n );
+ if( $gnode->id ne $n->{'id'} ) {
+ $namechange{$n->{'id'}} = $gnode->id;
+ }
}
# Now add the edges.
# print STDERR "Adding collation path edges\n";
foreach my $e ( @{$graph_data->{'edges'}} ) {
- my $from = $collation->reading( $e->{'source'}->{'id'} );
- my $to = $collation->reading( $e->{'target'}->{'id'} );
+ my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
+ ? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
+ my $targetid = exists $namechange{$e->{'target'}->{'id'}}
+ ? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
+ my $from = $collation->reading( $sourceid );
+ my $to = $collation->reading( $targetid );
warn "No witness label on path edge!" unless $e->{'witness'};
my $label = $e->{'witness'} . ( $e->{'extra'} ? $collation->ac_label : '' );
# Add the witness if we don't have it already.
unless( $witnesses{$e->{'witness'}} ) {
- $tradition->add_witness( sigil => $e->{'witness'} );
+ $tradition->add_witness(
+ sigil => $e->{'witness'}, 'sourcetype' => 'collation' );
$witnesses{$e->{'witness'}} = 1;
}
$tradition->witness( $e->{'witness'} )->is_layered( 1 ) if $e->{'extra'};
# Nodes are added via the call to add_reading above. We only need
# add the relationships themselves.
# TODO check that scoping does trt
- foreach my $e ( @{$rel_data->{'edges'}} ) {
- my $from = $collation->reading( $e->{'source'}->{'id'} );
- my $to = $collation->reading( $e->{'target'}->{'id'} );
+ $rel_data->{'edges'} ||= []; # so that the next line doesn't break on no rels
+ foreach my $e ( sort { _layersort_rel( $a, $b ) } @{$rel_data->{'edges'}} ) {
+ my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
+ ? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
+ my $targetid = exists $namechange{$e->{'target'}->{'id'}}
+ ? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
+ my $from = $collation->reading( $sourceid );
+ my $to = $collation->reading( $targetid );
delete $e->{'source'};
delete $e->{'target'};
# The remaining keys are relationship attributes.
$rel_exists = 1;
}
}
- $collation->add_relationship( $from, $to, $e ) unless $rel_exists;
+ try {
+ $collation->add_relationship( $from, $to, $e ) unless $rel_exists;
+ } catch( Text::Tradition::Error $e ) {
+ warn "DROPPING $from -> $to: " . $e->message;
+ }
}
# Save the text for each witness so that we can ensure consistency
$collation->text_from_paths();
}
+## Return the relationship that comes first in priority.
+my %LAYERS = (
+ 'collated' => 1,
+ 'orthographic' => 2,
+ 'spelling' => 3,
+ );
+
+sub _layersort_rel {
+ my( $a, $b ) = @_;
+ my $key = exists $a->{'type'} ? 'type' : 'relationship';
+ my $at = $LAYERS{$a->{$key}} || 99;
+ my $bt = $LAYERS{$b->{$key}} || 99;
+ return $at <=> $bt;
+}
+
1;
=head1 BUGS / TODO