Skip to content

Commit

Permalink
Test successful parser function
Browse files Browse the repository at this point in the history
  • Loading branch information
@sorear
sorear committed Mar 14, 2013
1 parent 3a5618e commit cba7e38
Show file tree
Hide file tree
Showing 3 changed files with 123 additions and 4 deletions.
6 changes: 4 additions & 2 deletions lib/X12/Schema/Element.pm
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -25,7 +25,7 @@ sub BUILD {
$self->{type} =~ /^(N|AN|DT|TM|ID|R|B)(\d*) (\d+)\/(\d+)$/ or confess "type at BUILD must look like N5 10/20"; $self->{type} =~ /^(N|AN|DT|TM|ID|R|B)(\d*) (\d+)\/(\d+)$/ or confess "type at BUILD must look like N5 10/20";


confess "Numeric postfix used only with N" if $1 ne 'N' && $2; # N means N0 confess "Numeric postfix used only with N" if $1 ne 'N' && $2; # N means N0
confess "expand required iff type = ID" if ($1 eq 'ID') != (defined $self->expand); confess "expand used only with type = ID" if ($1 ne 'ID') && (defined $self->expand);


$self->{type} = $1; $self->{type} = $1;
$self->{scale} = $2 || 0; $self->{scale} = $2 || 0;
Expand Down Expand Up @@ -84,7 +84,9 @@ sub encode {
} }


