Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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

…ment
  • Loading branch information...
commit 0a9ff214dccdd9c599f2997d9b0db1b824af6852 1 parent f50b131
@sorear authored
Showing with 46 additions and 17 deletions.
  1. +32 −14 lib/X12/Schema/Constraint.pm
  2. +14 −3 lib/X12/Schema/Segment.pm
View
46 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";
}
View
17 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;
Please sign in to comment.
Something went wrong with that request. Please try again.