libbusiness-edi-perl 0.05-2 / usr / share / perl5 / Business / EDI.pm

package Business::EDI;

use strict;
use warnings;
use Carp;
# use Data::Dumper;

our $VERSION = 0.05;

use UNIVERSAL::require;
use Data::Dumper;
use File::Spec;
use CGI qw//;
use Business::EDI::CodeList;
use Business::EDI::Composite;
use Business::EDI::DataElement;
use Business::EDI::Segment;
use Business::EDI::Spec;

our $debug = 0;
our %debug = ();
our $error;          # for the whole class
my %fields = ();

our $AUTOLOAD;
sub DESTROY {}  #
sub AUTOLOAD {
    my $self  = shift;
    my $class = ref($self) or croak "AUTOLOAD error: $self is not an object, looking for $AUTOLOAD";
    my $name  = $AUTOLOAD;

    $name =~ s/.*://;                # strip leading package stuff
    $name =~  /^syntax/          or  # leave syntax, 
    $name =~  /^SG\d+$/          or  # leave SGxx alone (for segment groups)
    $name =~ s/^s(eg(ment)?)?//i or  # strip segment (a prefix to avoid numerical method names)
    $name =~ s/^p(art)?//i;          # strip part -- autoload's parallel accessor, e.g. ->part4343 to ->part(4343)

    $debug and warn "AUTOLOADING '$name' for " . $class;

    if (exists $self->{_permitted}->{$name}) {  # explicitly named accessible fields
        if (@_) {
            return $self->{$name} = shift;
        } else {
            return $self->{$name};
        }
    }
    
    if (ref $self->{def} eq 'ARRAY') {          # spec defined subelements
        if ($name =~ s/^all_(.+)$/$1/i) {
            @_ and croak "AUTOLOAD error: all_$name is read_only, rec'd argument(s): " .  join(', ', @_);
            if ($debug) {
                warn "AUTOLOADing " . $self->{code} . "/all_$name (from " . scalar(@{$self->{array}}) . " arrayed elements): "
                        . join(' ', map {$_->{code}} @{$self->{array}});
                $debug > 1 and print STDERR Dumper($self), "\n";
            }
            my $target = $name =~ /^SG\d+$/ ? ($self->{code} . "/$name") : $name;
            return grep {$_->{code} and $_->{code} eq $target} @{$self->{array}};    # return array 
        }
        return __PACKAGE__->_deepload_array($self, $name, @_); # not $self->_deepload - avoid recursion
    }
    # lastly, try to reach through any Cxxx Composites, if the target is unique
    return __PACKAGE__->_deepload($self, $name, @_);           # not $self->_deepload - avoid recursion
}

sub _deepload_array {
    my $pkg  = shift; # does nothing
    my $self = shift or return;
    my $name = shift or return;
    unless ($self->{def}) {
        die "_deepload_array of '$name' attempted on an object that does not have a spec definition";
        return;
    }

    my @hits     = grep {$_->{code} eq $name} @{$self->{def}};
    my $defcount = scalar @{$self->{def}};
    my $hitcount = scalar @hits;
    my $total_possible = 0;
    foreach (@hits) {
        $total_possible += ($_->{repeats} || 1);
    }
    $name =~ /^SG\d+$/ and $name = $self->{message_code} . "/$name";    # adjust key for SGs
    $debug and warn "Looking for '$name' matches $hitcount of $defcount subelements, w/ $total_possible instances: " . join(' ', map {$_->{code}} @hits);
    $debug and warn ref($self) . " self->{array} has " . scalar(@{$self->{array}}) . " elements of data";
    
    # Logic: 
    # If there is only one possible element to match, then we can read/write to it.
    # But if there are multiple repetitions possible, then we cannot tell which one to target,
    # UNLESS it is a read operation and there is only one such element populated.  
    # Write operation still would be indifferentiable between new element constructor and existing elememt overwrite.
    if ($total_possible == 1 or ($hitcount == 1 and not @_)) {
        foreach (@{$self->{array}}) {
            $_->code eq $name or next;
            if (@_) {
                return $_ = shift;
            } else {
                return $_;
            }
        }
        # if we got here, it's a valid target w/ no populated value (no code match)
        return;
        # @_ or return $self->_subelement_helper($name, {}, $self->{message_code});   # so you get an empty object of the correct type on read
        # TODO: for 1-hit write, splice in at the correct position.  Tricky.
    } elsif ($total_possible == 0) {
        $debug and $debug > 1 and print STDERR "FAILED _deepload_array of '$name' in object: ", Dumper($self);
    }
    croak "AUTOLOAD error: Cannot " . (@_ ? 'write' : 'read') . " '$name' field of class '" . ref($self)
          . "', $hitcount matches ($total_possible repetitions) in subelements";
}

