From: Tara L Andrews <tla@mit.edu>
Date: Sun, 16 Sep 2012 19:20:26 +0000 (+0200)
Subject: make unsupported language non-fatal; correct exception raising
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=142698b84aca2bf7ee2177450593030d96a743a3;p=scpubgit%2Fstemmatology.git

make unsupported language non-fatal; correct exception raising
---

diff --git a/base/lib/Text/Tradition.pm b/base/lib/Text/Tradition.pm
index 769688f..f8f8ea1 100644
--- a/base/lib/Text/Tradition.pm
+++ b/base/lib/Text/Tradition.pm
@@ -305,6 +305,7 @@ sub add_json_witnesses {
 }
 
 sub throw {
+	my $self = shift;
 	Text::Tradition::Error->throw( 
 		'ident' => 'Tradition error',
 		'message' => $_[0],
diff --git a/morphology/Makefile.PL b/morphology/Makefile.PL
index a326c7a..00ac278 100644
--- a/morphology/Makefile.PL
+++ b/morphology/Makefile.PL
@@ -19,6 +19,7 @@ requires( 'Moose::Role' );
 requires( 'Text::Tradition' );
 requires( 'TryCatch' );
 build_requires( 'Safe::Isa' );
+build_requires( 'Test::Warn' );
 
 # Modules needed for morphology but not trivially CPANnable
 recommends( 'Lingua::TreeTagger' );
diff --git a/morphology/lib/Text/Tradition/Language.pm b/morphology/lib/Text/Tradition/Language.pm
index 3a78744..0f947b2 100644
--- a/morphology/lib/Text/Tradition/Language.pm
+++ b/morphology/lib/Text/Tradition/Language.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 use Module::Load;
 use Moose::Role;
+use TryCatch;
 
 requires 'throw';
 
@@ -21,6 +22,33 @@ add-on distribution.
 Accessor for the primary language of the tradition. Must correspond to one
 of the Text::Tradition::Language::* modules in this package.
 
+=begin testing
+
+use Test::Warn;
+use TryCatch;
+use_ok( 'Text::Tradition' ); # with Language
+
+# Test setting and recovering language
+my $t = Text::Tradition->new( input => 'Self', file => 't/data/legendfrag.xml' );
+warning_like { $t->language( 'Klingon' ); } qr/^Cannot load language/,
+	"Got expected warning for setting of unsupported language";
+$t->language( 'English' );
+is( $t->language, 'English', "Successfully set supported language" );
+
+# Test bad attempt to lemmatize - proper lemmatization is tested separately
+my $bt = Text::Tradition->new( input => 'Self', file => 't/data/besoin.xml' );
+try {
+	$bt->lemmatize;
+	ok( 0, "Failed to throw error on lemmatizing without language" );
+} catch( Text::Tradition::Error $e ) {
+	is( $e->message, "Please set a language to lemmatize a tradition",
+		"Got correct error thrown for lemmatization without set language" );
+} catch {
+	ok( 0, "Unexpected error on bad lemmatization attempt" );
+}
+
+=end testing
+
 =cut
 
 has 'language' => (
@@ -34,9 +62,10 @@ before 'language' => sub {
 	if( @_ && $_[0] ne 'Default' ) {
 		# We are trying to set the language; check that the corresponding
 		# module exists.
-		eval "require Text::Tradition::Language::".$_[0];
-		if( $@ ) {
-			throw( "Cannot load language module for @_: $@" );
+		try {
+			load( "Text::Tradition::Language::".$_[0] );
+		} catch ( $e ) {
+			warn( "Cannot load language module for @_: $e" );
 		}
 	}
 };
@@ -51,10 +80,16 @@ tradition.
 sub lemmatize {
 	my $self = shift;
 	unless( $self->has_language ) {
-		throw( "Please set a language to lemmatize a tradition" );
+		$self->throw( "Please set a language to lemmatize a tradition" );
 	}
 	my $mod = "Text::Tradition::Language::" . $self->language;
-	load( $mod );
+	try {
+		load( $mod );
+	} catch ( $e ) {
+		$self->throw( "Cannot load language module for " . $self->language );
+	}
+	$self->throw( "Language module $mod has no lemmatize function" )
+		unless $mod->can( 'lemmatize' );
 	$mod->can( 'lemmatize' )->( $self );
 }
 
diff --git a/morphology/t/text_tradition_language.t b/morphology/t/text_tradition_language.t
new file mode 100644
index 0000000..92f736a
--- /dev/null
+++ b/morphology/t/text_tradition_language.t
@@ -0,0 +1,38 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+$| = 1;
+
+
+
+# =begin testing
+{
+use Test::Warn;
+use TryCatch;
+use_ok( 'Text::Tradition' ); # with Language
+
+# Test setting and recovering language
+my $t = Text::Tradition->new( input => 'Self', file => 't/data/legendfrag.xml' );
+warning_like { $t->language( 'Klingon' ); } qr/^Cannot load language/,
+	"Got expected warning for setting of unsupported language";
+$t->language( 'English' );
+is( $t->language, 'English', "Successfully set supported language" );
+
+# Test bad attempt to lemmatize - proper lemmatization is tested separately
+my $bt = Text::Tradition->new( input => 'Self', file => 't/data/besoin.xml' );
+try {
+	$bt->lemmatize;
+	ok( 0, "Failed to throw error on lemmatizing without language" );
+} catch( Text::Tradition::Error $e ) {
+	is( $e->message, "Please set a language to lemmatize a tradition",
+		"Got correct error thrown for lemmatization without set language" );
+} catch {
+	ok( 0, "Unexpected error on bad lemmatization attempt" );
+}
+}
+
+
+
+
+1;