X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FParser%2FSelf.pm;h=ae70531b4ee2cdd15d75f1ebe912e623ce6845c9;hb=9fef629bd3a741a6d74d130f10056898d504fb47;hp=5499fc711138bc923c8fe7ff66a2bcb4668e1fc5;hpb=bf6e338dd676742fbd0c6d88c98795adae40429f;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Parser/Self.pm b/lib/Text/Tradition/Parser/Self.pm
index 5499fc7..ae70531 100644
--- a/lib/Text/Tradition/Parser/Self.pm
+++ b/lib/Text/Tradition/Parser/Self.pm
@@ -3,6 +3,8 @@ package Text::Tradition::Parser::Self;
 use strict;
 use warnings;
 use Text::Tradition::Parser::GraphML qw/ graphml_parse /;
+use Text::Tradition::UserStore;
+use TryCatch;
 
 =head1 NAME
 
@@ -94,6 +96,8 @@ source of the XML to be parsed.
 
 =begin testing
 
+use File::Temp;
+use Test::Warn;
 use Text::Tradition;
 binmode STDOUT, ":utf8";
 binmode STDERR, ":utf8";
@@ -113,9 +117,10 @@ if( $t ) {
     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' } );
@@ -133,8 +138,32 @@ if( $newt ) {
     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
 
@@ -159,6 +188,29 @@ sub parse {
 		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 {
@@ -166,7 +218,10 @@ sub parse {
 		}
 	}
 		
-    # 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'}} ) {    	
@@ -178,13 +233,20 @@ sub parse {
     		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 : '' );
@@ -192,7 +254,8 @@ sub parse {
 		
 		# 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'};
@@ -204,8 +267,12 @@ sub parse {
 	# TODO check that scoping does trt
 	$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 $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 );
 		delete $e->{'source'};
 		delete $e->{'target'};
 		# The remaining keys are relationship attributes.
@@ -223,7 +290,11 @@ sub parse {
 				$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