Open-ILS/src/perlmods/lib/OpenILS/Utils/LooseEDI.pm

   1 # The OpenILS::Utils::LooseEDI classes are an intentiaonally simplistic way to
   2 # represent EDI interchanges and the messages contained therein (which are in
   3 # turn made up of segment groups, segments, and smaller data structures).
   4 #
   5 # There is virtually no validation against EDIFACT or Editeur rules.  All we're
   6 # doing here is the minimum data munging against incoming JEDI that will let us
   7 # access segments by name without looping and searching for them (much), when
   8 # they're where they should be.
   9 #
  10 # Segment groups are hereinafter just "groups."  Groups can belong to other
  11 # groups, and segments can belong to groups, but groups cannot belong to
  12 # segments.
  13 #
  14 # Groups and segments at a given level always appear in
  15 # arrays in case there are any repeats of the the same thing at the same level.
  16 # Anything "less" than a segment is just copied as-is from the JEDI.
  17 #
  18 # The class you want to instantiate is OpenILS::Utils::LooseEDI::Interchange.
  19 # The only argument you need to give new() is the JEDI data (in string form
  20 # will do nicely).
  21
  22 package OpenILS::Utils::LooseEDI::Segment; # so simple it does nothing.
  23
  24 use strict;
  25 use warnings;
  26
  27 sub new {
  28     my ($class, $data) = @_;
  29
  30     my $self = bless $data, $class; # data is already hashref
  31
  32     return $self;
  33 }
  34
  35 1;
  36
  37 package OpenILS::Utils::LooseEDI::Group;
  38
  39 use strict;
  40 use warnings;
  41
  42 use OpenSRF::Utils::Logger qw/:logger/;
  43
  44 sub new {
  45     my ($class, $data) = @_;
  46
  47     my $self = bless {
  48         data => $data
  49     }, $class;
  50
  51     $self->load;
  52
  53     return $self;
  54 }
  55
  56 sub load {
  57     my $self = shift;
  58
  59     foreach (@{$self->{data}}) {
  60         $logger->warn("bad element in data for " . __PACKAGE__) unless
  61             @$_ == 2;
  62
  63         my ($left, $right) = @$_;
  64         $self->{$left} ||= [];
  65         push @{$self->{$left}}, $self->load_children($right);
  66     }
  67
  68     delete $self->{data};
  69 }
  70
  71 sub load_children {
  72     my ($self, $thing) = @_;
  73
  74     if (ref $thing eq 'ARRAY') {
  75         return new OpenILS::Utils::LooseEDI::Group($thing);
  76     } elsif (ref $thing eq 'HASH') {
  77         return new OpenILS::Utils::LooseEDI::Segment($thing);
  78     } else {
  79         $logger->warn("unexpected data, neither array nor hashref");
  80     }
  81 }
  82
  83 1;
  84
  85 package OpenILS::Utils::LooseEDI::Message;
  86
  87 use strict;
  88 use warnings;
  89
  90 # In our unsophisticated implementation, a message is just like a segment group.
  91 use base 'OpenILS::Utils::LooseEDI::Group';
  92
  93 sub message_name {
  94     my ($self) = @_;
  95
  96     return $self->{UNH}[0]{S009}{'0065'};
  97 }
  98
  99 1;
 100
 101 package OpenILS::Utils::LooseEDI::Interchange;
 102
 103 use strict;
 104 use warnings;
 105
 106 use OpenSRF::EX qw/:try/;
 107 use OpenSRF::Utils::JSON;
 108 use OpenSRF::Utils::Logger qw/:logger/;
 109
 110 sub new {
 111     my ($class, $data) = @_;
 112
 113     $data = OpenSRF::Utils::JSON->JSON2perl($data) unless ref $data;
 114
 115     if (ref $data eq 'HASH') {
 116         # Like a bad wine...
 117         throw new OpenSRF::EX::Error("Interchange lacks body") unless
 118             $data->{body};
 119         throw new OpenSRF::EX::Error("Interchange has empty body") unless
 120             ref $data->{body} eq 'ARRAY' and @{ $data->{body} };
 121
 122         my $self = bless {}, $class;
 123
 124         foreach my $part (@{ $data->{body} }) {
 125             foreach my $msgname (grep /^[A-Z]/, keys %$part) {
 126                 $self->{$msgname} ||= [];
 127                 my $message =
 128                     new OpenILS::Utils::LooseEDI::Message($part->{$msgname});
 129                 if ($msgname ne $message->message_name) {
 130                     $logger->warn(
 131                         "Found message thought to be named $msgname, " .
 132                         "but it says " . $message->message_name
 133                     );
 134                 }
 135                 push @{$self->{$msgname}}, $message;
 136             }
 137         }
 138         return $self;
 139     } else {
 140         $logger->error(__PACKAGE__ . " given bad data");
 141     }
 142 }
 143
 144 1;