Permalink
Browse files

WIP 1

  • Loading branch information...
1 parent 52a71de commit eac246988f110707224332595e2020eda5bb68f0 @sorear committed Mar 8, 2013
Showing with 350 additions and 0 deletions.
  1. +17 −0 Makefile.PL
  2. +104 −0 lib/X12/Schema/Element.pm
  3. +55 −0 lib/X12/Schema/Segment.pm
  4. +18 −0 lib/X12/Schema/Sequencable.pm
  5. +104 −0 lib/X12/Schema/Sequence.pm
  6. +52 −0 lib/X12/Schema/SyntaxNote.pm
View
@@ -0,0 +1,17 @@
+#!/usr/bin/env perl
+# IMPORTANT: if you delete this file your app will not work as
+# expected. You have been warned.
+use inc::Module::Install;
+
+name 'GTCore';
+all_from 'lib/GTCore.pm';
+
+requires 'parent';
+requires 'DBR';
+requires 'MIME::Base64' => 3.11;
+requires 'Crypt::OpenSSL::DSA' => 0.01;
+requires 'Moose' => 2.04;
+
+#install_script glob('script/*.pl');
+#auto_install;
+WriteAll;
@@ -0,0 +1,104 @@
+package X12::Schema::Element;
+
+use Moose;
+use namespace::autoclean;
+
+has name => (is => 'ro', isa => 'Str', required => 1);
+has required => (is => 'ro', isa => 'Bool', default => 0);
+
+has type => (is => 'ro', isa => 'Str', required => 1);
+has expand => (is => 'ro', isa => 'HashRef[Str]');
+
+has scale => (is => 'ro', isa => 'Int', init_arg => undef);
+has min_length => (is => 'ro', isa => 'Int', init_arg => undef);
+has max_length => (is => 'ro', isa => 'Int', init_arg => undef);
+has contract => (is => 'ro', isa => 'HashRef[Str]', init_arg => undef);
+
+sub BUILD {
+ my ($self) = @_;
+
+ $self->{type} =~ /^(N|AN|DT|TM|ID|R)(\d*) (\d+)\/(\d+)$/ or confess "type at BUILD must look like N5 10/20";
+
+ confess "Numeric postfix used only with N" if ($1 eq 'N') != ($2 ne '');
+ confess "expand required iff type = ID" if ($1 eq 'ID') != (defined $self->expand);
+
+ confess "Unsupported date format $self->{type}" if ($1 eq 'DT') && (($3 != $4) || ($3 != 6 && $3 != 8));
+ confess "Unsupported time format $self->{type}" if ($1 eq 'TM') && (($3 != $4) || ($3 != 6 && $3 != 8 && $3 != 4));
+
+ $self->{type} = $1;
+ $self->{scale} = $2 if $2;
+ $self->{min_length} = $3;
+ $self->{min_length} = $4;
+
+ $self->{contract} = $self->expand && { reverse %{ $self->expand } };
+}
+
+sub encode {
+ my ($self, $sink, $value) = @_;
+
+ my $cookvalue;
+ my $type = $self->{type};
+ my $maxp = $self->{max_length};
+ my $minp = $self->{min_length};
+
+ # let's assume no-one is dumb enough to pick 0-9, +, -, . as seps
+ # can't just use sprintf for these two because field widths are in _digits_. sign magnitude hoy!
+ if ($type eq 'R') {
+
+ my $prec = $maxp - 1;
+ my $string;
+
+ # this is a lot more complicated than it might otherwise be because the # of digits to the left of the decimal might increase after rounding on the right...
+
+ while ($prec >= 0) {
+ $string = sprintf "%.*f", $prec, $value;
+ ($string =~ tr/0-9//) <= $maxp and last;
+ $prec--;
+ }
+
+ if ($prec < 0) {
+ die "Value $value canot fit in $maxp digits for ".$self->name;
+ }
+
+ my $wid = 0;
+
+ while (1) {
+ $string = sprintf "%0*.*f", $wid, $prec, $value;
+ ($string =~ tr/0-9//) >= $minp and last;
+ $wid++;
+ }
+
+ return $string; # phew!
+ }
+
+ if ($type eq 'N') {
+ my $munge = $value * (10 ** $self->{scale});
+ my $string;
+ my $wid = 0;
+
+ while (1) {
+ $string = sprintf "%0*d", $wid, $value;
+ ($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;
+ return $string;
+ }
+
+ if ($type eq 'ID') {
+ # munge to string
+ # deliberate fall through
+ }
+
+ if ($type eq 'AN') {
+ }
+
+ if ($type eq 'DT') {
+ }
+
+ if ($type eq 'TM') {
+ }
+}
+
+__PACKAGE__->meta->make_immutable;
@@ -0,0 +1,55 @@
+package X12::Schema::Segment;
+
+use Moose;
+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 elements => (isa => 'ArrayRef[X12::Schema::Element]', is => 'ro', required => 1);
+
+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 };
+
+ my %tmp = %$obj;
+ my @bits;
+
+ for my $elem (@{ $self->elements }) {
+ my $value = delete $tmp{ $elem->name };
+
+ if (defined $value) {
+ push @bits, $elem->encode($sink, $value);
+ } else {
+ if ($elem->required) {
+ die "Segment ".$self->name." element ".$elem->name." is required";
+ }
+
+ push @bits, '';
+ }
+ }
+
+ die "Excess fields for segment ".$self->name.": ".join(', ', sort keys %tmp) if %tmp;
+ pop @bits while @bits && $bits[-1] eq '';
+
+ $sink->segment( join($sink->{element_sep}, $self->tag, @bits) . $sink->{segment_sep} ) if @bits;
+}
+
+sub BUILD {
+ my ($self) = @_;
+
+ # This needs a little elaboration. Yes, we sometimes do not output a value.
+ # But this flag only controls reading, and on read, entirely empty segments
+ # should be suppressed. If a segment is required, it needs to have at least
+ # one required element.
+ $self->_can_be_empty(0);
+
+ $self->_ambiguous_end_tags({});
+ $self->_initial_tags({ $self->tag => 1 });
+}
+
+__PACKAGE__->meta->make_immutable;
@@ -0,0 +1,18 @@
+package X12::Schema::Sequencable;
+
+use Moose::Role;
+use namespace::autoclean;
+
+has name => (isa => 'Str', is => 'ro', required => 1);
+has required => (isa => 'Bool', is => 'ro');
+has max_use => (isa => 'Int', is => 'ro', default => 1);
+
+# these should be set at BUILD
+has _can_be_empty => (isa => 'Bool', is => 'rw', init_arg => undef);
+has _initial_tags => (isa => 'HashRef', is => 'rw', init_arg => undef);
+has _ambiguous_end_tags => (isa => 'HashRef', is => 'rw', init_arg => undef);
+
+
+requires qw( encode );
+
+__PACKAGE__->meta->make_imutable;
@@ -0,0 +1,104 @@
+package X12::Schema::Sequence;
+
+use Moose;
+use namespace::autoclean;
+use Carp 'croak';
+
+with 'X12::Schema::Sequencable';
+
+has children => (isa => 'ArrayRef[X12::Schema::Sequencable]', is => 'ro', required => 1);
+
+sub encode {
+ my ($self, $sink, $obj) = @_;
+
+ die "Sequence ".$self->name." can only encode a HASH" unless $obj && ref($obj) eq 'HASH' && !blessed($obj);
+
+ my %tmp = %$obj; # we will remove things as they are processed
+ my @output;
+
+ for my $elem (@{ $self->children }) {
+ my $passed = delete $tmp{ $elem->name };
+
+ if (!defined($elem->max_use) || $elem->max_use > 1) {
+ $passed ||= [];
+ die "Replicated segment or loop ".$elem->name." must encode an ARRAY" unless ref($passed) eq 'ARRAY' && !blessed($passed);
+
+ die "Segment or loop ".$elem->name." is required" if $elem->required && !@$passed;
+ die "Segment or loop ".$elem->name." is limited to ".$elem->max_use." uses" if $elem->max_use && @$passed > $elem->max_use;
+
+ $elem->encode($sink, $_) for @$passed;
+ }
+ else {
+ die "Segment or loop ".$elem->name." is required" if $elem->required && !$passed;
+ $elem->encode($sink, $passed);
+ }
+ }
+
+ die "Unused children passed to ".$self->name.": ".join(', ',sort keys %tmp) if %tmp;
+}
+
+sub BUILD {
+ my ($self) = @_;
+
+ my $elems = $self->children;
+ my (@begin, @nofollow, @empty);
+
+ # Correct the values for min/max
+ for my $child (@$elems) {
+ push @begin, $child->_initial_tags;
+ push @nofollow, $child->_ambiguous_end_tags;
+ push @empty, $child->_can_be_empty;
+
+ my $desc = "Child " . $child->name . " of " . $self->name;
+
+ if (!defined($child->max_use) || $child->max_use > 1) {
+ croak "$desc can be empty, so it may not be repeated unambiguously"
+ if $empty[-1];
+ croak "$desc is ambiguous when followed by itself"
+ if grep { exists $nofollow[-1]{$_} }, keys %{ $begin[-1] };
+
+ $nofollow[-1] = { %{ $nofollow[-1] }, %{ $begin[-1] } };
+ }
+
+ if (!$child->required) {
+ croak "$desc can already be empty, so it may not be optional" if $empty[-1];
+
+ $nofollow[-1] = { %{ $nofollow[-1] }, %{ $begin[-1] } };
+ $empty[-1] = 1;
+ }
+ }
+
+ # get initial
+ my %initial;
+ my $can_be_empty = 1;
+ for my $childix ( 0 .. $#elems ) {
+ %initial = (%initial, %{ $begin[$childix] });
+ unless ($empty[$childix]) {
+ $can_be_empty = 0;
+ last;
+ }
+ }
+
+ # check for composition errors
+ my %excluded_from_continuation;
+
+ for my $ix ( 0 .. $#elems ) {
+ my $herename = $elems->[$ix]->name;
+ my ($conflict) = grep { exists $excluded_from_continuation{$_} } keys %{ $begin[$ix] };
+ if ($conflict) {
+ croak sprintf "In %s, %s can start with tag %s which makes the end of %s ambiguous",
+ $self->name, $herename, $conflict, $excluded_from_continuation{$conflict};
+ }
+
+ %excluded_from_continuation = () unless $empty[$ix];
+ for my $exclude (keys %{ $nofollow[$ix] }) {
+ $excluded_from_continuation{$exclude} = $herename;
+ }
+ }
+
+ $self->_can_be_empty($can_be_empty);
+ $self->_ambiguous_end_tags(\%excluded_from_continuation);
+ $self->_initial_tags(\%initial);
+}
+
+__PACKAGE__->meta->make_immutable;
@@ -0,0 +1,52 @@
+package X12::Schema::SyntaxNote;
+
+use Moose;
+use namespace::autoclean;
+
+has if_present => (is => 'ro', isa => 'Str');
+has then_require => (is => 'ro', isa => 'Str');
+
+has all_or_none => (is => 'ro', isa => 'ArrayRef[Str]');
+has at_least_one => (is => 'ro', isa => 'ArrayRef[Str]');
+
+has perl => (is => 'ro', isa => 'CodeRef');
+
+sub check {
+ my ($self, $values) = @_;
+ my $key;
+
+ if ($key = $self->{if_present}) {
+ if (defined($values->{$key}) && !defined($values->{$self->{then_require}})) {
+ die "If $key is present, then so must be $self->{then_require}\n";
+ }
+ }
+ elsif ($key = $self->{all_or_none}) {
+ my $count = grep (defined $values->{$_}), @$key;
+ if ($count && $count < @$key) {
+ die "All or none of @$key must be present\n";
+ }
+ }
+ elsif ($key = $self->{at_least_one}) {
+ my $count = grep (defined $values->{$_}), @$key;
+ if (!$count) {
+ die "At least one of @$key must be present\n";
+ }
+ }
+ elsif ($key = $self->{perl}) {
+ $key->($values);
+ }
+}
+
+sub BUILD {
+ my ($self) = @_;
+
+ if (1 != grep (defined $self->{$_}), qw( if_present all_or_none at_least_one perl )) {
+ confess "syntax note must have exactly one type";
+ }
+
+ if ($self->{if_present} && !$self->{then_require}) {
+ confess "if if_present is present, then then_require is required";
+ }
+}
+
+__PACKAGE__->meta->make_immutable;

0 comments on commit eac2469

Please sign in to comment.