Permalink
Browse files

Add X12 control syntax parser, first pass

  • Loading branch information...
1 parent bd387fb commit cad6c3933ca9fbd1144b8c04bbd83a3007d7e5e9 @sorear committed Mar 19, 2013
Showing with 174 additions and 5 deletions.
  1. +18 −3 lib/X12/Schema.pm
  2. +151 −0 lib/X12/Schema/ControlSyntaxX12.pm
  3. +4 −2 lib/X12/Schema/Sequence.pm
  4. +1 −0 lib/X12/Schema/TokenSource.pm
View
@@ -6,7 +6,7 @@ use File::Slurp qw( read_file );
has root => (is => 'ro', isa => 'X12::Schema::Sequence', required => 1);
-sub parse {
+sub loadstring {
my ($pkg, %args) = @_;
require X12::Schema::Parser; # laziness, also avoid a circularity
@@ -15,10 +15,25 @@ sub parse {
return X12::Schema::Parser->parse( $args{filename} || 'ANON', $args{text} );
}
-sub parsefile {
+sub loadfile {
my ($pkg, %args) = @_;
- return $pkg->parse( filename => $args{file}, text => scalar(read_file($args{file})) );
+ return $pkg->loadstring( filename => $args{file}, text => scalar(read_file($args{file})) );
+}
+
+sub parse {
+ my ($self, $text) = @_;
+
+ require X12::Schema::TokenSource;
+ require X12::Schema::ControlSyntaxX12;
+
+ my $src = X12::Schema::TokenSource->new( buffer => $text );
+ my $ctl = X12::Schema::ControlSyntaxX12->new( tx_set_def => $self->root );
+
+ my $interchange = $ctl->parse_interchange( $src );
+ $src->expect_eof;
+
+ return $interchange;
}
__PACKAGE__->meta->make_immutable;
@@ -0,0 +1,151 @@
+package X12::Schema::ControlSyntaxX12;
+
+use Moose;
+use namespace::autoclean;
+
+use X12::Schema::Segment;
+use X12::Schema::Element;
+
+has '_segments' => (is => 'bare');
+has 'tx_set_def' => (is => 'ro', isa => 'X12::Schema::Sequence', required => 1);
+
+sub _setup {
+ my ($self, $vers) = @_;
+
+ $self->{_segments} = {
+ ISA => X12::Schema::Segment->new(
+ tag => 'ISA', friendly => 'ISA',
+ elements => [
+ X12::Schema::Element->new( name => 'AuthQual', required => 1, type => 'ID 2/2', expand => { '00' => 'None', '01' => 'UCS', '02' => 'EDX', '03' => 'AdditionalData', '04' => 'Rail', '05' => 'DoD', '06' => 'Federal' } ),
+ X12::Schema::Element->new( name => 'Auth', required => 1, type => 'AN 10/10', allow_blank => 1 ),
+ X12::Schema::Element->new( name => 'SecQual', required => 1, type => 'ID 2/2', expand => { '00' => 'None', '01' => 'Password' } ),
+ X12::Schema::Element->new( name => 'Sec', required => 1, type => 'AN 10/10', allow_blank => 1 ),
+ X12::Schema::Element->new( name => 'SenderQual', required => 1, type => 'ID 2/2' ),
+ X12::Schema::Element->new( name => 'Sender', required => 1, type => 'AN 15/15' ),
+ X12::Schema::Element->new( name => 'ReceiverQual', required => 1, type => 'ID 2/2' ),
+ X12::Schema::Element->new( name => 'Receiver', required => 1, type => 'AN 15/15' ),
+ X12::Schema::Element->new( name => 'Date', required => 1, type => 'DT 6/6' ),
+ X12::Schema::Element->new( name => 'Time', required => 1, type => 'TM 4/4' ),
+ X12::Schema::Element->new( name => 'ISA11', required => 1, $vers ge '00402' ? (type => 'B 1/1') : (type => 'ID 1/1', expand => { U => 'US' }) ),
+ X12::Schema::Element->new( name => 'Version', required => 1, type => 'ID 5/5' ),
+ X12::Schema::Element->new( name => 'InterchangeNo', required => 1, type => 'N 9/9' ),
+ X12::Schema::Element->new( name => 'AckRequested', required => 1, type => 'ID 1/1', expand => { 0 => 0, 1 => 1 } ),
+ X12::Schema::Element->new( name => 'Usage', required => 1, type => 'ID 1/1', expand => { P => 'Production', T => 'Test' } ),
+ X12::Schema::Element->new( name => 'ComponentSep', required => 1, type => 'B 1/1' ),
+ ]
+ ),
+ GS => X12::Schema::Segment->new(
+ tag => 'GS', friendly => 'GS',
+ elements => [
+ X12::Schema::Element->new( name => 'FunctionCode', required => 1, type => 'ID 2/2' ),
+ X12::Schema::Element->new( name => 'Sender', required => 1, type => 'AN 2/15' ),
+ X12::Schema::Element->new( name => 'Receiver', required => 1, type => 'AN 2/15' ),
+ X12::Schema::Element->new( name => 'Date', required => 1, type => 'DT 8/8' ),
+ X12::Schema::Element->new( name => 'Time', required => 1, type => 'TM 4/8' ),
+ X12::Schema::Element->new( name => 'GroupNo', required => 1, type => 'N0 1/9' ),
+ X12::Schema::Element->new( name => 'VersionQual', required => 1, type => 'ID 1/2', expand => { T => "TDCC", X => "X12" } ),
+ X12::Schema::Element->new( name => 'Version', required => 1, type => 'AN 1/12' ),
+ ]
+ ),
+ ST => X12::Schema::Segment->new(
+ tag => 'ST', friendly => 'ST',
+ elements => [
+ X12::Schema::Element->new( name => 'Type', required => 1, type => 'ID 3/3' ),
+ X12::Schema::Element->new( name => 'TxSetNo', required => 1, type => 'AN 4/9' ),
+ ]
+ ),
+
+ SE => X12::Schema::Segment->new(
+ tag => 'SE', friendly => 'SE',
+ elements => [
+ X12::Schema::Element->new( name => 'SegmentCount', required => 1, type => 'N0 1/10' ),
+ X12::Schema::Element->new( name => 'TxSetNo', required => 1, type => 'AN 4/9' ),
+ ]
+ ),
+ GE => X12::Schema::Segment->new(
+ tag => 'GE', friendly => 'GE',
+ elements => [
+ X12::Schema::Element->new( name => 'SetCount', required => 1, type => 'N0 1/6' ),
+ X12::Schema::Element->new( name => 'GroupNo', required => 1, type => 'N0 1/9' ),
+ ]
+ ),
+ IEA => X12::Schema::Segment->new(
+ tag => 'IEA', friendly => 'IEA',
+ elements => [
+ X12::Schema::Element->new( name => 'GroupCount', required => 1, type => 'N0 1/5' ),
+ X12::Schema::Element->new( name => 'InterchangeNo', required => 1, type => 'N0 9/9' ),
+ ]
+ ),
+ };
+}
+
+sub parse_interchange {
+ my ($self, $source) = @_;
+
+ die "Interchange must start with ISA\n" unless $source->peek_code eq 'ISA';
+ my $ver = $source->peek->[12][0][0];
+ $ver =~ /^[0-9]{5}$/ or die "Malformed interchange syntax version number\n";
+
+ $self->_setup($ver);
+ my $ISA = $self->{_segments}{ISA}->decode( $source );
+
+ my $isa_time = delete $ISA->{Time};
+ $ISA->{Date}->set( map( ($_ => $isa_time->$_) , qw( hour minute second nanosecond ) ) );
+
+ my @groups;
+
+ while ($source->peek_code eq 'GS') {
+ my $GS = $self->{_segments}{GS}->decode( $source );
+ my @txsets;
+ my %txsetids;
+ # DIVERSITY: we may need to execute a syntax switch here at some point
+
+ my $gs_time = delete $GS->{Time};
+ $GS->{Date}->set( map( ($_ => $gs_time->$_) , qw( hour minute second nanosecond ) ) );
+
+ while ($source->peek_code eq 'ST') {
+ my $icount = $source->segment_counter;
+ my $ST = $self->{_segments}{ST}->decode( $source );
+
+ # DIVERSITY: will need to select this on the basis of $ST->{Type}
+ my $defn = $self->tx_set_def;
+
+ #my $defn = $self->types->{ "$GS->{VersionQual} $GS->{Version} $ST->{Type}" }
+ # or die "No schema available for standard=$GS->{VersionQual} $GS->{Version} transaction set type=$ST->{Type}\n";
+
+ my $body = $defn->decode( $source, { SE => 1 } );
+
+ die "Expected SE after transaction set, found ".$source->peek_code."\n" unless $source->peek_code eq 'SE';
+ my $SE = $self->{_segments}{SE}->decode( $source );
+ my $count = $source->segment_counter - $icount;
+
+ die "Transaction set control numbers $ST->{TxSetNo} in header and $SE->{TxSetNo} in footer do not match\n" unless $ST->{TxSetNo} eq $SE->{TxSetNo};
+ die "Transaction set $ST->{TxSetNo} claims $SE->{SegmentCount} children but has $count\n" if $count != $SE->{SegmentCount};
+ die "Transaction set identifier $ST->{TxSetNo} used more than once\n" if $txsetids{$ST->{TxSetNo}}++;
+
+ push @txsets, { ID => $ST->{TxSetNo}, Code => $ST->{Type}, Data => $body };
+ }
+
+ die "Expected GE after group $GS->{GroupNo}, found ".$source->peek_code."\n" if $source->peek_code ne 'GE';
+ my $GE = $self->{_segments}{GE}->decode( $source );
+
+ die "Group control numbers $GS->{GroupNo} in header and $GE->{GroupNo} in footer do not match\n" if $GS->{GroupNo} != $GE->{GroupNo};
+ die "Group $GS->{GroupNo} claims $GE->{SetCount} children but has ${\ scalar @txsets }\n" if @txsets != $GE->{SetCount};
+
+ push @groups, { %$GS, TransactionSets => \@txsets };
+ }
+
+ die "Expected IEA after interchange $ISA->{InterchangeNo}, found ".$source->peek_code."\n" if $source->peek_code ne 'IEA';
+ my $IEA = $self->{_segments}{IEA}->decode( $source );
+
+ die "Interchange control numbers $ISA->{InterchangeNo} in header and $IEA->{InterchangeNo} in footer do not match\n" if $ISA->{InterchangeNo} != $IEA->{InterchangeNo};
+ die "Interchange $ISA->{InterchangeNo} claims $IEA->{Count} children but has ${\ scalar @groups }\n" if @groups != $IEA->{GroupCount};
+
+ return { %$ISA, Groups => \@groups };
+}
+
+sub emit_interchange {
+ my ($self, $sink, $delims, $data) = @_;
+}
+
+__PACKAGE__->meta->make_immutable;
@@ -60,13 +60,15 @@ sub decode {
}
for my $i ( 0 .. $#$kids ) {
+ my $kid = $kids->[$i];
+
+ printf "Looking for %s at %d (%s)\n", join('|', sort keys %{ $kid->_initial_tags }), $src->segment_counter+1, $src->peek_code
+ if $src->trace > 0;
if ($src->peek_code && !$internal_cont[$i]{$src->peek_code}) {
$src->get;
die "Unexpected segment at ".$src->segment_counter."\n";
}
- my $kid = $kids->[$i];
-
if (defined($kid->max_use) && $kid->max_use == 1) {
if ($kid->_initial_tags->{ $src->peek_code }) {
$data{ $kid->name } = $kid->decode( $src, $internal_cont[$i+1] );
@@ -13,6 +13,7 @@ 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 trace => (is => 'rw', isa => 'Int', default => 0);
sub _parse {
my ($self) = @_;

0 comments on commit cad6c39

Please sign in to comment.