Permalink
Browse files

Start new error handling, segment tests

  • Loading branch information...
1 parent c75f0d9 commit c98cf936e8afd8a48836dc498343fc680f87b8e4 @sorear committed Mar 18, 2013
Showing with 118 additions and 2 deletions.
  1. +9 −0 lib/X12/Schema/SyntaxError.pm
  2. +41 −0 lib/X12/Schema/TokenSource.pm
  3. +21 −2 t/02-source.t
  4. +47 −0 t/05-segment.t
@@ -0,0 +1,9 @@
+package X12::Schema::SyntaxError;
+
+use Moose;
+use namespace::autoclean;
+
+has code => (is => 'ro', isa => 'Str', required => 1);
+has message => (is => 'ro', isa => 'Str', required => 1);
+
+__PACKAGE__->meta->make_immutable;
@@ -3,6 +3,8 @@ package X12::Schema::TokenSource;
use Moose;
use namespace::autoclean;
+use X12::Schema::SyntaxError;
+
has buffer => (is => 'bare', isa => 'Str', default => '');
has filler => (is => 'ro', isa => 'CodeRef', default => sub { sub { 0 } });
@@ -13,10 +15,14 @@ has _suffix_re => (is => 'bare', isa =>'RegexpRef', init_arg => undef);
has [qw(_segment_term _component_sep _repeat_sep _segment_term_suffix _element_sep)] => (is => 'bare', isa => 'Str', init_arg => undef);
has segment_counter => (is => 'rw', isa => 'Int', default => 0);
+has errors => (is => 'ro', isa => 'ArrayRef[X12::Schema::SyntaxError]', default => sub { [ ] }, init_arg => undef);
+has _fatal_error => (is => 'bare', isa => 'Bool');
sub _parse {
my ($self) = @_;
+ return if $self->{_fatal_error};
+
if (substr($self->{buffer},0,3) eq 'ISA') {
return if length($self->{buffer}) < 109; # ISA itself is 106 chars, but we need to see the beginning of GE to get the separator
@@ -38,6 +44,12 @@ sub _parse {
return [ map [[$_]], split /\Q$self->{_element_sep}/, substr($ISA,0,105) ];
}
+ unless ($self->{_segment_re}) {
+ $self->{_fatal_error} = 1;
+ $self->logerror( 'isa_not_first' );
+ return;
+ }
+
# DIVERSITY: UNx, BIN, BDS segments, maybe X12.58 but I don't have a clear idea what that entails
$self->{buffer} =~ s/$self->{_segment_re}// or return;
@@ -58,6 +70,11 @@ sub _parse {
sub _delims_changed {
my ($self) = @_;
+ my %u;
+ if (grep( defined $_ && $u{$_}++, @$self{ qw( _element_sep _repeat_sep _component_sep _segment_term ) } )) {
+ $self->logerror( 'nonunique_delims' );
+ }
+
my $t = $self->{_segment_term};
my $ts = $self->{_segment_term_suffix};
$self->{_segment_re} = "^([^\Q$t\E]*)\Q$t$ts\E";
@@ -95,4 +112,28 @@ sub peek_code {
return !$self->{_lookahead} ? '' : $self->{_lookahead}[0][0][0]; # DIVERSITY explicit nesting needs more info
}
+sub expect_eof {
+ my ($self) = @_;
+
+ 1 until length($self->{buffer}) or !$self->filler->();
+
+ $self->logerror('garbage') if length $self->{buffer};
+}
+
+my %errdefs = (
+ garbage => { message => 'Trailing garbage at EOF' },
+ isa_not_first => { message => 'EDI file must start with an ISA segment' },
+ nonunique_delims => { message => 'Delimiters are not unique' },
+);
+
+sub logerror {
+ my ($self, $code) = splice @_,0,2;
+
+ my $def = $errdefs{$code} or Carp::croak "Undefined error $code";
+
+ push @{ $self->errors }, X12::Schema::SyntaxError->new(
+ code => $code, message => $def->{message}
+ );
+}
+
__PACKAGE__->meta->make_immutable;
View
@@ -1,13 +1,14 @@
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 17;
BEGIN { use_ok('X12::Schema::TokenSource') or die }
my $O;
my $ISA1 = 'ISA*00* *00* *ZZ*TEST *ZZ*TEST *010101*1200*U*00401*000001208*0*P*/~';
my $ISA2 = 'ISA*00* *00* *ZZ*TEST *ZZ*TEST *010101*1200*U*00402*000001208*0*P*/~';
+my $ISA3 = 'ISA*00* *00* *ZZ*TEST *ZZ*TEST *010101*1200*~*00402*000001208*0*P*/~';
$O = new_ok 'X12::Schema::TokenSource', [ buffer => "${ISA1}FOO*BUR~" ], "create source with 2 tokens";
@@ -24,11 +25,29 @@ is_deeply $O->peek_code, '', 'peek_code on empty is ""';
is $O->segment_counter, 2, "segment_counter counts actually used segments";
+$O->expect_eof;
+is_deeply $O->errors, [], "no errors";
-$O = X12::Schema::TokenSource->new(buffer => "${ISA2}\r\nFOO*BUR/S*A/B~\r\n");
+$O = X12::Schema::TokenSource->new(buffer => "${ISA2}\r\nFOO*BUR/S*A/B~\r\nK");
$O->get;
is_deeply $O->get, [ [['FOO']], [['B'],['R','S']], [['A','B']] ], "parsing test for 'advanced features'";
+is_deeply $O->errors, [], "no errors";
+$O->expect_eof;
+
+is_deeply [map $_->code, @{$O->errors}], ['garbage'], 'trailing garbage noticed by expect_eof';
+
+$O = X12::Schema::TokenSource->new(buffer => "${ISA3}\r\nFOO*BUR/S*A/B~\r\n");
+$O->get;
+
+is_deeply [map $_->code, @{$O->errors}], ['nonunique_delims'], 'delimiter collision noticed';
+
+$O = X12::Schema::TokenSource->new(buffer => "FOO*BUR/S*A/B~\r\n");
+$O->get;
+$O->get;
+
+is_deeply [map $_->code, @{$O->errors}], ['isa_not_first'], 'missing ISA noticed';
+
View
@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+use Test::More tests => 15;
+use Test::Exception;
+
+use X12::Schema::Element;
+BEGIN { use_ok('X12::Schema::Segment') or die }
+use X12::Schema::TokenSink;
+
+# TODO: constraints will be redesigned for the parser, so don't test those
+
+my $sink = X12::Schema::TokenSink->new( element_sep => '*', segment_term => '~', component_sep => ':' );
+
+my $seg;
+
+
+$seg = new_ok 'X12::Schema::Segment', [ tag => 'FOO', friendly => 'Foo', elements => [
+ X12::Schema::Element->new( name => 'A', type => 'AN 5/5'),
+ X12::Schema::Element->new( name => 'B', type => 'AN 5/5'),
+] ], 'create, optional fields';
+
+throws_ok { $seg->encode($sink, undef) } qr/using a HASH/;
+throws_ok { $seg->encode($sink, 5) } qr/using a HASH/;
+throws_ok { $seg->encode($sink, []) } qr/using a HASH/;
+throws_ok { $seg->encode($sink, { C => 2 }) } qr/Excess fields/;
+throws_ok { $seg->encode($sink, { }) } qr/must contain data/;
+
+$sink->output('');
+lives_ok { $seg->encode($sink, { A => 'cow' }) } 'partial encode with suppressed sep lives';
+is $sink->output, 'FOO*cow ~', 'partial encode with suppressed sep right result';
+
+$sink->output('');
+lives_ok { $seg->encode($sink, { B => 'dog' }) } 'partial encode without suppressed sep lives';
+is $sink->output, 'FOO**dog ~', 'partial encode without suppressed sep right result';
+
+
+$seg = new_ok 'X12::Schema::Segment', [ tag => 'FOO', friendly => 'Foo', elements => [
+ X12::Schema::Element->new( name => 'A', type => 'AN 5/5', required => 1 ),
+ X12::Schema::Element->new( name => 'B', type => 'AN 5/5', required => 1 ),
+] ], 'create, required fields';
+
+throws_ok { $seg->encode($sink, { A => 'cow' }) } qr/B is required/;
+
+$sink->output('');
+lives_ok { $seg->encode($sink, { A => 'cow', B => 'dog' }) } 'encode with required fields';
+is $sink->output, 'FOO*cow *dog ~', '... right result';
+

0 comments on commit c98cf93

Please sign in to comment.