From: Tara L Andrews <tla@mit.edu>
Date: Mon, 24 Sep 2012 10:29:53 +0000 (+0200)
Subject: support limited witness sigil rename
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4889be4f7ccd1d077a187699d861ef5362f64e4c;p=scpubgit%2Fstemmatology.git

support limited witness sigil rename
---

diff --git a/base/lib/Text/Tradition.pm b/base/lib/Text/Tradition.pm
index f8f8ea1..bd3ac2f 100644
--- a/base/lib/Text/Tradition.pm
+++ b/base/lib/Text/Tradition.pm
@@ -4,13 +4,14 @@ use JSON qw / from_json /;
 use Module::Load;
 use Moose;
 use Moose::Util qw/ does_role apply_all_roles /;
+use Safe::Isa;
 use Text::Tradition::Collation;
 use Text::Tradition::Error;
 use Text::Tradition::Witness;
 use TryCatch;
 
 use vars qw( $VERSION );
-$VERSION = "1.1";
+$VERSION = "1.2";
 
 # Enable plugin(s) if available
 eval { with 'Text::Tradition::HasStemma'; };
@@ -53,14 +54,18 @@ has '_initialized' => (
 	writer => '_init_done',
 	); 
 
-# Create the witness before trying to add it
+# Create the witness if necessary before trying to add it
 around 'add_witness' => sub {
     my $orig = shift;
     my $self = shift;
-    # TODO allow add of a Witness object?
-    my %args = @_ == 1 ? %{$_[0]} : @_;
-    $args{'tradition'} = $self;
-    my $new_wit = Text::Tradition::Witness->new( %args );
+    my $new_wit;
+    if( @_ == 1 && $_[0]->$_isa( 'Text::Tradition::Witness' ) ) {
+    	$new_wit = shift;
+    } else {
+   		my %args = @_ == 1 ? %{$_[0]} : @_;
+		$args{'tradition'} = $self;
+		$new_wit = Text::Tradition::Witness->new( %args );
+	}
     $self->$orig( $new_wit->sigil => $new_wit );
     return $new_wit;
 };
@@ -84,6 +89,25 @@ around 'witness' => sub {
     return $self->$orig( $arg );
 };
 
+# Cope with witness sigil changes
+sub rename_witness {
+	my( $self, $sig, $newsig ) = @_;
+	$DB::single = 1;
+	my $wit = $self->witness( $sig );
+	$self->throw( "No such witness $sig" ) unless $wit;
+	$self->throw( "Cannot rename witness that has already been collated" )
+		if $wit->is_collated;
+	$wit = $self->del_witness( $sig );
+	try {
+		$wit->_set_sigil( $newsig );
+	} catch ( $e ) {
+		# Don't lose the witness if the rename failed
+		$self->add_witness( $wit );
+		$self->throw( $e );
+	}
+	$self->add_witness( $wit );
+}
+
 =head1 NAME
 
 Text::Tradition - a software model for a set of collated texts
@@ -201,6 +225,7 @@ witness object for the deleted witness.
 
 =begin testing
 
+use TryCatch;
 use_ok( 'Text::Tradition', "can use module" );
 
 my $t = Text::Tradition->new( 'name' => 'empty' );
