Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: sorear/x12-schema
base: aa14fa198f
...
head fork: sorear/x12-schema
compare: c75f0d9f70
Checking mergeability… Don't worry, you can still create the pull request.
  • 5 commits
  • 9 files changed
  • 0 commit comments
  • 1 contributor
View
4 lib/X12/Schema/Element.pm
@@ -96,6 +96,10 @@ sub encode {
$string = "".$value;
$string =~ s/ *$//;
+ length($string) or die "Value $value must have at least one non-space for ".$self->name."\n";
+ $string =~ /$sink->{non_charset_re}/ and die "Value $value contains a character outside the destination charset for ".$self->name."\n";
+ $string =~ /\P{Print}/ and die "Value $value contains a non-printable character for ".$self->name."\n";
+
length($string) > $maxp and die "Value $value does not fit in $maxp characters for ".$self->name."\n";
length($string) < $minp and $string .= (" " x ($minp - length($string)));
}
View
9 lib/X12/Schema/Segment.pm
@@ -12,7 +12,7 @@ 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);
+ die 'Segment '.$self->friendly." must be encoded using a HASH\n" unless $obj && ref($obj) eq 'HASH' && !blessed($obj);
$_->check($obj) for @{ $self->constraints };
@@ -33,11 +33,12 @@ sub encode {
}
}
- die "Excess fields for segment ".$self->name.": ".join(', ', sort keys %tmp) if %tmp;
+ die "Excess fields for segment ".$self->friendly.": ".join(', ', sort keys %tmp) if %tmp;
pop @bits while @bits && $bits[-1] eq '';
- $sink->segment( join($sink->element_sep, $self->tag, @bits) . $sink->segment_term ) if @bits;
- return @bits ? 1 : 0;
+ die "Segment ".$self->friendly." must contain data if it is present" unless @bits;
+
+ $sink->segment( join($sink->element_sep, $self->tag, @bits) . $sink->segment_term );
}
__PACKAGE__->meta->make_immutable;
View
12 lib/X12/Schema/SegmentUse.pm
@@ -5,23 +5,13 @@ use namespace::autoclean;
with 'X12::Schema::Sequencable';
-has def => (is => 'ro', isa => 'X12::Schema::Segment', required => 1);
-
-sub encode {
- my ($self, $sink, $obj) = @_;
-
- if (!$self->def->encode($sink, $obj) && $self->required) {
- die 'Segment '.$self->name." must contain data\n";
- }
-}
+has def => (is => 'ro', isa => 'X12::Schema::Segment', required => 1, handles => ['encode']);
sub BUILD {
my ($self) = @_;
# DIVERSITY: possibly worth restricting use of 'B' type here?
- # we can only be empty in the event that we are optional, but in that case
- # Sequence will automatically handle _can_be_empty and _ambiguous_end_tags.
$self->_can_be_empty(0);
$self->_ambiguous_end_tags({});
$self->_initial_tags({ $self->def->tag => 1 });
View
3  lib/X12/Schema/TokenSink.pm
@@ -4,12 +4,14 @@ use Moose;
use namespace::autoclean;
has delim_re => (is => 'ro', isa => 'RegexpRef', init_arg => undef);
+has non_charset_re => (is => 'ro', isa => 'RegexpRef', default => sub { qr/(?!)/ });
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');
+has segment_counter => (is => 'rw', isa => 'Int', default => 0, init_arg => undef);
# DIVERSITY: this will need to include flags to control the output in other ways, such as UN/EDIFACT mode, whether to use exponential notation, etc
@@ -34,6 +36,7 @@ sub BUILD {
sub segment {
my ($self, $seg) = @_;
+ $self->{segment_counter}++;
$self->{output_func} ? $self->{output_func}->($seg) : ( $self->{output} .= $seg );
}
View
40 lib/X12/Schema/TokenSource.pm
@@ -12,7 +12,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 isa11_is_repeat_sep => (is => 'ro', isa => 'Bool', default => 0);
+has segment_counter => (is => 'rw', isa => 'Int', default => 0);
sub _parse {
my ($self) = @_;
@@ -22,22 +22,26 @@ sub _parse {
my $ISA = substr($self->{buffer},0,106,"");
+ my $ver = substr($ISA, 84, 5);
+
$self->{_element_sep} = substr($ISA, 3, 1);
- $self->{_repeat_sep} = $self->{isa11_is_repeat_sep} ? substr($ISA, 82, 1) : undef;
+ $self->{_repeat_sep} = ($ver ge '00402') ? substr($ISA, 82, 1) : undef;
$self->{_component_sep} = substr($ISA, 104, 1);
$self->{_segment_term} = substr($ISA, 105, 1);
- ($self->{_segment_term_suffix}) = ($self->{buffer} =~ s/^(\r?\n?)//);
+ $self->{buffer} =~ s/^(\r?\n?)//;
+ $self->{_segment_term_suffix} = $1;
$self->_delims_changed;
- # not quite a regular segment: values may include the component separator
+ # not quite a regular segment: values may include the component/repeat separator
return [ map [[$_]], split /\Q$self->{_element_sep}/, substr($ISA,0,105) ];
}
# DIVERSITY: UNx, BIN, BDS segments, maybe X12.58 but I don't have a clear idea what that entails
- my ($segment) = $self->{buffer} =~ s/$self->{_segment_re}// or return;
+ $self->{buffer} =~ s/$self->{_segment_re}// or return;
+ my $segment = $1;
# DIVERSITY: EDIFACT release characters
@@ -59,30 +63,36 @@ sub _delims_changed {
$self->{_segment_re} = "^([^\Q$t\E]*)\Q$t$ts\E";
}
-sub get {
+sub peek {
my ($self) = @_;
- return delete $self->{_lookahead} if $self->{_lookahead};
+ return $self->{_lookahead} if $self->{_lookahead};
my $res;
while (1) {
- $res = $self->_parse and return $res;
+ $res = $self->_parse and return $self->{_lookahead} = $res;
$self->filler->() or return ();
}
}
-sub peek {
+sub get {
my ($self) = @_;
- return $self->{_lookahead} if $self->{_lookahead};
+ $self->peek;
+ if ($self->{_lookahead}) {
+ $self->{segment_counter}++;
+ return delete $self->{_lookahead};
+ }
+ return undef;
+}
- my $res;
+sub peek_code {
+ my ($self) = @_;
- while (1) {
- $res = $self->_parse and return $self->{_lookahead} = $res;
- $self->filler->() or return ();
- }
+ $self->peek;
+
+ return !$self->{_lookahead} ? '' : $self->{_lookahead}[0][0][0]; # DIVERSITY explicit nesting needs more info
}
__PACKAGE__->meta->make_immutable;
View
4 t/01-sink.t
@@ -1,6 +1,6 @@
use strict;
use warnings;
-use Test::More tests => 26;
+use Test::More tests => 28;
use Test::Exception;
BEGIN { use_ok "X12::Schema::TokenSink"; }
@@ -55,9 +55,11 @@ my $ext = '';
$baseline = new_ok 'X12::Schema::TokenSink', [%args, output_func => sub { $ext .= $_[0] }], 'new with output_func';
is $ext, '', 'external output initially empty';
+is $baseline->segment_counter, 0, 'ctr initially 0';
$baseline->segment('foo');
is $ext, 'foo', 'first external output recorded';
$baseline->segment('bar');
is $ext, 'foobar', 'subseq external output recorded';
+is $baseline->segment_counter, 2, 'ctr records segments';
View
34 t/02-source.t
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+use Test::More tests => 12;
+
+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*/~';
+
+$O = new_ok 'X12::Schema::TokenSource', [ buffer => "${ISA1}FOO*BUR~" ], "create source with 2 tokens";
+
+is ref($O->get), 'ARRAY', 'can read ISA';
+
+is_deeply $O->peek, [ [['FOO']], [['BUR']] ], 'can peek next';
+is_deeply $O->peek, [ [['FOO']], [['BUR']] ], 'can peek next twice';
+is $O->peek_code, 'FOO', 'peek-code';
+is_deeply $O->get, [ [['FOO']], [['BUR']] ], 'can get peeked value';
+
+ok !defined($O->peek), 'peek on empty is undef';
+ok !defined($O->get), 'get on empty is undef';
+is_deeply $O->peek_code, '', 'peek_code on empty is ""';
+
+is $O->segment_counter, 2, "segment_counter counts actually used segments";
+
+
+
+$O = X12::Schema::TokenSource->new(buffer => "${ISA2}\r\nFOO*BUR/S*A/B~\r\n");
+
+$O->get;
+
+is_deeply $O->get, [ [['FOO']], [['B'],['R','S']], [['A','B']] ], "parsing test for 'advanced features'";
+
View
11 t/02-element.t → t/03-element.t
@@ -1,12 +1,12 @@
use strict;
use warnings;
-use Test::More tests => 114;
+use Test::More tests => 121;
use Test::Exception;
BEGIN { use_ok 'X12::Schema::Element'; }
use X12::Schema::TokenSink;
-my $sink = X12::Schema::TokenSink->new( element_sep => '*', segment_term => "~\n", component_sep => '\\', repeat_sep => '^' );
+my $sink = X12::Schema::TokenSink->new( element_sep => '*', segment_term => "~\n", component_sep => '\\', repeat_sep => '^', non_charset_re => qr/[^\x00-\xFF]/ );
my $el;
@@ -14,7 +14,7 @@ throws_ok { X12::Schema::Element->new(name => 'Foo') } qr/type.*required/;
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 => 'R 2/3', expand => { }) } qr/expand/;
throws_ok { X12::Schema::Element->new(name => 'Foo', type => 'R3 2/3') } qr/Numeric postfix/;
sub elem_test {
@@ -98,6 +98,11 @@ elem_test('AN 2/4',
encode => 'FFFF' => 'FFFF',
encode => 'FFFFF' => qr/Value FFFFF does not fit in 4 characters for/,
encode => 'F^' => qr/Value F\^ after encoding would contain a prohibited delimiter.*/,
+ encode => 'F ' => 'F ',
+ encode => ' F ' => ' F',
+ encode => ' ' => qr/one non-space.*/,
+ encode => "\r" => qr/non-print.*/,
+ encode => "\x{3BB}" => qr/charset.*/,
);
elem_test('DT 6/6',
View
0  t/03-parser.t → t/04-parser.t
File renamed without changes

No commit comments for this range

Something went wrong with that request. Please try again.