sub _deepload {
    my $pkg  = shift; # does nothing
    my $self = shift    or return;
    my $name = shift    or return;
    $self->{_permitted} or return;

    my @partkeys = $self->part_keys;
    my @keys     = grep {/^C\d{3}$/} @partkeys;
    my $allcount = scalar(@partkeys);
    my $ccount   = scalar(@keys);
    $debug and warn "Looking for $name under $allcount subelements, $ccount Composites: " . join(' ', @keys);

    my @hits = grep {$name eq $_} @partkeys;
    if (scalar @hits) {
        
    } elsif ($ccount) {
        my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can autoload objects";
        my $part = $spec->get_spec('composite');
        foreach my $code (@keys) {
            $part->{$code} or croak(ref($self) . " Object _permitted composite code '$code' not found in spec version " . $spec->version);
            my @subparts = grep {$_->{code} eq $name} @{$part->{$code}->{parts}};
            @subparts and push(@hits, map {$code} @subparts);   
            # important here, we add the Cxxx code once per hit in its subparts.  Multiple hits means we cannot target cleanly.
        }
    }
    my $hitcount = scalar(@hits);
    $debug and warn "Found $name has $hitcount possible match(es) in $ccount Composites: " . join(' ', @hits);
    if ($hitcount == 1) {
        if (@_) {
            return $self->{$hits[0]}->{$name} = shift;
        } else {
            return $self->{$hits[0]}->{$name};
        }
    } elsif ($hitcount > 1) {
        croak "AUTOLOAD error: Cannot access '$name' field of class '" . ref($self) . "', "
            . " $hitcount indeterminate matches in collapsable subelements";
    }
    # else hitcount == 0
    $debug and $debug > 1 and print STDERR "FAILED _deepload of '$name' in object: ", Dumper($self);
    croak "AUTOLOAD error: Cannot access '$name' field of class '" . ref($self)
        . "' (or $allcount collapsable subelements, $ccount Composites)";
}

# Constructors

sub new {
    my $class = shift;
    my %args;
    if (scalar @_ eq 1) {
        $args{version} = shift;
    } elsif (@_) {
        scalar(@_) % 2 and croak "Odd number of arguments to new() incorrect.  Use (name1 => value1) style.";
        %args = @_;
    }
    my $stuff = {_permitted => {(map {$_ => 1} keys %fields)}, %fields};
    foreach (keys %args) {
        $_ eq 'version' and next;  # special case
        exists ($stuff->{_permitted}->{$_}) or croak "Unrecognized argument to new: $_ => $args{$_}";
    }
    my $self = bless($stuff, $class);
    if ($args{version}) {
        $self->spec(version => $args{version}) or croak "Unrecognized spec version '$args{version}'";
    }
    $debug and $debug > 1 and print Dumper($self);
    return $self;
}

# BIG Complicated META-Constructors!!

sub _common_constructor {
    my $self = shift;
    my $type = shift or die "Internal error: _common_constructor called without required argument for object type";
    my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can create $type objects";
    my $part = $spec->get_spec($type);
    my $code = uc(shift) or croak "No $type code specified";
    my $body = shift;

    $part->{$code} or return $self->carp_error("$type code '$code' is not found amongst "
        . scalar(keys %$part) ." ". $type . "s in spec version " . $spec->version); # . ": " . Dumper([sort keys %$part]));

    unless (ref($body) eq 'HASH') {
        return $self->carp_error("body argument for $type must be HASHREF, not '" . ref($body) . "'");
    }
    my @subparts = map {$_->{code}} @{$part->{$code}->{parts}};
    my @required = map {$_->{code}} grep {$_->{mandatory}} @{$part->{$code}->{parts}};

    my ($compspec, @compcodes);
    my ( $segspec, @seggroups);
    foreach (@subparts) {
        /^SG\d+$/  and push(@seggroups, $_) and next;
        /^C\d{3}$/ and push(@compcodes, $_) and next;
    }
    $compspec = $spec->get_spec('composite') if @compcodes;
  # $segspec  = $spec->get_spec('segment')   if @seggroups;

    my $normal;
    # Now we normalize the body according to the spec (apply wrappers)
    foreach my $key (keys %$body) {
        if (grep {$key eq $_} @subparts) {
            $normal->{$key} = $body->{$key};    # simple case
            next;
        }
        elsif (@compcodes) {
            my @hits;
            foreach my $compcode (@compcodes) {
                push @hits, map {$compcode} grep {$_->{code} eq $key} @{$compspec->{$compcode}->{parts}};
            }
            if (scalar(@hits) == 1) {
                $normal->{$hits[0]}->{$key} = $body->{$key};    # only one place for it to go, so apply the wrapper
                next;
            } elsif (scalar(@hits) > 1) {
                return $self->carp_error("$type subpart '$key' has " . scalar(@hits)
                    . " indeterminate matches under composites: " . join(', ', @hits)
                );
            }
            return $self->carp_error("$type subpart '$key' not found in spec " . $spec->version);
        }
    }

    $debug and printf STDERR "creating $type/$code with %d spec subpart(s): %s\n", scalar(@subparts), join(' ', @subparts);
    # push @subparts,  'debug';
    my $unblessed = $self->unblessed($normal, \@subparts);
    $unblessed or return;
    my $new = bless($unblessed, __PACKAGE__ . '::' . ucfirst($type));
    $new->spec($spec);
    $new->{_permitted}->{code}  = 1;
    $new->{_permitted}->{label} = 1;
    $new->{code}  = $code;
    $new->{label} = $part->{$code}->{label};
    # $new->debug($debug{$type}) if $debug{$type};
    foreach (@required) {
        unless (defined $new->part($_)) {
            return $self->carp_error("Required field $type/$code/$_ not populated");
        }
    }
    return $new;
}

