Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

We’re showing branches in this repository, but you can also compare across forks.

base fork: sorear/x12-schema
base: 587722d705
...
head fork: sorear/x12-schema
compare: 9030ae28f3
  • 4 commits
  • 7 files changed
  • 0 commit comments
  • 1 contributor
2  lib/X12/Schema/SyntaxNote.pm → lib/X12/Schema/Constraint.pm
View
@@ -1,4 +1,4 @@
-package X12::Schema::SyntaxNote;
+package X12::Schema::Constraint;
use Moose;
use namespace::autoclean;
6 lib/X12/Schema/Element.pm
View
@@ -58,7 +58,7 @@ sub encode {
}
if ($prec < 0) {
- die "Value $value canot fit in $maxp digits for ".$self->name."\n";
+ die "Value $value cannot fit in $maxp digits for ".$self->name."\n";
}
my $wid = 0;
@@ -75,12 +75,12 @@ sub encode {
my $wid = 0;
while (1) {
- $string = sprintf "%0*d", $wid, $value;
+ $string = sprintf "%0*.0f", $wid, $munge;
($string =~ tr/0-9//) >= $minp and last;
$wid++;
}
- ($string =~ tr/0-9//) >= $maxp and die "Value $value cannot fit in $maxp digits for ".$self->name."\n";
+ ($string =~ tr/0-9//) > $maxp and die "Value $value cannot fit in $maxp digits for ".$self->name."\n";
}
if ($type eq 'ID') {
219 lib/X12/Schema/Parser.pm
View
@@ -0,0 +1,219 @@
+package X12::Schema::Parser;
+
+use strict;
+use warnings;
+# not an instantiatable class
+
+sub _extract_tree {
+ my ($self, $file, $lines) = @_;
+
+ # contains all items for which there is no less-or-equal-indented item further down
+ my @open_items = ( { indent => -1, children => [] } );
+
+ my $lineno = 0;
+ for my $line (@$lines) {
+ $lineno++;
+
+ my ($indent, $body) = $line =~ /^([ \t]**)([^#]**)/;
+ $body =~ s/\s*$//;
+
+ die "$file:$lineno: Illegal hard tab\n" if $indent =~ /\t/;
+
+ next unless $body;
+ my $num_indent = length($indent);
+
+ while ($num_indent <= $open_items[-1]{indent}) {
+ pop @open_items;
+ }
+
+ # attach to nearest plausible ancestor, but enforce consistency
+
+ my $sibling_indent = $open_items[-1]{children} ? $open_items[-1]{children}[-1]{indent} : undef;
+
+ if (defined($sibling_indent) && $sibling_indent != $num_indent) {
+ die "$file:$lineno:Inconsistent indentation; previous sibling indented $sibling_indent, this indented $num_indent\n";
+ }
+
+ my @toks = split ' ', $body;
+ my $command = (@toks && $toks[0] =~ /:$/) ? shift(@toks) : '';
+ my @flags;
+ unshift @flags, pop @toks while @toks && $toks[-1] =~ /^\+/;
+
+ push @{ $open_items[-1]{children} }, { file => $file, line => $lineno, toks => \@toks, command => $command, flags => \@flags, indent => $num_indent, children => [] };
+ }
+
+ return $open_items[0]{children};
+}
+
+sub _noflags {
+ my ($node,$thing) = @_;
+ die "$node->{file}:$node->{line}:$thing does not accept flags\n" if @{ $node->{flags} };
+}
+
+sub _getflags {
+ my ($node,$thing,@flags) = @_;
+
+ my %fpassed;
+ for my $fstr (@{ $node->{flags} }) {
+ if ($fpassed{$fstr}++) { die "$node->{file}:$node->{line}:Duplicate flag $fstr\n" }
+ }
+
+ my @out;
+ while (@flags) {
+ my $fname = shift @flags;
+ push @out, delete($fpassed{$fname}) ? 1 : 0;
+ }
+
+ die "$node->{file}:$node->{line}:Invalid flag ".((sort keys %fpassed)[0])." for $thing, valid flags are: @flags\n" if %fpassed;
+
+ return @out;
+}
+
+sub _interpret_root {
+ my ($self, $node) = @_;
+
+ my $schema;
+ my %segments;
+
+ for my $z (@{ $node->{children} }) {
+ if ($z->{command} eq 'schema:') {
+ die "$z->{file}:$z->{line}:Duplicate schema definition\n" if $schema;
+ $schema = $z; # need to defer this until the segments exist
+ }
+ elsif ($z->{command} eq 'segment:') {
+ my $seg = $self->_interpret_segment($z);
+ die "$z->{file}:$z->{line}:Duplicate definition of segment ".$seg->tag."\n" if $segments{$seg->tag};
+ $segments{$seg->tag} = $seg;
+ }
+ else {
+ die "$z->{file}:$z->{line}:Root-level element in schema must be segment: or schema:\n";
+ }
+ }
+
+ die "$node->{file}:0:Missing schema: element\n" unless $schema;
+
+ return $self->_interpret_schema(\%segments, $schema);
+}
+
+sub _interpret_segment {
+ my ($self, $node) = @_;
+
+ my ($incomplete) = _getflags("node", "segment", "+incomplete");
+ die "$node->{file}:$node->{line}:Segment syntax is segment: SHRT FriendlyName\n" unless @{ $node->{toks} } == 2;
+
+ my ($short, $friendly) = @{ $node->{toks} };
+
+ my @elements;
+ my @constraints;
+
+ for my $z (@{ $node->{children} }) {
+ if ($z->{command} eq '') {
+ push @elements, $self->_interpret_element($z);
+ }
+ elsif ($z->{command} eq 'constraint:') {
+ push @constraints, $z; # delay so that we can check element names
+ }
+ else {
+ die "$z->{file}:$z->{line}:Child of a segment must be an element (unmarked) or a constraint:\n";
+ }
+ }
+
+ my %elem_ok = map { $_->name => 1 } @elements;
+ @constraints = map { $self->_interpret_constraint(\%elem_ok, $_) } @constraints;
+
+ return X12::Schema::Segment->new(
+ incomplete => $incomplete,
+ constraints => \@constraints,
+ elements => \@elements,
+ tag => $short,
+ name => $friendly,
+ );
+}
+
+sub _interpret_constraint {
+ my ($self, $elem_ok, $node) = @_;
+
+ _noflags($node);
+ my $reparse = join " ", @{ $node->{toks} };
+
+ my ($kind,$allelems) = $reparse =~ /^\s*(\w+)\s*\((\s*\w+\s*(?:,\s*\w+\s*)*)\)\s*$/
+ or die "$node->{file}:$node->{line}:Constraint syntax is constraint: kind( A, B, C )\n";
+
+ my @elems = split /,/, $allelems;
+ map { s/^\s+|\s+$//g } @elems;
+
+ @elems >= 2 or die "$node->{file}:$node->{line}:Constraint requires at least two elements\n";
+
+ my %uniq;
+ for my $e (@elems) {
+ die "$node->{file}:$node->{line}:No such element $e\n" unless $elem_ok->{$e};
+ die "$node->{file}:$node->{line}:Duplicate element $e\n" if $uniq{$e}++;
+ }
+
+ if ($kind eq 'all_or_none') {
+ return X12::Schema::Constraint->new( all_or_none => \@elems );
+ } elsif ($kind eq 'at_most_one') {
+ return X12::Schema::Constraint->new( at_most_one => \@elems );
+ } elsif ($kind eq 'at_least_one') {
+ return X12::Schema::Constraint->new( at_least_one => \@elems );
+ } elsif ($kind eq 'if_then_all') {
+ return X12::Schema::Constraint->new( if_present => shift(@elems), require_all => \@elems );
+ } elsif ($kind eq 'if_then_one') {
+ return X12::Schema::Constraint->new( if_present => shift(@elems), require_one => \@elems );
+ } else {
+ die "$node->{file}:$node->{line}:Invalid constraint type $kind, must be one of (all_or_none, at_most_one, at_least_one, if_then_all, if_then_one)\n";
+ }
+}
+
+sub _interpret_element {
+ my ($self, $node) = @_;
+
+ my ($required, $raw) = _getflags($node, 'element', '+required', '+raw');
+
+ @{ $node->{toks} } == 3 or die "$node->{file}:$node->{line}:Element definition must be of the form FriendlyName TYPE MIN/MAX [+flags]\n";
+ my ($name, $type, $size) = @{ $node->{toks} };
+
+ my (%expand, %unexpand);
+
+ die "$node->{file}:$node->{line}:+raw only permitted for ID\n" if $raw && $type ne 'ID';
+
+ for my $z (@{ $node->{children} }) {
+ die "$node->{file}:$node->{line}:Value definitions only permitted for ID-type elements without +raw\n" unless $type eq 'ID' && !$raw;
+ _noflags($z, "value");
+ my ($short, undef, $long) = @{ $z->{toks} };
+ die "$node->{file}:$node->{line}:Value definition must be of the form SHORT -> LONG\n" unless $z->{command} eq '' && @{ $z->{toks} } == 3 && $z->{toks}[1] eq '->';
+ die "$node->{file}:$node->{line}:Short value can contain only [0-9A-Z] chars\n" if $short =~ /[^0-9A-Z]/;
+ die "$node->{file}:$node->{line}:Duplicate short value $short\n" if $expand{$short};
+ die "$node->{file}:$node->{line}:Duplicate long value $short\n" if $unexpand{$long};
+ $expand{$short} = $long;
+ $unexpand{$long} = $short;
+ }
+
+ return X12::Schema::Element->new(
+ required => $required,
+ name => $name,
+ type => "$type $size",
+ (%expand ? (expand => \%expand) : ()),
+ );
+}
+
+sub _interpret_schema {
+ my ($self, $elems, $node) = @_;
+ _noflags($node,"schema");
+ return $self->_interpret_loop_body(1, 1, $elems, $node);
+}
+
+sub _interpret_loop_body {
+ my ($self, $min, $max, $elems, $node) = @_;
+
+ my @children;
+
+ for my $z (@{ $node->{children} }) {
+ if ($z->{command} eq 'loop:') {
+ _noflags($z,"loop");
+ (@{ $z->{toks} } == 1 && $z->{toks}[0] =~ /^(0|1):(N|\d+)$/) or die "$z->{file}:$z->{line}:Loop header must be of the form loop: [01]/ddd or [01]/N\n";
+ push @children, $self->_interpret_loop_body($1, $2, $elems, $z);
+ }
+ elsif ($z->{command} eq '') {
+ _noflags($z,"segment ref");
+ # what do we do with the name here
5 lib/X12/Schema/Segment.pm
View
@@ -6,15 +6,16 @@ use namespace::autoclean;
with 'X12::Schema::Sequencable';
has tag => (isa => 'Str', is => 'ro', required => 1);
-has syntax_notes => (isa => 'ArrayRef[X12::Schema::SyntaxNote]', is => 'ro', default => sub { [] });
+has constraints => (isa => 'ArrayRef[X12::Schema::Constraint]', is => 'ro', default => sub { [] });
has elements => (isa => 'ArrayRef[X12::Schema::Element]', is => 'ro', required => 1);
+has incomplete => (isa => 'Bool', is => 'ro', default => 0);
sub encode {
my ($self, $sink, $obj) = @_;
die 'Segment '.$self->name." must be encoded using a HASH\n" unless $obj && ref($obj) eq 'HASH' && !blessed($obj);
- $_->check($obj) for @{ $self->syntax_notes };
+ $_->check($obj) for @{ $self->constraints };
my %tmp = %$obj;
my @bits;
10 lib/X12/Schema/TokenSink.pm
View
@@ -5,7 +5,8 @@ use namespace::autoclean;
has delim_re => (is => 'ro', isa => 'RegexpRef', init_arg => undef);
-has [qw( segment_term element_sep repeat_sep component_sep )] => (is => 'ro', isa => 'Str', required => 1);
+has [qw( segment_term element_sep component_sep )] => (is => 'ro', isa => 'Str', required => 1);
+has repeat_sep => (is => 'ro', isa => 'Str');
has output => (is => 'rw', isa => 'Str', default => '', init_arg => undef);
has output_func => (is => 'rw', isa => 'CodeRef');
@@ -17,14 +18,15 @@ sub BUILD {
my %all_seps;
$self->segment_term =~ /^.\r?\n?$/ or confess "segment_term must be a single character, optionally followed by CR and/or LF";
- $all_seps{substr($self->segment_term,0,1)} = 1;
+ $all_seps{substr($self->segment_term,0,1)}++;
for (qw( element_sep repeat_sep component_sep )) {
+ $self->$_ or next;
length($self->$_) == 1 or confess "$_ must be a single character";
- $all_seps{$self->$_} = 1;
+ $all_seps{$self->$_}++;
}
- keys(%all_seps) == 4 or confess "all delimiters must be unique";
+ grep(($_ > 1), values %all_seps) and confess "all delimiters must be unique";
my $re = '[' . quotemeta(join '', sort keys %all_seps) . ']';
$self->{delim_re} = qr/$re/;
}
4 t/01-sink.t
View
@@ -1,13 +1,13 @@
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More tests => 26;
use Test::Exception;
BEGIN { use_ok "X12::Schema::TokenSink"; }
my %args = qw( segment_term s element_sep e repeat_sep r component_sep c );
-for my $t (sort keys %args) {
+for my $t (qw( segment_term element_sep component_sep )) {
local $args{$t}; delete $args{$t}; # delete local is a 5.12ism
throws_ok { X12::Schema::TokenSink->new( %args ) } qr/$t.*required/, "$t is required";
}
6 t/02-element.t
View
@@ -15,7 +15,7 @@ throws_ok { X12::Schema::Element->new(type => 'N 3/3') } qr/name.*required/;
throws_ok { X12::Schema::Element->new(name => 'Foo', type => 'X 2/3') } qr/type at BUILD must look like/;
throws_ok { X12::Schema::Element->new(name => 'Foo', type => 'ID 2/3') } qr/expand required/;
-throws_ok { X12::Schema::Element->new(name => 'Foo', type => 'R3 2/3') } qr/numeric postfix/;
+throws_ok { X12::Schema::Element->new(name => 'Foo', type => 'R3 2/3') } qr/Numeric postfix/;
sub elem_test {
my $type = shift;
@@ -69,8 +69,8 @@ elem_test('N0 3/5',
encode => -995, '-995',
encode => 99995, '99995',
encode => -99995, '-99995',
- encode => 99999.9, qr/Value 99999.9 cannot fit in 3 digits for/,
- encode => -99999.9, qr/Value -99999.9 cannot fit in 3 digits for/,
+ encode => 99999.9, qr/Value 99999.9 cannot fit in 5 digits for/,
+ encode => -99999.9, qr/Value -99999.9 cannot fit in 5 digits for/,
);
elem_test('N2 4/6',

No commit comments for this range

Something went wrong with that request. Please try again.