WIP 1

Makefile.PL

@@ -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;

lib/X12/Schema/Element.pm

@@ -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;

lib/X12/Schema/Segment.pm

@@ -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;

lib/X12/Schema/Sequencable.pm

@@ -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;

lib/X12/Schema/Sequence.pm

@@ -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;

lib/X12/Schema/SyntaxNote.pm

@@ -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;