sub _def_based_constructor {
    my $self = shift;
    my $type = shift or die "Internal error: _def_based_constructor called without required argument for object type";
    my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can create $type objects";
    my $page = $self->spec_page($type);  # page of the spec
    my $code = uc(shift) or croak "No $type code specified";
    my $body = shift;
    my $message_code = (@_ and $_[0]) ? shift : '';
    my $page_code;

    if ($type eq 'message') {
        $message_code = $code;
        $page_code    = $code;
    } elsif ($type eq 'segment_group') {
        $code =~ /^SG\d+$/ and $message_code and $code = "$message_code/$code";
        $code =~ /^(\S+)\/(SG\d+)$/ or return $self->carp_error("Cannot spec $type '$code' without message.  Use xpath style, like 'ORDERS/SG27'");
        $page = $page->{$1} or return $self->carp_error("Message $1 does not have any " . $type . "s in spec version " . $spec->version);
        $message_code = $1;
        $page_code    = $2;
        # tighen spec down past message level based on first part of key
    }

    unless (ref($body) eq 'ARRAY') {
        return $self->carp_error("body argument to $type() must be ARRAYREF, not '" . ref($body) . "'");
    }

    my @subparts = @{$page->{$page_code}->{parts}};
    $debug and printf STDERR "creating $type/$code with %d spec subpart(s): %s\n", scalar(@subparts), join(' ', map {$_->{code}} @subparts);
    $debug and print STDERR "calling \$self->unblessed_array(\$body, \$page->{$page_code}->{parts}, '$message_code')\n";
    my $unblessed = $self->unblessed_array($body, \@subparts, $message_code);     # doesn't yet support arrayref(?)
    $unblessed or return;
    my $new = bless($unblessed, __PACKAGE__ . '::' . ucfirst($type));
    $new->spec($spec);
    $new->{_permitted}->{code}         = 1;
    $new->{_permitted}->{message_code} = 1;
    $new->{_permitted}->{label}        = 1;
    $new->{code} = $code;
    $new->{message_code} = $message_code;   # same as code for messages, different for SGs
    $new->{label} = $page->{$page_code}->{label};
    if ($type eq 'segment_group') {
        $new->{sg_code}  = $page_code;   
    }
    return $new;
}

# Fundamental constructor calls for different object types
# These are here so you can just "use Business::EDI;" and not have to worry about using different 
# modules for different data objects.  

sub segment {
    my $self = shift;
    return $self->_common_constructor('segment', @_);
}

sub segment_group {
    my $self = shift;
    return $self->_def_based_constructor('segment_group', @_);
# The difference is that segment_group must deal with repeatable segments, other segment groups, etc.
}

# TODO: rename detect_version one something more clueful
# The difference is that message() expects you to have declared an EDI spec version already, whereas detect_version
# just looks at the contents of the passed data, attempting to extract the encoded version there.

sub detect_version {
    my $self = shift;
    return Business::EDI::Message->new(@_);
}

sub message {
    my $self = shift;
   # my $msg_code = shift;
    #print Dumper ($body);
    return $self->_def_based_constructor('message', @_);
}

sub dataelement {
    my $self = shift;
    # Business::EDI::DataElement->require;
    Business::EDI::DataElement->new(@_);
}

sub composite {
    my $self = shift;
    # Business::EDI::DataElement->require;
    Business::EDI::Composite->new(@_);
}

sub codelist {
    my $self = shift;
    # my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can create objects";
    # my $part = $spec->get_spec('message');
    Business::EDI::CodeList->new_codelist(@_);
}

sub spec_page {
    my $self = shift;
    my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can retrieve part of it";
    @_ or return carp_error("Missing argument to spec_page()");
    return $spec->get_spec(@_); # not $self->get_spec .... sorry
}

sub get_spec {
    my $self = shift;
    @_ or return carp_error("Missing argument to get_spec()");
    return Business::EDI::Spec->new(@_);
}

# Accessor get/set methods

sub code {
    my $self = shift;
    @_ and $self->{code} = shift;
    return $self->{code};
}

sub spec {        # spec(code)
    my $self = shift;
    if (@_) {                                        #  Arg(s) mean we are constructing
        ref($self) or return $self->get_spec(@_);    #  Business::EDI->spec(...) style, class method: simple constructor
        if (ref($_[0]) eq 'Business::EDI::Spec') {   # TODO: use isa or whatever the hip OO style of role-checking is
            $self->{spec} = shift;                   #  We got passed a full spec object, just set
        } else {
            $self->{spec} = $self->get_spec(@_);     #  otherwise construct and retain
        }
    }
    ref($self) or croak "Cannot use class method Business::EDI->spec as an accessor (spec is uninstantiated).  " .
        "Get a spec'd object first like: Business::EDI->new('d87a')->spec, " .
        "or specify the version you want: Business::EDI->spec('default') or Business::EDI->get_spec('default')";
    return $self->{spec};
}

sub error {
    my ($self, $msg, $quiet) = @_;
    $msg or return $self->{error} || $error;  # just an accessor
    ($debug or ! $quiet) and carp $msg;
    return $self->{error} = $msg;
}