@@ -226,16 +251,40 @@ if( $wit_a ) {
 is( $s->witness('X'), undef, "There is no witness X" );
 ok( !exists $s->{'witnesses'}->{'X'}, "Witness key X not created" );
 
-my $wit_d = $s->add_witness( 'sigil' => 'D', 'sourcetype' => 'collation' );
+my $wit_d = $s->add_witness( 'sigil' => 'D', 'sourcetype' => 'plaintext',
+	'string' => 'je suis depourvu de foi' );
 is( ref( $wit_d ), 'Text::Tradition::Witness', "new witness created" );
 is( $wit_d->sigil, 'D', "witness has correct sigil" );
 is( scalar $s->witnesses, 4, "object now has four witnesses" );
 
-my $del = $s->del_witness( 'D' );
+try {
+	$s->rename_witness( 'D', 'Invalid Sigil' );
+	ok( 0, "Renamed witness with bad sigil" );
+} catch ( Text::Tradition::Error $e ) {
+	print STDERR $e->message . "\n";
+	is( $s->witness('D'), $wit_d, "Held onto witness during bad rename" );
+}
+
+try {
+	$s->rename_witness( 'D', 'Q' );
+	ok( 1, "Rename of witness succeeded" );
+	is( $s->witness('Q'), $wit_d, "Witness available under new sigil" );
+	ok( !$s->has_witness('D'), "Witness no longer available under old sigil" );
+} catch ( Text::Tradition::Error $e ) {
+	ok( 0, "Failed to rename witness: " . $e->message );
+}	
+
+my $del = $s->del_witness( 'Q' );
 is( $del, $wit_d, "Deleted correct witness" );
 is( scalar $s->witnesses, 3, "object has three witnesses again" );
 
-# TODO test initialization by witness list when we have it
+try {
+	$s->rename_witness( 'A', 'WitA' );
+	ok( 0, "Successfully renamed an already collated witness" );
+} catch ( Text::Tradition::Error $e ) {
+	is( $e->message, 'Cannot rename witness that has already been collated',
+		"Refused to rename an already-collated witness" );
+}
 
 =end testing
 
diff --git a/base/lib/Text/Tradition/Parser/CollateX.pm b/base/lib/Text/Tradition/Parser/CollateX.pm
index 628e672..d73eefe 100644
--- a/base/lib/Text/Tradition/Parser/CollateX.pm
+++ b/base/lib/Text/Tradition/Parser/CollateX.pm
@@ -125,7 +125,9 @@ sub parse {
 			## Add the path for each witness listesd.
             # Create the witness objects if they does not yet exist.
             foreach my $wit ( split( /, /, $e->{$WITKEY} ) ) {
-				unless( $tradition->witness( $wit ) ) {
+				if( $tradition->witness( $wit ) ) {
+					$tradition->witness( $wit )->is_collated( 1 );
+				} else {
 					$tradition->add_witness( 
 						'sigil' => $wit, 'sourcetype' => 'collation' );
 				}
diff --git a/base/lib/Text/Tradition/Parser/JSON.pm b/base/lib/Text/Tradition/Parser/JSON.pm
index 0734856..b32c904 100644
--- a/base/lib/Text/Tradition/Parser/JSON.pm
+++ b/base/lib/Text/Tradition/Parser/JSON.pm
@@ -108,8 +108,14 @@ sub parse {
 	my @witnesses; # Keep the ordered list of our witnesses
     my %ac_wits;  # Track these for later removal
     foreach my $sigil ( map { $_->{'witness'} } @{$table->{'alignment'}} ) {
-        my $wit = $tradition->add_witness( 
-        	'sigil' => $sigil, 'sourcetype' => 'collation' );
+    	my $wit;
+    	if( $tradition->has_witness( $sigil ) {
+    		$wit = $tradition->witness( $sigil );
+    		$wit->is_collated( 1 );
+    	} else {
+			$wit = $tradition->add_witness( 
+				'sigil' => $sigil, 'sourcetype' => 'collation' );
+		}
         $wit->path( [ $c->start ] );
         push( @witnesses, $wit );
         my $aclabel = $c->ac_label;
diff --git a/base/lib/Text/Tradition/Witness.pm b/base/lib/Text/Tradition/Witness.pm
index d0c4fb6..4ab7d5b 100644
--- a/base/lib/Text/Tradition/Witness.pm
+++ b/base/lib/Text/Tradition/Witness.pm
@@ -280,6 +280,11 @@ has 'layertext' => (
 	predicate => 'has_layertext',
 	);
 	
+has 'is_collated' => (
+	is => 'rw',
+	isa => 'Bool'
+	);
+	
 # Path.	 This is an array of Reading nodes that can be saved during
 # initialization, but should be cleared before saving in a DB.
 has 'path' => (
@@ -317,7 +322,10 @@ sub BUILD {
 		$self->$init_sub();
 		# Remove our XML / source objects; we no longer need them.
 		$self->clear_object if $self->has_object;
-		$self->tradition->collation->make_witness_path( $self );
+		# $self->tradition->collation->make_witness_path( $self );
+	}
+	if( $self->sourcetype eq 'collation' ) {
+		$self->is_collated( 1 );
 	}
 	return $self;
 }
diff --git a/base/t/text_tradition.t b/base/t/text_tradition.t
index 7e1718a..e158f9b 100644
--- a/base/t/text_tradition.t
+++ b/base/t/text_tradition.t
@@ -8,6 +8,7 @@ $| = 1;
 
 # =begin testing
 {
+use TryCatch;
 use_ok( 'Text::Tradition', "can use module" );
 
 my $t = Text::Tradition->new( 'name' => 'empty' );
@@ -33,16 +34,40 @@ if( $wit_a ) {
 is( $s->witness('X'), undef, "There is no witness X" );
 ok( !exists $s->{'witnesses'}->{'X'}, "Witness key X not created" );
 
-my $wit_d = $s->add_witness( 'sigil' => 'D', 'sourcetype' => 'collation' );
+my $wit_d = $s->add_witness( 'sigil' => 'D', 'sourcetype' => 'plaintext',
+	'string' => 'je suis depourvu de foi' );
 is( ref( $wit_d ), 'Text::Tradition::Witness', "new witness created" );
 is( $wit_d->sigil, 'D', "witness has correct sigil" );
 is( scalar $s->witnesses, 4, "object now has four witnesses" );
 
-my $del = $s->del_witness( 'D' );
+try {
+	$s->rename_witness( 'D', 'Invalid Sigil' );
+	ok( 0, "Renamed witness with bad sigil" );
+} catch ( Text::Tradition::Error $e ) {
+	print STDERR $e->message . "\n";
+	is( $s->witness('D'), $wit_d, "Held onto witness during bad rename" );
+}
+
+try {
+	$s->rename_witness( 'D', 'Q' );
+	ok( 1, "Rename of witness succeeded" );
+	is( $s->witness('Q'), $wit_d, "Witness available under new sigil" );
+	ok( !$s->has_witness('D'), "Witness no longer available under old sigil" );
+} catch ( Text::Tradition::Error $e ) {
+	ok( 0, "Failed to rename witness: " . $e->message );
+}	
+
+my $del = $s->del_witness( 'Q' );
 is( $del, $wit_d, "Deleted correct witness" );
 is( scalar $s->witnesses, 3, "object has three witnesses again" );
 
-# TODO test initialization by witness list when we have it
+try {
+	$s->rename_witness( 'A', 'WitA' );
+	ok( 0, "Successfully renamed an already collated witness" );
+} catch ( Text::Tradition::Error $e ) {
+	is( $e->message, 'Cannot rename witness that has already been collated',
+		"Refused to rename an already-collated witness" );
+}
 }
 
 
diff --git a/morphology/Makefile.PL b/morphology/Makefile.PL
index 3e12b1c..80570aa 100644
--- a/morphology/Makefile.PL
+++ b/morphology/Makefile.PL
@@ -16,7 +16,7 @@ requires( 'Lingua::TagSet::TreeTagger::English' );
 requires( 'Module::Load' );
 requires( 'Moose' );
 requires( 'Moose::Role' );
-requires( 'Text::Tradition' => '1.1' );
+requires( 'Text::Tradition' => '1.2' );
 requires( 'TryCatch' );
 build_requires( 'Safe::Isa' );
 build_requires( 'Test::Warn' );