Add OpenILS::Utils::LooseEDI module.

This doesn't try to do the validation and other helpful things that
Business::EDI aims to do, but it does let us get at data in EDI
invoices if we know what we're looking for.

Signed-off-by: Lebbeous Fogle-Weekley <lebbeous@esilibrary.com>

diff --git a/Open-ILS/src/perlmods/lib/OpenILS/Utils/LooseEDI.pm b/Open-ILS/src/perlmods/lib/OpenILS/Utils/LooseEDI.pm
new file mode 100644 (file)
index 0000000..3ff5fa7
--- /dev/null
+++ b/Open-ILS/src/perlmods/lib/OpenILS/Utils/LooseEDI.pm
@@ -0,0 +1,245 @@
+# The OpenILS::Utils::LooseEDI classes are an intentiaonally simplistic way to
+# represent EDI interchanges and the messages contained therein (which are in
+# turn made up of segment groups, segments, and smaller data structures).
+#
+# There is virtually no validation against EDIFACT or Editeur rules.  All we're
+# doing here is the minimum data munging against incoming JEDI that will let us
+# access segments by name without looping and searching for them, when they're
+# where they should be.
+#
+# Segment groups are hereinafter just "groups."  Groups can belong to other
+# groups, and segments can belong to groups, but groups cannot belong to
+# segments.
+#
+# Groups and segments at a given level always appear in
+# arrays in case there are any repeats of the the same thing at the same level.
+# Anything "less" than a segment is just copied as-is from the JEDI.
+#
+# The class you want to instantiate is OpenILS::Utils::LooseEDI::Interchange.
+# The only argument you need to give new() is the JEDI data (in string form
+# will do nicely).
+
+package OpenILS::Utils::LooseEDI::Segment; # so simple it does nothing.
+
+use strict;
+use warnings;
+
+sub new {
+    my ($class, $data) = @_;
+
+    my $self = bless $data, $class; # data is already hashref
+
+    return $self;
+}
+
+1;
+
+package OpenILS::Utils::LooseEDI::Group;
+
+use strict;
+use warnings;
+
+use OpenSRF::Utils::Logger qw/:logger/;
+
+sub new {
+    my ($class, $data) = @_;
+
+    my $self = bless {
+        data => $data
+    }, $class;
+
+    $self->load;
+
+    return $self;
+}
+
+sub load {
+    my $self = shift;
+
+    foreach (@{$self->{data}}) {
+        $logger->warn("bad element in data for " . __PACKAGE__) unless
+            @$_ == 2;
+
+        my ($left, $right) = @$_;
+        $self->{$left} ||= [];
+        push @{$self->{$left}}, $self->load_children($right);
+    }
+
+    delete $self->{data};
+}
+
+sub load_children {
+    my ($self, $thing) = @_;
+
+    if (ref $thing eq 'ARRAY') {
+        return new OpenILS::Utils::LooseEDI::Group($thing);
+    } elsif (ref $thing eq 'HASH') {
+        return new OpenILS::Utils::LooseEDI::Segment($thing);
+    } else {
+        $logger->warn("unexpected data, neither array nor hashref");
+    }
+}
+
+1;
+
+package OpenILS::Utils::LooseEDI::Message;
+
+use strict;
+use warnings;
+
+# In our unsophisticated implementation, a message is just like a segment group.
+use base 'OpenILS::Utils::LooseEDI::Group';
+
+sub message_name {
+    my ($self) = @_;
+
+    return $self->{UNH}[0]{S009}{'0065'};
+}
+
+1;
+
+package OpenILS::Utils::LooseEDI::Interchange;
+
+use strict;
+use warnings;
+
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw/:logger/;
+
+sub new {
+    my ($class, $data) = @_;
+
+    $data = OpenSRF::Utils::JSON->JSON2perl($data) unless ref $data;
+
+    if (ref $data eq 'HASH') {
+        # Like a bad wine...
+        throw new OpenSRF::EX::Error("Interchange lacks body") unless
+            $data->{body};
+        throw new OpenSRF::EX::Error("Interchange has empty body") unless
+            ref $data->{body} eq 'ARRAY' and @{ $data->{body} };
+
+        my $self = bless {}, $class;
+
+        foreach my $part (@{ $data->{body} }) {
+            foreach my $msgname (grep /^[A-Z]/, keys %$part) {
+                $self->{$msgname} ||= [];
+                my $message =
+                    new OpenILS::Utils::LooseEDI::Message($part->{$msgname});
+                if ($msgname ne $message->message_name) {
+                    $logger->warn(
+                        "Found message thought to be named $msgname, " .
+                        "but it says " . $message->message_name
+                    );
+                }
+                push @{$self->{$msgname}}, $message;
+            }
+        }
+        return $self;
+    } else {
+        $logger->error(__PACKAGE__ . " given bad data");
+    }
+}
+
+1;
+
+=pod
+sub process_invoice {
+    my ($invoice) = @_;
+
+    # The invoice message will have once instance of segment group 25
+    # per lineitem.
+    foreach my $sg25 (@{ $invoice->{SG25} }) {
+        print "found a sg25 (for a lineitem)\n";
+
+        # quantity
+        my $c186 = $sg25->{QTY}[0]->{C186};
+        printf("\tquantity: %d %s\n", $c186->{6060}, $c186->{6411} || "");
+
+        # identifiers (typically ISBN for us, and we may not need these)
+        my @identifiers = ();
+
+        #   from LIN...
+        try {
+            my $c212 = $sg25->{LIN}[0]{C212};
+            push @identifiers, [$c212->{7143}, $c212->{7140}];
+        } catch Error with {
+            # move on
+        };
+
+        #   from PIA...
+        try {
+            my $c212 = $sg25->{PIA}[0]{C212};
+            foreach my $h (@$c212) {
+                push @identifiers, [$h->{7143}, $h->{7140}];
+            }
+        } catch Error with {
+            # move on
+        };
+
+        printf("\tidentifier: %s %13s\n", $_->[0], $_->[1]) for @identifiers;
+
+        # Segment Group 26-47 are all descendants of SG25.
+
+        # Segment Group 26 concerns *lineitem* price
+        try {
+            printf(
+                "\tlineitem amount: %.02f\n",
+                $sg25->{SG26}[0]{MOA}[0]{C516}{5004}
+            );
+        } catch Error with {
+            # move on
+        };
+
+        # Segment Group 28 concerns *unit* (lineitem detail) price
+        foreach my $sg28 (@{$sg25->{SG28}}) {
+            my $c509 = $sg28->{PRI}[0]{C509};
+            printf("\tsg28 (price/range details): %.02f, qual/type qual are %s/%s\n", $c509->{5118}, $c509->{5125}, $c509->{5387});
+        }
+
+        # Segment Group 29 concerns LI and PO numbers
+        my $acq_identifiers = {};
+        foreach my $sg29 (@{$sg25->{SG29}}) {
+            foreach my $rff (@{$sg29->{RFF}}) {
+                my $c506 = $rff->{C506};
+                if ($c506->{1153} eq 'ON') {
+                    $acq_identifiers->{po} = $c506->{1154};
+                } elsif ($c506->{1153} eq 'LI') {
+                    my ($po, $li) = split m./., $c506->{1154};
+                    if ($po and $li) {
+                        if ($acq_identifiers->{po}) {
+                            $logger->warn(
+                                "RFFs within lineitem disagree on PO #"
+                            ) unless $acq_identifiers->{po} eq $po;
+
+                            $acq_identifiers->{li} = $li;
+                        }
+                    } else {
+                        $logger->warn(
+                            "RFF 1154 doesn't match expectations where 1153 is LI"
+                        );
+                    }
+                }
+            }
+        }
+
+        printf(
+            "\treferences PO# %d and LI #%d\n",
+            $acq_identifiers->{po},
+            $acq_identifiers->{li}
+        );
+    }
+}
+
+################ main ##################
+local $/;
+undef $/;
+
+my $interchange = new OpenILS::Utils::LooseEDI::Interchange(<STDIN>);
+
+foreach (@{ $interchange->{INVOIC} }) {
+    process_invoice($_);
+}
+
+0;
+=cut