sub carp_error {
    my $obj_or_message = shift;
    my $msg;
    if (@_) {
        $msg = (ref($obj_or_message) || $obj_or_message) . ' - ' . shift;
    } else {
        $msg = $obj_or_message;
    }
    if (ref $obj_or_message) {
        # do something?
    }
    carp $msg;
    return;     # undef: important!
}

# ->unblessed($body, \@codes)

sub unblessed {     # call like Business::EDI->unblessed(\%hash, \@codes);
    my $class    = shift;
    my $body     = shift;
    my $codesref = shift;
    $body     or return carp_error "1st required argument to unblessed() is EMPTY";
    $codesref or return carp_error "2nd required argument to unblessed() is EMPTY";
    unless (ref($body)     eq 'HASH') {
        return carp_error "1st argument to unblessed() must be HASHREF, not '" . ref($body) . "'";
    }
    unless (ref($codesref) eq 'ARRAY') {
        return carp_error "2nd argument to unblessed() must be ARRAYREF, not '" . ref($codesref) . "'";
    }
    $debug and printf STDERR "good: unblessed() got body and definition: %s/%s topnodes/defs\n", scalar(keys %$body), scalar(@$codesref); #, Dumper($body), "\n";
    my $self = {};
    foreach (@$codesref) {
        $self->{_permitted}->{$_} = 1;
        $body->{$_} or next;
        $self->{$_} = Business::EDI->subelement({$_ => $body->{$_}}) || $body->{$_};
    }
    return $self;
}

# array based object creation (segment groups)
# allows repeatable subobjects
# enforces mandatory subobjects
sub unblessed_array {     # call like Business::EDI->unblessed_array(\@pseudo_hashes, \@code_objects);
    my $class    = shift;
    my $body     = shift;
    my $codesref = shift;
    my $msg = (@_ and $_[0]) ? shift : '';
 #   my $msg = 'ORDRSP';
    my $strict   = 0;
    $body     or return carp_error "1st required argument 'x' to unblessed_array(x,y,'$msg') is EMPTY";
    $codesref or return carp_error "2nd required argument 'y' to unblessed_array(x,y,'$msg') is EMPTY";
    unless (ref($body)     eq 'ARRAY') {
        return carp_error "1st argument to unblessed_array() must be ARRAYREF, not '" . ref($body) . "'";
    }
    unless (ref($codesref) eq 'ARRAY') {
        return carp_error "2nd argument to unblessed_array() must be ARRAYREF, not '" . ref($codesref) . "'";
    }
    $debug and printf STDERR "good: unblessed_array() got body and definition: %s/%s topnodes/defs\n", scalar(@$body), scalar(@$codesref); #, Dumper($body), "\n";
    my $self = {
        array => [],    # subelements get pushed in here
        def => $codesref,
        _permitted => {array => 1, def => 1},
    };

    my     $sg_specs = $class->spec_page('segment_group') or croak "Cannot get Segment Group definitions";
    my $msg_sg_specs = $sg_specs->{$msg} or croak "ERROR: $msg Segment Groups not defined in spec";
    my $codecount = scalar @$codesref;
    my $j = 0;  # index for @$codesref
    my $repeats = 0;
    my $last_matched = '';
    my $i;
    if (@$body == 2 and ref($body->[0]) eq '') {
        # push @{$self->{array}}, $class->_subelement_helper($body->[0], $body->[1], $msg);
        # return $self;
        $body = [ [$body->[0], $body->[1]] ];
    }

    BODYPART: for ($i=0; $i < @$body; $i++) {
        my $bodypart = $body->[$i];
        # next if ref($bodypart) =~ /)^Business::EDI::/;
        unless (ref($bodypart) eq 'ARRAY') {
            warn "Malformed data.  Bodypart $i is expected to be pseudohash ARRAYREF, not "
                . (ref($bodypart) || "a scalar='$bodypart'") . ".  Skipping it...";
            next;
        }
        my $key = $bodypart->[0];
        $debug and print "BODYPART $i: $key\n";
        while ($j < $codecount) {
            my $def = $codesref->[$j];
            $debug and printf STDERR "BODYPART $i: $key comparing to def $j: %5s  %s\n", $def->{code}, ($key eq $def->{code} ? 'MATCH!' : '');
            if ($key eq $def->{code}) {
                $last_matched = $key;
                my $limit = $def->{repeats};     # checking the PREVIOUS def to see if it allows repetition
                if (++$repeats <= $limit) {
                    push @{$self->{array}}, $class->_subelement_helper($key, $bodypart->[1], $msg);
                } else {
                    $strict and die "Code '$key' is limited to $limit occurrences.  Dropping data!!";
                    warn "Code '$key' is limited to $limit occurrences.  Dropping data!!";
                }
                next BODYPART;
            }
            # check if this def was mandatory (satisfied if we already added it)
            if ($def->{mandatory} and $def->{code} !~ /^UN.$/ and not $repeats) {
                my $msg = "Mandatory code '" . $def->{code} . "' from definition $j missing or out of position (last found '$key' at position $i)";
                $strict and return carp_error $msg;
                $debug and warn $msg;
            }
            $repeats = 0;
            $j++;   # move the index to the next rule
        }
        # now either we matched, or we ran out of tries
        if ($j >= $codecount) {     # if we ran out of tries, error
            my $msg = "All $j subelements exhausted.  Code '$key' from position $i not matched";
            $strict and return carp_error $msg;
            $debug and warn $msg;   # FIXME: this happens too often
        }
    }
    return $self;
    # We're out of parts, so time to check for any outstanding mandatory defs (same kind of loop)
    # This check doesn't work because a subelement can be mandatory in a given optional element.  Context matters.
    while (++$j < $codecount) {
        $codesref->[$j]->{mandatory} and return carp_error
            "Mandatory code '" . $codesref->[$j]->{code} . "' from definition $j missing (all ". $i+1 . " data traversed)";
    }
}

