Permalink
Browse files

Refactor Element::encode into a bunch of methods

  • Loading branch information...
1 parent c98cf93 commit b486a99707497ca44b4c63388859af8dfd7fd4b5 @sorear committed Mar 18, 2013
Showing with 96 additions and 88 deletions.
  1. +94 −86 lib/X12/Schema/Element.pm
  2. +2 −2 lib/X12/Schema/SegmentUse.pm
View
@@ -38,116 +38,124 @@ sub BUILD {
sub encode {
my ($self, $sink, $value) = @_;
- my $string;
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;
-
- # DIVERSITY: exponential notation
- # 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 !($prec && $string =~ /0$/) and last;
- $prec--;
- }
-
- if ($prec < 0) {
- die "Value $value cannot fit in $maxp digits for ".$self->name."\n";
- }
-
- my $wid = 0;
-
- while (1) {
- $string = sprintf "%0*.*f", $wid, $prec, $value;
- ($string =~ tr/0-9//) >= $minp and last;
- $wid++;
- }
+ my $method = "_encode_$type";
+
+ my $string = $self->$method( $self->{min_length}, $self->{max_length}, $sink, $value );
+
+ # DIVERSITY: use the release character when emitting UN/EDIFACT
+ if ($type ne 'B' && $string =~ /$sink->{delim_re}/) {
+ die "Value $string after encoding would contain a prohibited delimiter character from $sink->{delim_re} in ".$self->name."\n";
}
- if ($type eq 'N') {
- my $munge = $value * (10 ** $self->{scale});
- my $wid = 0;
+ return $string;
+}
- while (1) {
- $string = sprintf "%0*.0f", $wid, $munge;
- ($string =~ tr/0-9//) >= $minp and last;
- $wid++;
- }
+# can't just use sprintf for these two because field widths are in _digits_. sign magnitude hoy!
+sub _encode_R {
+ my ($self, $minp, $maxp, $sink, $value) = @_;
+ my $string;
+ my $prec = $maxp - 1;
- ($string =~ tr/0-9//) > $maxp and die "Value $value cannot fit in $maxp digits for ".$self->name."\n";
+ # DIVERSITY: exponential notation
+ # 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 !($prec && $string =~ /0$/) and last;
+ $prec--;
}
- if ($type eq 'ID') {
- if ($self->contract) {
- $value = ($self->contract->{$value} || die "Value $value not contained in ".join(', ',sort keys %{$self->contract})." for ".$self->name."\n");
- }
- $type = "AN";
+ if ($prec < 0) {
+ die "Value $value cannot fit in $maxp digits for ".$self->name."\n";
+ }
- # deliberate fall through
+ my $wid = 0;
+
+ while (1) {
+ $string = sprintf "%0*.*f", $wid, $prec, $value;
+ ($string =~ tr/0-9//) >= $minp and return $string;
+ $wid++;
}
+}
- if ($type eq 'AN') {
- $string = "".$value;
- $string =~ s/ *$//;
+sub _encode_N {
+ my ($self, $minp, $maxp, $sink, $value) = @_;
+ my $string;
- 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";
+ my $munge = sprintf "%.0f", $value * (10 ** $self->{scale});
- 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)));
+ length(abs($munge)) > $maxp and die "Value $value cannot fit in $maxp digits for ".$self->name."\n";
+
+ return sprintf "%0*d", ($munge < 0 ? $minp + 1 : $minp), $munge;
+}
+
+sub _encode_ID {
+ my ($self, $minp, $maxp, $sink, $value) = @_;
+ my $string;
+
+ if ($self->contract) {
+ $value = ($self->contract->{$value} || die "Value $value not contained in ".join(', ',sort keys %{$self->contract})." for ".$self->name."\n");
}
+ return $self->_encode_AN( $minp, $maxp, $sink, $value );
+}
+
+sub _encode_AN {
+ my ($self, $minp, $maxp, $sink, $value) = @_;
+ my $string;
+
+ $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)));
+ return $string;
+}
# on input, dates and times are not meaningfully associated (with each other, or with a time zone) so we have to generate isolated dates
# (floating, 00:00 time) and isolated times (floating DateTime for 2000-01-01 - gross)
- if ($type eq 'DT') {
- # send century if the field widths permit
- blessed($value) && $value->can('format_cldr') or die "Value $value is insufficiently date-like for ".$self->name."\n";
- $value->year > 0 && $value->year < 1e4 or die "Value $value is out of range for ".$self->name."\n";
-
- if (8 >= $minp && 8 <= $maxp) {
- $string = $value->format_cldr('yyyyMMdd');
- }
- elsif (6 >= $minp && 6 <= $maxp) {
- $string = $value->format_cldr('yyMMdd');
- }
- else {
- die "Field size does not permit any date format ".$self->name."\n";
- }
- }
+sub _encode_DT {
+ my ($self, $minp, $maxp, $sink, $value) = @_;
- if ($type eq 'TM') {
- blessed($value) && $value->can('format_cldr') or die "Value $value is insufficiently date-like for ".$self->name."\n";
+ # send century if the field widths permit
+ blessed($value) && $value->can('format_cldr') or die "Value $value is insufficiently date-like for ".$self->name."\n";
+ $value->year > 0 && $value->year < 1e4 or die "Value $value is out of range for ".$self->name."\n";
- if ($value->second >= 60) {
- # No leap seconds in X.12. Round it
- $value = $value->clone->set_second(59);
- }
+ if (8 >= $minp && 8 <= $maxp) {
+ return $value->format_cldr('yyyyMMdd');
+ }
+ elsif (6 >= $minp && 6 <= $maxp) {
+ return $value->format_cldr('yyMMdd');
+ }
+ else {
+ die "Field size does not permit any date format ".$self->name."\n";
+ }
+}
- # as much precision as permitted by the field. TODO: maybe use a different input type that admits precision specs
- my $fmt = $maxp >= 6 ? 'HHmmss' . ('S' x ($maxp - 6)) : 'HHmm';
- length($fmt) >= $minp && length($fmt) <= $maxp or die "Field size does not permit any date format ".$self->name."\n";
+sub _encode_TM {
+ my ($self, $minp, $maxp, $sink, $value) = @_;
- $string = $value->format_cldr($fmt);
- }
+ blessed($value) && $value->can('format_cldr') or die "Value $value is insufficiently date-like for ".$self->name."\n";
- if ($type eq 'B') {
- # bail out, we don't check for delimiters...
- return $value;
+ if ($value->second >= 60) {
+ # No leap seconds in X.12. Round it
+ $value = $value->clone->set_second(59);
}
- # DIVERSITY: use the release character when emitting UN/EDIFACT
- if ($string =~ /$sink->{delim_re}/) {
- die "Value $string after encoding would contain a prohibited delimiter character from $sink->{delim_re} in ".$self->name."\n";
- }
+ # as much precision as permitted by the field. TODO: maybe use a different input type that admits precision specs
+ my $fmt = $maxp >= 6 ? 'HHmmss' . ('S' x ($maxp - 6)) : 'HHmm';
+ length($fmt) >= $minp && length($fmt) <= $maxp or die "Field size does not permit any date format ".$self->name."\n";
- return $string;
+ return $value->format_cldr($fmt);
+}
+
+sub _encode_B {
+ my ($self, $minp, $maxp, $sink, $value) = @_;
+ return $value;
}
__PACKAGE__->meta->make_immutable;
@@ -3,10 +3,10 @@ package X12::Schema::SegmentUse;
use Moose;
use namespace::autoclean;
-with 'X12::Schema::Sequencable';
-
has def => (is => 'ro', isa => 'X12::Schema::Segment', required => 1, handles => ['encode']);
+with 'X12::Schema::Sequencable';
+
sub BUILD {
my ($self) = @_;

0 comments on commit b486a99

Please sign in to comment.