Refactor Contraint to permit eventually use in a not-just-die environ…

…ment

lib/X12/Schema/Constraint.pm

@@ -11,8 +11,6 @@ has all_or_none  => (is => 'ro', isa => 'ArrayRef[Str]');
 has at_least_one => (is => 'ro', isa => 'ArrayRef[Str]');
 has at_most_one  => (is => 'ro', isa => 'ArrayRef[Str]');
 
-has perl         => (is => 'ro', isa => 'CodeRef');
-
 sub check {
     my ($self, $values) = @_;
     my $key;
@@ -21,42 +19,62 @@ sub check {
         my $test;
         if (defined($values->{$key})) {
             if ($test = $self->{require_one}) {
-                die "If $key is present, then so must be one of @$test\n"
-                    unless grep defined($values->{$_}), @$test;
+                return if grep defined($values->{$_}), @$test;
+                return @$test;
             }
             elsif ($test = $self->{require_all}) {
-                die "If $key is present, then so must be all of @$test\n"
-                    if grep !defined($values->{$_}), @$test;
+                return grep !defined($values->{$_}), @$test;
             }
         }
     }
     elsif ($key = $self->{all_or_none}) {
         my $count = grep defined ($values->{$_}), @$key;
         if ($count && $count < @$key) {
-            die "All or none of @$key must be present\n";
+            return grep !defined($values->{$_}), @$key;
         }
     }
     elsif ($key = $self->{at_least_one}) {
         my $count = grep defined ($values->{$_}), @$key;
         if (!$count) {
-            die "At least one of @$key must be present\n";
+            return @$key;
         }
     }
     elsif ($key = $self->{at_most_one}) {
-        my $count = grep defined ($values->{$_}), @$key;
-        if ($count > 1) {
-            die "At most one of @$key must be present\n";
+        my @present = grep defined ($values->{$_}), @$key;
+        if (@present > 1) {
+            return @present;
         }
     }
-    elsif ($key = $self->{perl}) {
-        $key->($values);
+    return ();
+}
+
+sub describe {
+    my ($self) = @_;
+    my ($key, $test);
+
+    if ($key = $self->{if_present}) {
+        if ($test = $self->{require_one}) {
+            return "If $key is present, then so must be one of @$test";
+        }
+        elsif ($test = $self->{require_all}) {
+            return "If $key is present, then so must be all of @$test";
+        }
+    }
+    elsif ($key = $self->{all_or_none}) {
+        return "All or none of @$key must be present";
+    }
+    elsif ($key = $self->{at_least_one}) {
+        return "At least one of @$key must be present";
+    }
+    elsif ($key = $self->{at_most_one}) {
+        return "At most one of @$key must be present";
     }
 }
 
 sub BUILD {
     my ($self) = @_;
 
-    if (1 != grep defined ($self->{$_}), qw( if_present all_or_none at_least_one at_most_one perl )) {
+    if (1 != grep defined ($self->{$_}), qw( if_present all_or_none at_least_one at_most_one )) {
         confess "syntax note must have exactly one type";
     }
 

lib/X12/Schema/Segment.pm

@@ -14,7 +14,11 @@ sub encode {
 
     die 'Segment '.$self->friendly." must be encoded using a HASH\n" unless $obj && ref($obj) eq 'HASH' && !blessed($obj);
 
-    $_->check($obj) for @{ $self->constraints };
+    for my $c ( @{ $self->constraints } ) {
+        if ( () = $c->check($obj) ) {
+            die $c->describe . "\n";
+        }
+    }
 
     my %tmp = %$obj;
     my @bits;
@@ -33,12 +37,19 @@ sub encode {
         }
     }
 
-    die "Excess fields for segment ".$self->friendly.": ".join(', ', sort keys %tmp) if %tmp;
+    die "Excess fields for segment ".$self->friendly.": ".join(', ', sort keys %tmp)."\n" if %tmp;
     pop @bits while @bits && $bits[-1] eq '';
 
-    die "Segment ".$self->friendly." must contain data if it is present" unless @bits;
+    die "Segment ".$self->friendly." must contain data if it is present\n" unless @bits;
 
     $sink->segment( join($sink->element_sep, $self->tag, @bits) . $sink->segment_term );
 }
 
+# assumes that the lookahead tag has already been validated
+sub decode {
+    my ($self, $src) = @_;
+
+    my $tokens = $src->get;
+}
+
 __PACKAGE__->meta->make_immutable;