sub _subelement_helper {
    my ($class, $key, $body, $msg) = @_;
    if ($key =~ /^[A-Z]{3}$/) {
        $debug and print STDERR "SEGMENT ($key) detected\n";
        return $class->segment($key => $body);
    } else {
        return $class->subelement({$key => $body}, $msg);
    }
}

# Similar to AUTOLOAD, but by an exact argument, does get and set
# This code should parallel AUTOLOAD tightly.
sub part {
    my $self  = shift;
    my $class = ref($self) or croak "part() object method error: $self is not an object";
    my $name  = shift or return;

    unless (exists $self->{_permitted}->{$name}) {
        if ($self->{def}) {
            if ($name =~ s/^all_(.+)$/$1/i) {   # strip 'all_' prefix
                @_ and croak "part() error: all_$name is read_only, rec'd argument(s): " .  join(', ', @_);
                if ($debug) {
                    warn "part() " . $self->{code} . "/all_$name (from " . scalar(@{$self->{array}}) . " arrayed elements): "
                            . join(' ', map {$_->{code}} @{$self->{array}});
                    $debug > 1 and print STDERR Dumper($self), "\n";
                }
                my $target = $name =~ /^SG\d+$/ ? ($self->{message_code} . "/$name") : $name;
                return grep {$_->{code} and $_->{code} eq $target} @{$self->{array}};    # return array 
            }
            return __PACKAGE__->_deepload_array($self, $name, @_); # not $self->_deepload_array - avoid recursion
        }
        return __PACKAGE__->_deepload($self, $name, @_); # not $self->_deepload - avoid recursion
    }

    if (@_) {
        return $self->{$name} = shift;
    } else {
        return $self->{$name};
    }
}

# part_keys gives you values that are always valid as the argument to the same object's part() method
# TODO: mix/match both _permitted and def based?  Maybe.

sub part_keys {
    my $self = shift;
    if ($self->{def}) {
        return map { my $key = $_->{code}; $_->{repeats} > 1 ? "all_$key" : $key } @{$self->{def}};
    }
    return keys %{$self->{_permitted}};
    # my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can know what parts an $self object might have";
}


# Example data:
# 'BGM', {
#     '1004' => '582822',
#     '4343' => 'AC',
#     '1225' => '29',
#     'C002' => {
#        '1001' => '231'
#     }
# }

our $codelist_map;

# Tricky recursive constructor!
sub subelement {
    my $self = shift;
    my $body = shift;
    my $message_code = (@_ and $_[0]) ? shift : '';
    if (! $body) {
        carp "required argument to subelement() empty";
        return;
    }
    unless (ref $body) {
        $debug and carp "subelement() got a regular scalar argument. Returning it ('$body') as subelement";
        return $body;
    }
    ref($body) =~ /^Business::EDI/ and return $body;    # it's already an EDI object, return it

    if (ref($body) eq 'ARRAY') {
        if (scalar(@$body) != 2) {
            carp "Array expected to be psuedohash with 2 elements, or wrapper with 1, instead got " . scalar(@$body);
            return; # [(map {ref($_) ? $self->subelement($_) : $_} @$body)];     # recursion
        } else {
            $body = {$body->[0] => $body->[1]};
        }
    }
    elsif (ref($body) ne 'HASH') {
        carp "argument to subelement() should be ARRAYref or HASHref or Business::EDI subobject, not type '" . ref($body) . "'";
        return;
    }
    $debug and print STDERR "good: we now have a body in class " . (ref($self) || $self) . " with " . scalar(keys %$body) . " key(s): ", join(', ', keys %$body), "\n";
    $codelist_map ||= Business::EDI::CodeList->codemap;
    my $new = {};
    foreach (keys %$body) {
        $debug and print STDERR "subelement building from key '$_'\n";
        my $ref = ref($body->{$_});
        if ($codelist_map->{$_}) {      # If the key is in the codelist map, it's a codelist
            $new->{$_} = $self->codelist($_, $body->{$_})
                or carp "Bad ref ($ref) in body for key $_.  Codelist subelement not created";
        } elsif (/^C\d{3}$/ or /^S\d{3}$/) {
            $new->{$_} = Business::EDI::Composite->new({$_ => $body->{$_}})     # Cxxx and Sxxx codes are for Composite data elements
                or carp "Bad ref ($ref) in body for key $_.  Composite subelement not created";
        } elsif (/^[A-Z]{3}$/) {
            $new->{$_} = $self->segment($_, $body->{$_})                        # ABC codes are for Segments
                or carp "Bad ref ($ref) in body for key $_.  Segment subelement not created";
        } elsif (/^(\S+\/)?(SG\d+)$/) {
            my $sg_spec = $_;
            my $msg     = $1;
            my $sg_tag  = $2;
            $sg_spec =~ s/\/\S+\//\//;      # delete middle tags: ORDRSP/SG25/SG26 => ORSRSP/SG26
            $new->{$sg_spec} = $self->segment_group(($msg ? $sg_spec : "$message_code/$sg_tag"), $body->{$_}, $message_code)   # SGx[x] codes are for Segment Groups
                or carp "Bad ref ($ref) in body for key $_.  Segment_group subelement not created";
        } elsif ($ref eq 'ARRAY') {
            my $count = scalar(@{$body->{$_}});
            $count == 1 or carp "Repeated section '$_' appears $count times.  Only handling first appearance";  # TODO: fix this
            $new->{repeats}->{$_} = -1;
            $new->{$_} = $self->subelement($body->{$_}->[0], $message_code)     # ELSE, break the ref down (recursively)
                or carp "Bad ref ($ref) in body for key $_.  Subelement not created";
        } elsif ($ref) {
            $new->{$_} = $self->subelement($body->{$_}, $message_code)          # ELSE, break the ref down (recursively)
                or carp "Bad ref ($ref) in body for key $_.  Subelement not created";
        } else {
            $new->{$_} = Business::EDI::DataElement->new($_, $body->{$_});      # Otherwise, a terminal (non-ref) data node means it's a DataElement
                  # like Business::EDI::DataElement->new('1225', '582830');
        }
        (scalar(keys %$body) == 1) and return $new->{$_};   # important: if that's our only key/pair, return the object itself, no wrapper.
    }
    return $new;
}


