cosmetic fixes to error messages

[scpubgit/stemmatology.git] / lib / Text / Tradition / Analysis / Result.pm

diff --git a/lib/Text/Tradition/Analysis/Result.pm b/lib/Text/Tradition/Analysis/Result.pm
index d8717ae..91c8a49 100644 (file)
--- a/lib/Text/Tradition/Analysis/Result.pm
+++ b/lib/Text/Tradition/Analysis/Result.pm
@@ -76,6 +76,7 @@ follows that of a parent on the graph.
 
 =begin testing
 
+use Set::Scalar;
 use Test::More::UTF8;
 use Text::Tradition;
 use TryCatch;
@@ -116,6 +117,14 @@ try {
        like( $e->message, qr/Failed to find witness set that is a subset of/, 
                "Correct error thrown on bad record_grouping attempt" );
 }
+# Test manually setting an out-of-range group
+try {
+       $result->_set_grouping( 3, Set::Scalar->new( qw/ X Y / ) );
+       ok( 0, "Set a grouping at an invalid index" );
+} catch ( Text::Tradition::Error $e ) {
+       is( $e->message, 'Set / group index 3 out of range for set_grouping', 
+               "Caught attempt to set grouping at invalid index" );
+}
 $result->record_grouping( [ qw/ 3 F H / ] );
 my $gp1 = $result->grouping(1);
 is( $result->minimum_grouping_for( $rsets[1] ), $gp1, 
@@ -192,7 +201,6 @@ has 'groupinglist' => (
        isa => 'ArrayRef[Set::Scalar]',
        handles => {
                groupings => 'elements',
-               _add_grouping => 'push',
                _set_grouping => 'set',
                grouping => 'get',
        },
@@ -218,8 +226,10 @@ around BUILDARGS => sub {
        
        # Convert the set list into a list of Set::Scalars, ordered first by size and
        # then alphabetically by first-sorted.
-       die "Must specify a set list to Analysis::Result->new()" 
+       throw( "Must specify a set list to Analysis::Result->new()" )
                unless ref( $args->{'setlist'} ) eq 'ARRAY'; 
+       throw( "Empty set list specified to Analysis::Result->new()" )
+               unless @{$args->{'setlist'}};
        # Order the sets and make sure they are all distinct Set::Scalars.
        $args->{'setlist'} = [ sort { by_size_and_alpha( $a, $b ) } 
                                                        _check_set_args( $args->{'setlist'} ) ];
@@ -238,12 +248,11 @@ around BUILDARGS => sub {
                } elsif( $type eq 'Graph' ) {
                        $args->{'graph'} = Text::Tradition::Stemma::editable_graph( $st, $gopt );
                } else {
-                       die "Passed argument to graph that is neither Stemma nor Graph";
+                       throw( "Passed argument to graph that is neither Stemma nor Graph" );
                }
        } 
        
        # If our only args are graph and setlist, then status should be 'new'
-       $DB::single = 1;
        if( scalar keys %$args == 2 ) {
                $args->{'status'} = 'new';
        }
@@ -259,12 +268,12 @@ sub _check_set_args {
                # Check uniqueness of the current set
                if( ref( $set ) ne 'Set::Scalar' ) {
                        $s = Set::Scalar->new( @$set );
-                       die "Duplicate element(s) in set or group passed to Analysis::Result->new()"
+                       throw( "Duplicate element(s) in set or group passed to Analysis::Result->new()" )
                                unless @$set == $s->elements;
                }
                # Check distinctness of the set from all other sets given so far
                foreach my $ps ( @sets ) {
-                       die "Two sets are not disjoint"
+                       throw( "Two sets $s / $ps are not disjoint" )
                                unless $s->is_disjoint( $ps );
                }
                # Save the set.
@@ -277,9 +286,23 @@ sub BUILD {
        my $self = shift;
        
        # Initialize the groupings array
-       map { $self->_add_grouping( $_ ) } $self->sets;
+       my @sets = $self->sets;
+       foreach my $idx( 0 .. $#sets ) {
+               unless( $self->grouping( $idx ) ) {
+                       $self->_set_grouping( $idx, $sets[$idx] );
+               }
+       }
 }
 
+before '_set_grouping' => sub {
+       my $self = shift;
+       my $idx = $_[0];
+       my $max = scalar $self->sets;
+       if( $idx >= $max ) {
+               throw( "Set / group index $idx out of range for set_grouping" );
+       }
+};
+
 =head2 $self->object_key
 
 Returns a unique key that can be used to look up this graph/set combination in
@@ -301,54 +324,7 @@ key for the result.
 
 sub request_string {
        my $self = shift;
-       return string_from_graph_problem( $self->graph, [ $self->sets ] );
-}
-
-# TODO do we need this now?
-
-sub string_from_graph_problem {
-       my( $graph, $grouping ) = @_;
-       my( $graphstr, @groupsets );
-       # Get the graph string
-       if( ref( $graph ) && ref( $graph ) eq 'Graph' ) {
-               $graphstr = Text::Tradition::Stemma::editable_graph( $graph, { 'linesep' => ' ' } );
-       } else {
-               throw( "Passed non-graph object $graph to stringification" )
-                       if ref( $graph );
-               $graphstr = $graph;
-       }
-       # Make sure all groupings are sets
-       foreach my $g ( @$grouping ) {
-               if( ref( $g ) eq 'ARRAY' ) {
-                       push( @groupsets, Set::Scalar->new( @$g ) );
-               } elsif( ref( $g ) eq 'Set::Scalar' ) {
-                       push( @groupsets, $g );
-               } else {
-                       throw( "Tried to stringify grouping $g that is neither set nor array" );
-               }
-       }
-       return $graphstr . '//' . 
-               join( ',', sort { by_size_and_alpha( $a, $b ) } @groupsets );
-}
-
-# TODO do we need this?
-# This should work as $self->problem_json or as problem_json( @objects )
-sub problem_json {
-       my( @objects ) = @_;
-       # There should be a distinct problem for each unique graph.
-       my %distinct_problems;
-       foreach my $o ( @objects ) {
-               unless( exists $distinct_problems{$o->graph} ) {
-                       $distinct_problems{$o->graph} = [];
-               }
-               my @groupings;
-               map { push( @groupings, [ $_->members ] ) } $o->sets;
-               push( @{$distinct_problems{$o->graph}}, \@groupings );
-       }
-       my @pstrs = map { to_json( 
-               { graph => $_, groupings => $distinct_problems{$_} } ) } 
-               keys %distinct_problems;
-       return @pstrs;
+       return $self->graph . '//' . join( ',', $self->sets );
 }
 
 =head2 by_size_and_alpha