From: tla <tla@mit.edu>
Date: Sat, 18 Apr 2015 12:43:03 +0000 (+0200)
Subject: propagate normal form when it is changed on a lemma reading. #38
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=87ded8508d9ec32ebfb42678bfde8ceb9a0091fa;p=scpubgit%2Fstemmatology.git

propagate normal form when it is changed on a lemma reading. #38
---

diff --git a/morphology/lib/Text/Tradition/Morphology.pm b/morphology/lib/Text/Tradition/Morphology.pm
index ab3017b..31a49ef 100644
--- a/morphology/lib/Text/Tradition/Morphology.pm
+++ b/morphology/lib/Text/Tradition/Morphology.pm
@@ -70,19 +70,23 @@ has 'reading_lexemes' => (
 	
 
 
-# Make normal_form default to text, transparently.
+# Make normal_form default to text, transparently; also propagate the
+# normal form given if the reading is a lemma.
 around 'normal_form' => sub {
 	my $orig = shift;
 	my $self = shift;
-	my( $arg ) = @_;
+	unless( @_ ) {
+		# return the right default
+		return $self->_has_normal_form ? $self->$orig() : $self->text;
+	}
+	my $arg = shift;
 	if( $arg && $arg eq $self->text ) {
 		$self->_clear_normal_form;
-		return $arg;
-	} elsif( !$arg && !$self->_has_normal_form ) {
-		return $self->text;
 	} else {
-		$self->$orig( @_ );
+		$self->$orig( $arg );
 	}
+	$self->push_normal_form() if $self->is_lemma;
+	return $arg;
 };
 
 =head1 READING METHODS
@@ -287,6 +291,17 @@ $r3->make_lemma( 1 );
 is( $r4->normal_form, 'YAN', "normal form propagated" );
 is( $r5->normal_form, 'YAN', "normal form propagated" );
 
+# Now try modifying the normal form and making sure the change is propagated
+$r3->normal_form( 'JIGGIT' );
+is( $r4->normal_form, 'JIGGIT', "new normal form propagated" );
+is( $r5->normal_form, 'JIGGIT', "new normal form propagated" );
+
+# ...and that no change is propagated if the reading isn't a lemma.
+$r4->normal_form( 'JOLLY' );
+is( $r3->normal_form, 'JIGGIT', "normal form on non-lemma not propagated" );
+is( $r5->normal_form, 'JIGGIT', "normal form on non-lemma not propagated" );
+
+
 # Finally, try a relationship that shouldn't propagate the normal form
 my $r6 = $c->reading('w91');
 my $r7 = $c->reading('w92');
diff --git a/morphology/t/text_tradition_morphology.t b/morphology/t/text_tradition_morphology.t
index c78772e..db7483f 100644
--- a/morphology/t/text_tradition_morphology.t
+++ b/morphology/t/text_tradition_morphology.t
@@ -49,6 +49,17 @@ $r3->make_lemma( 1 );
 is( $r4->normal_form, 'YAN', "normal form propagated" );
 is( $r5->normal_form, 'YAN', "normal form propagated" );
 
+# Now try modifying the normal form and making sure the change is propagated
+$r3->normal_form( 'JIGGIT' );
+is( $r4->normal_form, 'JIGGIT', "new normal form propagated" );
+is( $r5->normal_form, 'JIGGIT', "new normal form propagated" );
+
+# ...and that no change is propagated if the reading isn't a lemma.
+$r4->normal_form( 'JOLLY' );
+is( $r3->normal_form, 'JIGGIT', "normal form on non-lemma not propagated" );
+is( $r5->normal_form, 'JIGGIT', "normal form on non-lemma not propagated" );
+
+
 # Finally, try a relationship that shouldn't propagate the normal form
 my $r6 = $c->reading('w91');
 my $r7 = $c->reading('w92');