# not really xpath, but xpath-lite-like.  the idea here is to never crash on a valid path, just return undef.
sub xpath {
    my $self  = shift;
    my $path  = shift or return;
    my $class = ref($self) or croak "xpath() object method error: $self is not an object";
    $path eq '/' and return $self;
    $path =~ m#([^-A-z_0-9/\.])# and croak "xpath does not handle '$1' in the path, just decending paths like 'SG27/LIN/1229'";
    $path =~ m#(//)#             and croak "xpath does not handle '$1' in the path, just decending paths like 'SG27/LIN/1229'";
    $path =~ m#^/#               and croak "xpath does not handle leading slashes in the path, just decending relative paths like 'SG27/LIN/1229'";

    my ($front, $back) = split "/", $path, 2;
    defined $front or $front = '';
    defined $back  or $back  = '';
    $debug and print STDERR $class . "->xpath($path)  ==>  ->part($front)->xpath($back);\n";

    if ($front) {
        $back or return $self->part($front);    # no trailing part means we're done!
        my @ret;
        push @ret, $self->part($front) or return;   # front might return multiple hits ('all_SG3', for example)
        return grep {defined $_} map {$_->xpath($back)} @ret;
    }
    croak "xpath does not handle leading slashes in the path, just decending relative paths like 'SG27/LIN/1229'";
}

sub xpath_value {
    my $self = shift;
    my @hits = $self->xpath(@_);
    @hits or return;
    wantarray or return $hits[0]->value;
    return map {$_->value} @hits;
}

our $cgi;
# Write your own CSS
sub html {
    my $self    = shift;
    my $empties = @_ ? shift : 0;
    my $indent  = @_ ? shift : 0;
    my $obtype  = ref $self or return $self;
    my $x = ' ' x $indent;

    my $extra = '';
    $obtype =~ s/^Business::EDI::// or return "$x<div class='edi_error'>$obtype object</div>";
    if ($obtype =~ /::(.*)$/) {
        $extra = " edi_$1";
        $extra  =~ s/::/_/;
        $obtype =~ s/::.*$//;
    }

    my $html = "$x<div class='edi_node edi_$obtype$extra'>";
    my %tophash;
    foreach (qw/code label desc value/) { # get top values, if existing
        $tophash{$_} = $self->$_ if (eval {$self->$_});
    }
    $cgi ||= CGI->new();
    foreach (qw/code label desc value/) { # same order, w/ some fanciness for label (title attribute based on desc)
        defined $tophash{$_} or next;
        my $attrs = {class=>"edi_$_"};
        ($_ eq 'label') and $attrs->{title} = $tophash{desc};
        $html .= "\n$x    " . $cgi->span($attrs, $self->$_);
    }

    my @keys = grep {$_ ne 'label' and $_ ne 'value' and $_ ne 'code' and $_ ne 'desc'} $self->part_keys;   # disclude stuff we already got
    #my @parts = map {$self->part($_)} $self->part_keys;
    my @parts = $self->{array} ? @{$self->{array}} : map {$self->part($_)} @keys;
    $debug and print STDERR $tophash{label}, " has ", scalar(@keys),  " in part_keys: ", join(' ', @keys), "\n";
    # $_->{array} and print "$tophash{label} has ", scalar(@{$_->{array}}), " in array: " . join(' ', map {$_->{code}} @{$_->{array}}), "\n";
    $debug and print STDERR $tophash{label}, " has ", scalar(@parts), " in  'parts' : ", join(' ', map {ref($_) ? $_->{code} : $_} @parts), "\n";
    if (@parts) {
        $html .= "\n$x    <ul>";
        foreach (@parts) {
            (ref $_ and $_->{code}) or next;
            $debug and print STDERR "html(): $tophash{label} => " . $_->{code} . " subcall\n";
            $html .= "\n$x    <li>\n" . $_->html($empties, $indent + 8) . "\n$x    </li>";
        }
        $html .= "\n$x    </ul>"
    }
    return "$html\n$x</div>";
}


