Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Add X12 control syntax parser, first pass
  • Loading branch information
sorear committed Mar 19, 2013
1 parent bd387fb commit cad6c39
Show file tree
Hide file tree
Showing 4 changed files with 174 additions and 5 deletions.
21 changes: 18 additions & 3 deletions lib/X12/Schema.pm
Expand Up @@ -6,7 +6,7 @@ use File::Slurp qw( read_file );


has root => (is => 'ro', isa => 'X12::Schema::Sequence', required => 1); has root => (is => 'ro', isa => 'X12::Schema::Sequence', required => 1);


sub parse { sub loadstring {
my ($pkg, %args) = @_; my ($pkg, %args) = @_;


require X12::Schema::Parser; # laziness, also avoid a circularity require X12::Schema::Parser; # laziness, also avoid a circularity
Expand All @@ -15,10 +15,25 @@ sub parse {
return X12::Schema::Parser->parse( $args{filename} || 'ANON', $args{text} ); return X12::Schema::Parser->parse( $args{filename} || 'ANON', $args{text} );
} }


sub parsefile { sub loadfile {
my ($pkg, %args) = @_; 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; __PACKAGE__->meta->make_immutable;
151 changes: 151 additions & 0 deletions lib/X12/Schema/ControlSyntaxX12.pm
@@ -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;
6 changes: 4 additions & 2 deletions lib/X12/Schema/Sequence.pm
Expand Up @@ -60,13 +60,15 @@ sub decode {
} }


for my $i ( 0 .. $#$kids ) { 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}) { if ($src->peek_code && !$internal_cont[$i]{$src->peek_code}) {
$src->get; $src->get;
die "Unexpected segment at ".$src->segment_counter."\n"; die "Unexpected segment at ".$src->segment_counter."\n";
} }


my $kid = $kids->[$i];

if (defined($kid->max_use) && $kid->max_use == 1) { if (defined($kid->max_use) && $kid->max_use == 1) {
if ($kid->_initial_tags->{ $src->peek_code }) { if ($kid->_initial_tags->{ $src->peek_code }) {
$data{ $kid->name } = $kid->decode( $src, $internal_cont[$i+1] ); $data{ $kid->name } = $kid->decode( $src, $internal_cont[$i+1] );
Expand Down
1 change: 1 addition & 0 deletions lib/X12/Schema/TokenSource.pm
Expand Up @@ -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 [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 segment_counter => (is => 'rw', isa => 'Int', default => 0);
has trace => (is => 'rw', isa => 'Int', default => 0);


sub _parse { sub _parse {
my ($self) = @_; my ($self) = @_;
Expand Down

0 comments on commit cad6c39

Please sign in to comment.