if ($type eq 'ID') { if ($type eq 'ID') {
$value = ($self->contract->{$value} || die "Value $value not contained in ".join(', ',sort keys %{$self->contract})." for ".$self->name."\n"); if ($self->contract) {
$value = ($self->contract->{$value} || die "Value $value not contained in ".join(', ',sort keys %{$self->contract})." for ".$self->name."\n");
}
$type = "AN"; $type = "AN";


# deliberate fall through # deliberate fall through
Expand Down
2 changes: 1 addition & 1 deletion lib/X12/Schema/Sequencable.pm
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ use namespace::autoclean;


has name => (isa => 'Str', is => 'ro', required => 1); has name => (isa => 'Str', is => 'ro', required => 1);
has required => (isa => 'Bool', is => 'ro'); has required => (isa => 'Bool', is => 'ro');
has max_use => (isa => 'Int', is => 'ro', default => 1); has max_use => (isa => 'Maybe[Int]', is => 'ro', default => 1);


# these should be set at BUILD # these should be set at BUILD
has _can_be_empty => (isa => 'Bool', is => 'rw', init_arg => undef); has _can_be_empty => (isa => 'Bool', is => 'rw', init_arg => undef);
Expand Down
119 changes: 118 additions & 1 deletion t/03-parser.t
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@ use strict;
use warnings; use warnings;


use File::Slurp qw( read_file ); use File::Slurp qw( read_file );
use Test::More tests => 40; use Test::More tests => 45;
use Try::Tiny; use Try::Tiny;


BEGIN { use_ok('X12::Schema::Parser') or die; } BEGIN { use_ok('X12::Schema::Parser') or die; }
Expand All @@ -18,14 +18,17 @@ for my $ex (@examples) {


my $result; my $result;


local $@;
my $expect = ($output =~ /^(_F.*)/) ? [ FAIL => $1 ] : [ OK => eval $output ]; my $expect = ($output =~ /^(_F.*)/) ? [ FAIL => $1 ] : [ OK => eval $output ];
die $@ if $@;


try { try {
$result = [ 'OK', X12::Schema::Parser->parse( '_F', $input ) ]; $result = [ 'OK', X12::Schema::Parser->parse( '_F', $input ) ];
} catch { } catch {
chomp; $result = [ 'FAIL', $_ ]; chomp; $result = [ 'FAIL', $_ ];
}; };


use Data::Dumper;
is_deeply( $result, $expect, $name ); is_deeply( $result, $expect, $name );
} }


Expand Down Expand Up @@ -310,3 +313,117 @@ schema: foo
loop: BOB loop: BOB
==> ==>
_F:2:Loop header must be of the form loop: HashKey [01]/ddd or HashKey [01]/N _F:2:Loop header must be of the form loop: HashKey [01]/ddd or HashKey [01]/N
#### Now let's test some VALID syntax
--- minimal valid
schema: foo
FOO Foo1 1/1
segment: FOO Foo2
A AN 1/1
==>
my $FOO = X12::Schema::Segment->new( tag => 'FOO', friendly => 'Foo2', elements => [
X12::Schema::Element->new( name => 'A', type => 'AN 1/1' )
] );
X12::Schema->new(root => X12::Schema::Sequence->new( required => 1, max_use => 1, name => 'ROOT', children => [
X12::Schema::SegmentUse->new( def => $FOO, name => 'Foo1', required => 1, max_use => 1 )
] ) );
# this may break if we start verifying that constraints are logically compatible...
--- constraints: all features
schema: foo
FOO Foo1 1/1
segment: FOO Foo2
A AN 1/1
B AN 1/1
C AN 1/1
constraint: all_or_none(B, A)
constraint: at_most_one ( A ,B)
constraint: at_least_one ( A,B )
constraint: if_then_one(A,B)
constraint: if_then_all(A,B,C)
==>
my $FOO = X12::Schema::Segment->new( tag => 'FOO', friendly => 'Foo2', elements => [
X12::Schema::Element->new( name => 'A', type => 'AN 1/1' ),
X12::Schema::Element->new( name => 'B', type => 'AN 1/1' ),
X12::Schema::Element->new( name => 'C', type => 'AN 1/1' ),
], constraints => [
X12::Schema::Constraint->new( all_or_none => [ 'B', 'A' ] ),
X12::Schema::Constraint->new( at_most_one => [ 'A', 'B' ] ),
X12::Schema::Constraint->new( at_least_one => [ 'A', 'B' ] ),
X12::Schema::Constraint->new( if_present => 'A', require_one => [ 'B' ] ),
X12::Schema::Constraint->new( if_present => 'A', require_all => [ 'B', 'C' ] ),
]);
X12::Schema->new(root => X12::Schema::Sequence->new( required => 1, max_use => 1, name => 'ROOT', children => [
X12::Schema::SegmentUse->new( def => $FOO, name => 'Foo1', required => 1, max_use => 1 )
] ) );
--- elements: all features
schema: foo
FOO Foo1 1/1
segment: FOO Foo2
A AN 1/1
B AN 1/10 +required
C ID 2/2
US -> UnitedStates
CA -> Canada
D ID 2/2 +raw
==>
my $FOO = X12::Schema::Segment->new( tag => 'FOO', friendly => 'Foo2', elements => [
X12::Schema::Element->new( name => 'A', type => 'AN 1/1' ),
X12::Schema::Element->new( name => 'B', type => 'AN 1/10', required => 1 ),
X12::Schema::Element->new( name => 'C', type => 'ID 2/2', expand => { US => 'UnitedStates', CA => 'Canada' } ),
X12::Schema::Element->new( name => 'D', type => 'ID 2/2' ),
] );
X12::Schema->new(root => X12::Schema::Sequence->new( required => 1, max_use => 1, name => 'ROOT', children => [
X12::Schema::SegmentUse->new( def => $FOO, name => 'Foo1', required => 1, max_use => 1 )
] ) );
--- segments: all features
schema: foo
FO1 Foo1 1/1
FO2 Foo2 1/N
FO3 Foo3 0/1
segment: FO1 Foo
A AN 1/1
segment: FO2 Foo
A AN 1/1
segment: FO3 Foo +incomplete
A AN 1/1
==>
my %S; $S{$_} = X12::Schema::Segment->new( tag => $_, friendly => 'Foo', incomplete => ($_ eq 'FO3' ? 1 : 0), elements => [
X12::Schema::Element->new( name => 'A', type => 'AN 1/1' )
] ) for qw( FO1 FO2 FO3 );
X12::Schema->new(root => X12::Schema::Sequence->new( required => 1, max_use => 1, name => 'ROOT', children => [
X12::Schema::SegmentUse->new( def => $S{FO1}, name => 'Foo1', required => 1, max_use => 1 ),
X12::Schema::SegmentUse->new( def => $S{FO2}, name => 'Foo2', required => 1, max_use => undef ),
X12::Schema::SegmentUse->new( def => $S{FO3}, name => 'Foo3', required => 0, max_use => 1 )
] ) );
--- again, with loops
segment: FO1 Foo
A AN 1/1
schema: foo
loop: L1 1/1
FO1 Foo1 1/1
loop: L2 1/N
FO2 Foo2 1/1
loop: L3 0/1
FO3 Foo3 1/1
segment: FO2 Foo
A AN 1/1
segment: FO3 Foo
A AN 1/1
==>
my %S; $S{$_} = X12::Schema::Segment->new( tag => $_, friendly => 'Foo', elements => [
X12::Schema::Element->new( name => 'A', type => 'AN 1/1' )
] ) for qw( FO1 FO2 FO3 );
X12::Schema->new(root => X12::Schema::Sequence->new( required => 1, max_use => 1, name => 'ROOT', children => [
X12::Schema::Sequence->new( required => 1, max_use => 1, name => 'L1', children => [
X12::Schema::SegmentUse->new( def => $S{FO1}, name => 'Foo1', required => 1, max_use => 1 ) ]),
X12::Schema::Sequence->new( required => 1, max_use => undef, name => 'L2', children => [
X12::Schema::SegmentUse->new( def => $S{FO2}, name => 'Foo2', required => 1, max_use => 1 ) ]),
X12::Schema::Sequence->new( required => '', max_use => 1, name => 'L3', children => [
X12::Schema::SegmentUse->new( def => $S{FO3}, name => 'Foo3', required => 1, max_use => 1 ) ]),
] ) );

0 comments on commit cba7e38

Please sign in to comment.