1;

# END of Business::EDI
# =======================================================================================

package Business::EDI::Segment_group;
use strict; use warnings;
use Carp;
use base qw/Business::EDI/;
our $VERSION = 0.02;
our $debug;

sub sg_code {
    my $self = shift or return;
    @_ and croak "sg_code is read only (no args)";
    return $self->{sg_code};
}

sub desc {  # build a description on the fly
    my $self = shift or return;
    my $sgcode = $self->sg_code;
    $sgcode =~ s/^SG//i;
    return $self->{message_code} . " Segment Group $sgcode";
}

# Business::EDI::Segment_group gets its own part method to handle meta-mapped SGs INSIDE other SGs,
# but it falls back to the main part method after that.

sub part {
    my $self  = shift;
    my $class = ref($self) or croak("part object method error: $self is not an object");
    my $name  = shift or return;
    my $code  = $self->{message_code} or return $self->carp_error("Message type (code) unset.  Cannot assess metamapping.");
    my $spec  = $self->{spec}         or return $self->carp_error("Message spec (code) unset.  Cannot assess metamapping.");
    my $sg    = $spec->metamap($code, $name);
    my $str_spec = "in spec " . $spec->version;
    if ($sg) {
        $debug and warn "SG Message/field '$code/$name' ==> '$code/all_$sg' via mapping $str_spec";
        if ($sg =~ /\//) {
            my $obj;
            my @chunks = split '/', $sg;
            my $first  = shift @chunks;   
            my $last   = pop   @chunks;   
            $first eq $self->{sg_code} or return $self->carp_error("Mapped target $sg descends from $code/$first $str_spec, not " . $self->{sg_code});
            foreach (@chunks) {
                $obj = $obj ? $obj->SUPER::part("all_$_") : $self->SUPER::part("all_$_");
                $obj or warn "Mapped SG $sg part 'all_$_' not found $str_spec";
                $obj or return;
            }
            return $obj ? $obj->SUPER::part("all_$last", @_) : $self->SUPER::part("all_$last", @_);  # only the last part gets the remaining args
        } else {
            return $self->carp_error("Mapped target $sg is not under " . $self->{code} . " $str_spec");
        }
    } else {
        $debug and warn "Message/field '$code/$name' not mapped $str_spec.  Skipping metamapping";
    }
    return $self->SUPER::part($name, @_);
}


1;

package Business::EDI::Message;
use strict; use warnings;
use Carp;
use base qw/Business::EDI/;
our $VERSION = 0.02;
our $debug;

# Business::EDI::Message gets its own part method to handle meta-mapped SGs,
# but it falls back to the main part method after that.

sub part {
    my $self  = shift;
    my $class = ref($self) or croak("part object method error: $self is not an object");
    my $name  = shift or return;
    my $code  = $self->{message_code} or return carp_error("Message type (code) unset.  Cannot assess metamapping.");
    my $spec  = $self->{spec}         or return carp_error("Message spec (code) unset.  Cannot assess metamapping.");
    my $sg    = $spec->metamap($code, $name);
    if ($sg) {
        $sg =~ s#/#/all_#;    # e.g. SG26/SG30 => SG26/all_SG30
        $debug and warn "Message/field '$code/$name' => '$code/all_$sg' via mapping";
        $name = "all_$sg";    # new target from mapping
    } else {
        $debug and warn "Message/field '$code/$name'  not mapped.  Skipping metamapping";
    }
    return $self->SUPER::part($name, @_);
}

# This is a very high level method.
# We look inside a message body BEFORE we know what it is, and what spec it was written to.
# Second argument is a flag for "string only", in which case we just return the composed version string (e.g. 'D96A')
# otherwise we return a Business::EDI::Message object, or undef on failure.
#
# my $message = Business:EDI::Message->new($body);
# my $version = Business:EDI::Message->new($body, 1);
# 
# Handles ALL valid message types

sub new {
    my $class = shift;
    my $body  = shift     or return $class->carp_error("missing required argument to detect_version()");
    ref($body) eq 'ARRAY' or return $class->carp_error("detect_version_string argument must be ARRAYref, not '" . ref($body) . "'");
    foreach my $node (@$body) {
        my ($tag, $segbody, @xtra) = @$node;
        unless ($tag)     { carp "EDI tag received is empty";      next };
        unless ($segbody) { carp "EDI segment '$tag' has no body"; next };   # IIIIIIiiii, ain't got noboooOOoody!
        if (scalar @xtra) { carp scalar(@xtra) . " unexpected extra elements encountered in detect_version().  Ignoring!";}
        $tag eq 'UNH' or next;

        my $agency  = $segbody->{S009}->{'0051'};   # Thankfully these are true in all syntaxes/specs
        my $pre     = $segbody->{S009}->{'0052'};
        my $release = $segbody->{S009}->{'0054'};
        my $type    = $segbody->{S009}->{'0065'};
        $agency and $agency  eq 'UN' or return $class->carp_error("$tag/S009/0051 does not designate 'UN' as controlling agency");
        $pre    and uc($pre) eq 'D'  or return $class->carp_error("$tag/S009/0052 does not designate 'D' as spec (prefix) version");
        $release                     or return $class->carp_error("$tag/S009/0054 (spec release version) is empty (example value: '96A')");

        @_ and $_[0] and return "$pre$release";     #  "string only"
        my $edi = Business::EDI->new(version => "$pre$release") or
            return $class->carp_error("Spec unrecognized: Failed to create new Business::EDI object with version => '$pre$release'");
        return $edi->message($type, $body);
    }
}

1;

__END__

=head1 NAME

Business::EDI - Top level class for generating U.N. EDI interchange objects and subobjects.

=head1 SYNOPSIS

  use Business::EDI;
  
  my $edi = Business::EDI-new('d09b');      # set the EDI spec version
  my $rtc = $edi->codelist('ResponseTypeCode', $json) or die "Unrecognized code!";
  printf "EDI response type: %s - %s (%s)\n", $rtc->code, $rtc->label, $rtc->value;

  my $msg = Business::EDI::Message->new($ordrsp) or die "Failed Message constructor";
  foreach ($msg->xpath('line_detail/all_LIN') {
      ($_->part(7143) || '') eq 'EN' or next;
      print $_->part(7140)->value, "\n";    # print all the 13-digit (EN) ISBNs
  }


=head1 DESCRIPTION

The focus of functionality is to provide object based access to EDI messages and subelements.
At present, the EDI input processed by Business::EDI objects is JSON from the B<edi4r> ruby library, and
there is no EDI output beyond the perl objects themselves.

=head1 NAMESPACE

When you C<use Business::EDI;> the following package namespaces are also loaded:
    L<Business::EDI::Segment_group>
    L<Business::EDI::Message> 

That's why the example message constructor in SYNOPSIS would succeed without having done C<use Business::EDI::Message;>

=head1 EDI Structure

Everything depends on the spec.  That means you have to have declared a spec version before you can create
or parse a given chunk of data.  The exception is a whole EDI message, because each message declares its 
spec version internally.  

EDI has a hierachical specification defining data.  From top to bottom, it includes:

=over

=item B<Communication> - containing one or more messages (not yet modeled here)

=item B<Message>       - containing segment groups and segments

=item B<Segment Group> - containing segments

=item B<Segment>       - containing composites, codelists and data elements

=item B<Composite>     - containing multiple codelists and/or data elements

=item B<Codelist>      - enumerated value from a spec-defined set

=item B<Data Element>  - unenumerated value

=back

This module handles messages and everything below, but not (yet) communications. 

=head1 CLASS FUNCTIONS

Much more documentation needed here...

=head2 new()

Constructor

=head1 OBJECT METHODS (General)

=head2 value()

Get/set accessor for the value of the field.

=head2 code()

The string code designating this node's type.  The code is what is what the spec uses to refer to the object's definition.
For example, a composite "C504", segment "RFF", data element "7140", etc.

Don't be confused when dealing with CodeList objects.  Calling code() gets you the 4-character code of the CodeList field, NOT
what that CodeList is currently set to.  For that use value().  

=head2 desc()

English description of the element.

=head1 METHODS (for Traversal)

=head2 part_keys()

This method returns strings that can be fed to part() like:
    foreach ($x->part_keys) { something($x->part($_)) }

This is similar to doing:
    foreach (keys %x) { something($x{$_}) }

In this way an object can be exhaustively, recursively parsed without further knowledge of it.

=head2 part($key)

Returns subelement(s) of the object.  The key can reference any subobject allowed by the spec.  If the subobject is repeatable,
then prepending "all_" to the key will return an array of all such subobjects.  This is the safest and most comprehensive approach.
Using part($key) without "all_" to retrieve when there is only one $key subobject will succeed.
Using part($key) without "all_" to retrieve when there are multiple $key subobjects will FAIL.  Since that difference is only dependent on data, 
you should always use "all_" when dealing with a repeatable field (or xpath, see below).

Examples:

    my $qty  = $detail->part('QTY');      # FAILURE PRONE!
    my @qtys = $detail->part('all_QTY');  # OK!


=head2 xpath($path)

$path can traverse multiple depths in representation via one call.  For example:

    $message->xpath('all_SG26/all_QTY/6063')

is like this function foo():

    sub foo {
        my @x;
        for my $sg ($message->part->('all_SG26') {
            for ($sg->part('all_QTY') {
                push @x, $->part('6063');
            }
        }
        return @x;
    }

The xpath version is much nicer!  However this is nowhere near as fully featured as
W3C xpath for XML.  This is more like a multple-depth part().  

Examples:
    my @obj_1154 = $message->xpath('line_detail/SG31/RFF/C506/1154');

=head2 xpath_value($path)

Returns value(s) instead of object(s).

Examples:
    'ORDRSP' eq $ordrsp->xpath_value('UNH/S009/0065') or die "Wrong Message Type!";


=head1 WARNINGS

This code is experimental.  EDI is a big spec with many revisions.

At the lower levels, all data elements, codelists, composites and segments from the most recent spec (D09B) are present.  

=head1 SEE ALSO

 Business::EDI::Spec
 edi4r - http://edi4r.rubyforge.org

=head1 AUTHOR

Joe Atzberger