1package Business::EDI; 2 3use strict; 4use warnings; 5use Carp; 6# use Data::Dumper; 7 8our $VERSION = 0.05; 9 10use UNIVERSAL::require; 11use Data::Dumper; 12use File::Spec; 13use CGI qw//; 14use Business::EDI::CodeList; 15use Business::EDI::Composite; 16use Business::EDI::DataElement; 17use Business::EDI::Segment; 18use Business::EDI::Spec; 19 20our $debug = 0; 21our %debug = (); 22our $error; # for the whole class 23my %fields = (); 24 25our $AUTOLOAD; 26sub DESTROY {} # 27sub AUTOLOAD { 28 my $self = shift; 29 my $class = ref($self) or croak "AUTOLOAD error: $self is not an object, looking for $AUTOLOAD"; 30 my $name = $AUTOLOAD; 31 32 $name =~ s/.*://; # strip leading package stuff 33 $name =~ /^syntax/ or # leave syntax, 34 $name =~ /^SG\d+$/ or # leave SGxx alone (for segment groups) 35 $name =~ s/^s(eg(ment)?)?//i or # strip segment (a prefix to avoid numerical method names) 36 $name =~ s/^p(art)?//i; # strip part -- autoload's parallel accessor, e.g. ->part4343 to ->part(4343) 37 38 $debug and warn "AUTOLOADING '$name' for " . $class; 39 40 if (exists $self->{_permitted}->{$name}) { # explicitly named accessible fields 41 if (@_) { 42 return $self->{$name} = shift; 43 } else { 44 return $self->{$name}; 45 } 46 } 47 48 if (ref $self->{def} eq 'ARRAY') { # spec defined subelements 49 if ($name =~ s/^all_(.+)$/$1/i) { 50 @_ and croak "AUTOLOAD error: all_$name is read_only, rec'd argument(s): " . join(', ', @_); 51 if ($debug) { 52 warn "AUTOLOADing " . $self->{code} . "/all_$name (from " . scalar(@{$self->{array}}) . " arrayed elements): " 53 . join(' ', map {$_->{code}} @{$self->{array}}); 54 $debug > 1 and print STDERR Dumper($self), "\n"; 55 } 56 my $target = $name =~ /^SG\d+$/ ? ($self->{code} . "/$name") : $name; 57 return grep {$_->{code} and $_->{code} eq $target} @{$self->{array}}; # return array 58 } 59 return __PACKAGE__->_deepload_array($self, $name, @_); # not $self->_deepload - avoid recursion 60 } 61 # lastly, try to reach through any Cxxx Composites, if the target is unique 62 return __PACKAGE__->_deepload($self, $name, @_); # not $self->_deepload - avoid recursion 63} 64 65sub _deepload_array { 66 my $pkg = shift; # does nothing 67 my $self = shift or return; 68 my $name = shift or return; 69 unless ($self->{def}) { 70 die "_deepload_array of '$name' attempted on an object that does not have a spec definition"; 71 return; 72 } 73 74 my @hits = grep {$_->{code} eq $name} @{$self->{def}}; 75 my $defcount = scalar @{$self->{def}}; 76 my $hitcount = scalar @hits; 77 my $total_possible = 0; 78 foreach (@hits) { 79 $total_possible += ($_->{repeats} || 1); 80 } 81 $name =~ /^SG\d+$/ and $name = $self->{message_code} . "/$name"; # adjust key for SGs 82 $debug and warn "Looking for '$name' matches $hitcount of $defcount subelements, w/ $total_possible instances: " . join(' ', map {$_->{code}} @hits); 83 $debug and warn ref($self) . " self->{array} has " . scalar(@{$self->{array}}) . " elements of data"; 84 85 # Logic: 86 # If there is only one possible element to match, then we can read/write to it. 87 # But if there are multiple repetitions possible, then we cannot tell which one to target, 88 # UNLESS it is a read operation and there is only one such element populated. 89 # Write operation still would be indifferentiable between new element constructor and existing elememt overwrite. 90 if ($total_possible == 1 or ($hitcount == 1 and not @_)) { 91 foreach (@{$self->{array}}) { 92 $_->code eq $name or next; 93 if (@_) { 94 return $_ = shift; 95 } else { 96 return $_; 97 } 98 } 99 # if we got here, it's a valid target w/ no populated value (no code match) 100 return; 101 # @_ or return $self->_subelement_helper($name, {}, $self->{message_code}); # so you get an empty object of the correct type on read 102 # TODO: for 1-hit write, splice in at the correct position. Tricky. 103 } elsif ($total_possible == 0) { 104 $debug and $debug > 1 and print STDERR "FAILED _deepload_array of '$name' in object: ", Dumper($self); 105 } 106 croak "AUTOLOAD error: Cannot " . (@_ ? 'write' : 'read') . " '$name' field of class '" . ref($self) 107 . "', $hitcount matches ($total_possible repetitions) in subelements"; 108} 109 110sub _deepload { 111 my $pkg = shift; # does nothing 112 my $self = shift or return; 113 my $name = shift or return; 114 $self->{_permitted} or return; 115 116 my @partkeys = $self->part_keys; 117 my @keys = grep {/^C\d{3}$/} @partkeys; 118 my $allcount = scalar(@partkeys); 119 my $ccount = scalar(@keys); 120 $debug and warn "Looking for $name under $allcount subelements, $ccount Composites: " . join(' ', @keys); 121 122 my @hits = grep {$name eq $_} @partkeys; 123 if (scalar @hits) { 124 125 } elsif ($ccount) { 126 my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can autoload objects"; 127 my $part = $spec->get_spec('composite'); 128 foreach my $code (@keys) { 129 $part->{$code} or croak(ref($self) . " Object _permitted composite code '$code' not found in spec version " . $spec->version); 130 my @subparts = grep {$_->{code} eq $name} @{$part->{$code}->{parts}}; 131 @subparts and push(@hits, map {$code} @subparts); 132 # important here, we add the Cxxx code once per hit in its subparts. Multiple hits means we cannot target cleanly. 133 } 134 } 135 my $hitcount = scalar(@hits); 136 $debug and warn "Found $name has $hitcount possible match(es) in $ccount Composites: " . join(' ', @hits); 137 if ($hitcount == 1) { 138 if (@_) { 139 return $self->{$hits[0]}->{$name} = shift; 140 } else { 141 return $self->{$hits[0]}->{$name}; 142 } 143 } elsif ($hitcount > 1) { 144 croak "AUTOLOAD error: Cannot access '$name' field of class '" . ref($self) . "', " 145 . " $hitcount indeterminate matches in collapsable subelements"; 146 } 147 # else hitcount == 0 148 $debug and $debug > 1 and print STDERR "FAILED _deepload of '$name' in object: ", Dumper($self); 149 croak "AUTOLOAD error: Cannot access '$name' field of class '" . ref($self) 150 . "' (or $allcount collapsable subelements, $ccount Composites)"; 151} 152 153# Constructors 154 155sub new { 156 my $class = shift; 157 my %args; 158 if (scalar @_ eq 1) { 159 $args{version} = shift; 160 } elsif (@_) { 161 scalar(@_) % 2 and croak "Odd number of arguments to new() incorrect. Use (name1 => value1) style."; 162 %args = @_; 163 } 164 my $stuff = {_permitted => {(map {$_ => 1} keys %fields)}, %fields}; 165 foreach (keys %args) { 166 $_ eq 'version' and next; # special case 167 exists ($stuff->{_permitted}->{$_}) or croak "Unrecognized argument to new: $_ => $args{$_}"; 168 } 169 my $self = bless($stuff, $class); 170 if ($args{version}) { 171 $self->spec(version => $args{version}) or croak "Unrecognized spec version '$args{version}'"; 172 } 173 $debug and $debug > 1 and print Dumper($self); 174 return $self; 175} 176 177# BIG Complicated META-Constructors!! 178 179sub _common_constructor { 180 my $self = shift; 181 my $type = shift or die "Internal error: _common_constructor called without required argument for object type"; 182 my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can create $type objects"; 183 my $part = $spec->get_spec($type); 184 my $code = uc(shift) or croak "No $type code specified"; 185 my $body = shift; 186 187 $part->{$code} or return $self->carp_error("$type code '$code' is not found amongst " 188 . scalar(keys %$part) ." ". $type . "s in spec version " . $spec->version); # . ": " . Dumper([sort keys %$part])); 189 190 unless (ref($body) eq 'HASH') { 191 return $self->carp_error("body argument for $type must be HASHREF, not '" . ref($body) . "'"); 192 } 193 my @subparts = map {$_->{code}} @{$part->{$code}->{parts}}; 194 my @required = map {$_->{code}} grep {$_->{mandatory}} @{$part->{$code}->{parts}}; 195 196 my ($compspec, @compcodes); 197 my ( $segspec, @seggroups); 198 foreach (@subparts) { 199 /^SG\d+$/ and push(@seggroups, $_) and next; 200 /^C\d{3}$/ and push(@compcodes, $_) and next; 201 } 202 $compspec = $spec->get_spec('composite') if @compcodes; 203 # $segspec = $spec->get_spec('segment') if @seggroups; 204 205 my $normal; 206 # Now we normalize the body according to the spec (apply wrappers) 207 foreach my $key (keys %$body) { 208 if (grep {$key eq $_} @subparts) { 209 $normal->{$key} = $body->{$key}; # simple case 210 next; 211 } 212 elsif (@compcodes) { 213 my @hits; 214 foreach my $compcode (@compcodes) { 215 push @hits, map {$compcode} grep {$_->{code} eq $key} @{$compspec->{$compcode}->{parts}}; 216 } 217 if (scalar(@hits) == 1) { 218 $normal->{$hits[0]}->{$key} = $body->{$key}; # only one place for it to go, so apply the wrapper 219 next; 220 } elsif (scalar(@hits) > 1) { 221 return $self->carp_error("$type subpart '$key' has " . scalar(@hits) 222 . " indeterminate matches under composites: " . join(', ', @hits) 223 ); 224 } 225 return $self->carp_error("$type subpart '$key' not found in spec " . $spec->version); 226 } 227 } 228 229 $debug and printf STDERR "creating $type/$code with %d spec subpart(s): %s\n", scalar(@subparts), join(' ', @subparts); 230 # push @subparts, 'debug'; 231 my $unblessed = $self->unblessed($normal, \@subparts); 232 $unblessed or return; 233 my $new = bless($unblessed, __PACKAGE__ . '::' . ucfirst($type)); 234 $new->spec($spec); 235 $new->{_permitted}->{code} = 1; 236 $new->{_permitted}->{label} = 1; 237 $new->{code} = $code; 238 $new->{label} = $part->{$code}->{label}; 239 # $new->debug($debug{$type}) if $debug{$type}; 240 foreach (@required) { 241 unless (defined $new->part($_)) { 242 return $self->carp_error("Required field $type/$code/$_ not populated"); 243 } 244 } 245 return $new; 246} 247 248sub _def_based_constructor { 249 my $self = shift; 250 my $type = shift or die "Internal error: _def_based_constructor called without required argument for object type"; 251 my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can create $type objects"; 252 my $page = $self->spec_page($type); # page of the spec 253 my $code = uc(shift) or croak "No $type code specified"; 254 my $body = shift; 255 my $message_code = (@_ and $_[0]) ? shift : ''; 256 my $page_code; 257 258 if ($type eq 'message') { 259 $message_code = $code; 260 $page_code = $code; 261 } elsif ($type eq 'segment_group') { 262 $code =~ /^SG\d+$/ and $message_code and $code = "$message_code/$code"; 263 $code =~ /^(\S+)\/(SG\d+)$/ or return $self->carp_error("Cannot spec $type '$code' without message. Use xpath style, like 'ORDERS/SG27'"); 264 $page = $page->{$1} or return $self->carp_error("Message $1 does not have any " . $type . "s in spec version " . $spec->version); 265 $message_code = $1; 266 $page_code = $2; 267 # tighen spec down past message level based on first part of key 268 } 269 270 unless (ref($body) eq 'ARRAY') { 271 return $self->carp_error("body argument to $type() must be ARRAYREF, not '" . ref($body) . "'"); 272 } 273 274 my @subparts = @{$page->{$page_code}->{parts}}; 275 $debug and printf STDERR "creating $type/$code with %d spec subpart(s): %s\n", scalar(@subparts), join(' ', map {$_->{code}} @subparts); 276 $debug and print STDERR "calling \$self->unblessed_array(\$body, \$page->{$page_code}->{parts}, '$message_code')\n"; 277 my $unblessed = $self->unblessed_array($body, \@subparts, $message_code); # doesn't yet support arrayref(?) 278 $unblessed or return; 279 my $new = bless($unblessed, __PACKAGE__ . '::' . ucfirst($type)); 280 $new->spec($spec); 281 $new->{_permitted}->{code} = 1; 282 $new->{_permitted}->{message_code} = 1; 283 $new->{_permitted}->{label} = 1; 284 $new->{code} = $code; 285 $new->{message_code} = $message_code; # same as code for messages, different for SGs 286 $new->{label} = $page->{$page_code}->{label}; 287 if ($type eq 'segment_group') { 288 $new->{sg_code} = $page_code; 289 } 290 return $new; 291} 292 293# Fundamental constructor calls for different object types 294# These are here so you can just "use Business::EDI;" and not have to worry about using different 295# modules for different data objects. 296 297sub segment { 298 my $self = shift; 299 return $self->_common_constructor('segment', @_); 300} 301 302sub segment_group { 303 my $self = shift; 304 return $self->_def_based_constructor('segment_group', @_); 305# The difference is that segment_group must deal with repeatable segments, other segment groups, etc. 306} 307 308# TODO: rename detect_version one something more clueful 309# The difference is that message() expects you to have declared an EDI spec version already, whereas detect_version 310# just looks at the contents of the passed data, attempting to extract the encoded version there. 311 312sub detect_version { 313 my $self = shift; 314 return Business::EDI::Message->new(@_); 315} 316 317sub message { 318 my $self = shift; 319 # my $msg_code = shift; 320 #print Dumper ($body); 321 return $self->_def_based_constructor('message', @_); 322} 323 324sub dataelement { 325 my $self = shift; 326 # Business::EDI::DataElement->require; 327 Business::EDI::DataElement->new(@_); 328} 329 330sub composite { 331 my $self = shift; 332 # Business::EDI::DataElement->require; 333 Business::EDI::Composite->new(@_); 334} 335 336sub codelist { 337 my $self = shift; 338 # my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can create objects"; 339 # my $part = $spec->get_spec('message'); 340 Business::EDI::CodeList->new_codelist(@_); 341} 342 343sub spec_page { 344 my $self = shift; 345 my $spec = $self->spec or croak "You must set a spec version (via constructor or spec method) before EDI can retrieve part of it"; 346 @_ or return carp_error("Missing argument to spec_page()"); 347 return $spec->get_spec(@_); # not $self->get_spec .... sorry 348} 349 350sub get_spec { 351 my $self = shift; 352 @_ or return carp_error("Missing argument to get_spec()"); 353 return Business::EDI::Spec->new(@_); 354} 355 356# Accessor get/set methods 357 358sub code { 359 my $self = shift; 360 @_ and $self->{code} = shift; 361 return $self->{code}; 362} 363 364sub spec { # spec(code) 365 my $self = shift; 366 if (@_) { # Arg(s) mean we are constructing 367 ref($self) or return $self->get_spec(@_); # Business::EDI->spec(...) style, class method: simple constructor 368 if (ref($_[0]) eq 'Business::EDI::Spec') { # TODO: use isa or whatever the hip OO style of role-checking is 369 $self->{spec} = shift; # We got passed a full spec object, just set 370 } else { 371 $self->{spec} = $self->get_spec(@_); # otherwise construct and retain 372 } 373 } 374 ref($self) or croak "Cannot use class method Business::EDI->spec as an accessor (spec is uninstantiated). " . 375 "Get a spec'd object first like: Business::EDI->new('d87a')->spec, " . 376 "or specify the version you want: Business::EDI->spec('default') or Business::EDI->get_spec('default')"; 377 return $self->{spec}; 378} 379 380sub error { 381 my ($self, $msg, $quiet) = @_; 382 $msg or return $self->{error} || $error; # just an accessor 383 ($debug or ! $quiet) and carp $msg; 384 return $self->{error} = $msg; 385} 386 387sub carp_error { 388 my $obj_or_message = shift; 389 my $msg; 390 if (@_) { 391 $msg = (ref($obj_or_message) || $obj_or_message) . ' - ' . shift; 392 } else { 393 $msg = $obj_or_message; 394 } 395 if (ref $obj_or_message) { 396 # do something? 397 } 398 carp $msg; 399 return; # undef: important! 400} 401 402# ->unblessed($body, \@codes) 403 404sub unblessed { # call like Business::EDI->unblessed(\%hash, \@codes); 405 my $class = shift; 406 my $body = shift; 407 my $codesref = shift; 408 $body or return carp_error "1st required argument to unblessed() is EMPTY"; 409 $codesref or return carp_error "2nd required argument to unblessed() is EMPTY"; 410 unless (ref($body) eq 'HASH') { 411 return carp_error "1st argument to unblessed() must be HASHREF, not '" . ref($body) . "'"; 412 } 413 unless (ref($codesref) eq 'ARRAY') { 414 return carp_error "2nd argument to unblessed() must be ARRAYREF, not '" . ref($codesref) . "'"; 415 } 416 $debug and printf STDERR "good: unblessed() got body and definition: %s/%s topnodes/defs\n", scalar(keys %$body), scalar(@$codesref); #, Dumper($body), "\n"; 417 my $self = {}; 418 foreach (@$codesref) { 419 $self->{_permitted}->{$_} = 1; 420 $body->{$_} or next; 421 $self->{$_} = Business::EDI->subelement({$_ => $body->{$_}}) || $body->{$_}; 422 } 423 return $self; 424} 425 426# array based object creation (segment groups) 427# allows repeatable subobjects 428# enforces mandatory subobjects 429sub unblessed_array { # call like Business::EDI->unblessed_array(\@pseudo_hashes, \@code_objects); 430 my $class = shift; 431 my $body = shift; 432 my $codesref = shift; 433 my $msg = (@_ and $_[0]) ? shift : ''; 434 # my $msg = 'ORDRSP'; 435 my $strict = 0; 436 $body or return carp_error "1st required argument 'x' to unblessed_array(x,y,'$msg') is EMPTY"; 437 $codesref or return carp_error "2nd required argument 'y' to unblessed_array(x,y,'$msg') is EMPTY"; 438 unless (ref($body) eq 'ARRAY') { 439 return carp_error "1st argument to unblessed_array() must be ARRAYREF, not '" . ref($body) . "'"; 440 } 441 unless (ref($codesref) eq 'ARRAY') { 442 return carp_error "2nd argument to unblessed_array() must be ARRAYREF, not '" . ref($codesref) . "'"; 443 } 444 $debug and printf STDERR "good: unblessed_array() got body and definition: %s/%s topnodes/defs\n", scalar(@$body), scalar(@$codesref); #, Dumper($body), "\n"; 445 my $self = { 446 array => [], # subelements get pushed in here 447 def => $codesref, 448 _permitted => {array => 1, def => 1}, 449 }; 450 451 my $sg_specs = $class->spec_page('segment_group') or croak "Cannot get Segment Group definitions"; 452 my $msg_sg_specs = $sg_specs->{$msg} or croak "ERROR: $msg Segment Groups not defined in spec"; 453 my $codecount = scalar @$codesref; 454 my $j = 0; # index for @$codesref 455 my $repeats = 0; 456 my $last_matched = ''; 457 my $i; 458 if (@$body == 2 and ref($body->[0]) eq '') { 459 # push @{$self->{array}}, $class->_subelement_helper($body->[0], $body->[1], $msg); 460 # return $self; 461 $body = [ [$body->[0], $body->[1]] ]; 462 } 463 464 BODYPART: for ($i=0; $i < @$body; $i++) { 465 my $bodypart = $body->[$i]; 466 # next if ref($bodypart) =~ /)^Business::EDI::/; 467 unless (ref($bodypart) eq 'ARRAY') { 468 warn "Malformed data. Bodypart $i is expected to be pseudohash ARRAYREF, not " 469 . (ref($bodypart) || "a scalar='$bodypart'") . ". Skipping it..."; 470 next; 471 } 472 my $key = $bodypart->[0]; 473 $debug and print "BODYPART $i: $key\n"; 474 while ($j < $codecount) { 475 my $def = $codesref->[$j]; 476 $debug and printf STDERR "BODYPART $i: $key comparing to def $j: %5s %s\n", $def->{code}, ($key eq $def->{code} ? 'MATCH!' : ''); 477 if ($key eq $def->{code}) { 478 $last_matched = $key; 479 my $limit = $def->{repeats}; # checking the PREVIOUS def to see if it allows repetition 480 if (++$repeats <= $limit) { 481 push @{$self->{array}}, $class->_subelement_helper($key, $bodypart->[1], $msg); 482 } else { 483 $strict and die "Code '$key' is limited to $limit occurrences. Dropping data!!"; 484 warn "Code '$key' is limited to $limit occurrences. Dropping data!!"; 485 } 486 next BODYPART; 487 } 488 # check if this def was mandatory (satisfied if we already added it) 489 if ($def->{mandatory} and $def->{code} !~ /^UN.$/ and not $repeats) { 490 my $msg = "Mandatory code '" . $def->{code} . "' from definition $j missing or out of position (last found '$key' at position $i)"; 491 $strict and return carp_error $msg; 492 $debug and warn $msg; 493 } 494 $repeats = 0; 495 $j++; # move the index to the next rule 496 } 497 # now either we matched, or we ran out of tries 498 if ($j >= $codecount) { # if we ran out of tries, error 499 my $msg = "All $j subelements exhausted. Code '$key' from position $i not matched"; 500 $strict and return carp_error $msg; 501 $debug and warn $msg; # FIXME: this happens too often 502 } 503 } 504 return $self; 505 # We're out of parts, so time to check for any outstanding mandatory defs (same kind of loop) 506 # This check doesn't work because a subelement can be mandatory in a given optional element. Context matters. 507 while (++$j < $codecount) { 508 $codesref->[$j]->{mandatory} and return carp_error 509 "Mandatory code '" . $codesref->[$j]->{code} . "' from definition $j missing (all ". $i+1 . " data traversed)"; 510 } 511} 512 513sub _subelement_helper { 514 my ($class, $key, $body, $msg) = @_; 515 if ($key =~ /^[A-Z]{3}$/) { 516 $debug and print STDERR "SEGMENT ($key) detected\n"; 517 return $class->segment($key => $body); 518 } else { 519 return $class->subelement({$key => $body}, $msg); 520 } 521} 522 523# Similar to AUTOLOAD, but by an exact argument, does get and set 524# This code should parallel AUTOLOAD tightly. 525sub part { 526 my $self = shift; 527 my $class = ref($self) or croak "part() object method error: $self is not an object"; 528 my $name = shift or return; 529 530 unless (exists $self->{_permitted}->{$name}) { 531 if ($self->{def}) { 532 if ($name =~ s/^all_(.+)$/$1/i) { # strip 'all_' prefix 533 @_ and croak "part() error: all_$name is read_only, rec'd argument(s): " . join(', ', @_); 534 if ($debug) { 535 warn "part() " . $self->{code} . "/all_$name (from " . scalar(@{$self->{array}}) . " arrayed elements): " 536 . join(' ', map {$_->{code}} @{$self->{array}}); 537 $debug > 1 and print STDERR Dumper($self), "\n"; 538 } 539 my $target = $name =~ /^SG\d+$/ ? ($self->{message_code} . "/$name") : $name; 540 return grep {$_->{code} and $_->{code} eq $target} @{$self->{array}}; # return array 541 } 542 return __PACKAGE__->_deepload_array($self, $name, @_); # not $self->_deepload_array - avoid recursion 543 } 544 return __PACKAGE__->_deepload($self, $name, @_); # not $self->_deepload - avoid recursion 545 } 546 547 if (@_) { 548 return $self->{$name} = shift; 549 } else { 550 return $self->{$name}; 551 } 552} 553 554# part_keys gives you values that are always valid as the argument to the same object's part() method 555# TODO: mix/match both _permitted and def based? Maybe. 556 557sub part_keys { 558 my $self = shift; 559 if ($self->{def}) { 560 return map { my $key = $_->{code}; $_->{repeats} > 1 ? "all_$key" : $key } @{$self->{def}}; 561 } 562 return keys %{$self->{_permitted}}; 563 # 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"; 564} 565 566 567# Example data: 568# 'BGM', { 569# '1004' => '582822', 570# '4343' => 'AC', 571# '1225' => '29', 572# 'C002' => { 573# '1001' => '231' 574# } 575# } 576 577our $codelist_map; 578 579# Tricky recursive constructor! 580sub subelement { 581 my $self = shift; 582 my $body = shift; 583 my $message_code = (@_ and $_[0]) ? shift : ''; 584 if (! $body) { 585 carp "required argument to subelement() empty"; 586 return; 587 } 588 unless (ref $body) { 589 $debug and carp "subelement() got a regular scalar argument. Returning it ('$body') as subelement"; 590 return $body; 591 } 592 ref($body) =~ /^Business::EDI/ and return $body; # it's already an EDI object, return it 593 594 if (ref($body) eq 'ARRAY') { 595 if (scalar(@$body) != 2) { 596 carp "Array expected to be psuedohash with 2 elements, or wrapper with 1, instead got " . scalar(@$body); 597 return; # [(map {ref($_) ? $self->subelement($_) : $_} @$body)]; # recursion 598 } else { 599 $body = {$body->[0] => $body->[1]}; 600 } 601 } 602 elsif (ref($body) ne 'HASH') { 603 carp "argument to subelement() should be ARRAYref or HASHref or Business::EDI subobject, not type '" . ref($body) . "'"; 604 return; 605 } 606 $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"; 607 $codelist_map ||= Business::EDI::CodeList->codemap; 608 my $new = {}; 609 foreach (keys %$body) { 610 $debug and print STDERR "subelement building from key '$_'\n"; 611 my $ref = ref($body->{$_}); 612 if ($codelist_map->{$_}) { # If the key is in the codelist map, it's a codelist 613 $new->{$_} = $self->codelist($_, $body->{$_}) 614 or carp "Bad ref ($ref) in body for key $_. Codelist subelement not created"; 615 } elsif (/^C\d{3}$/ or /^S\d{3}$/) { 616 $new->{$_} = Business::EDI::Composite->new({$_ => $body->{$_}}) # Cxxx and Sxxx codes are for Composite data elements 617 or carp "Bad ref ($ref) in body for key $_. Composite subelement not created"; 618 } elsif (/^[A-Z]{3}$/) { 619 $new->{$_} = $self->segment($_, $body->{$_}) # ABC codes are for Segments 620 or carp "Bad ref ($ref) in body for key $_. Segment subelement not created"; 621 } elsif (/^(\S+\/)?(SG\d+)$/) { 622 my $sg_spec = $_; 623 my $msg = $1; 624 my $sg_tag = $2; 625 $sg_spec =~ s/\/\S+\//\//; # delete middle tags: ORDRSP/SG25/SG26 => ORSRSP/SG26 626 $new->{$sg_spec} = $self->segment_group(($msg ? $sg_spec : "$message_code/$sg_tag"), $body->{$_}, $message_code) # SGx[x] codes are for Segment Groups 627 or carp "Bad ref ($ref) in body for key $_. Segment_group subelement not created"; 628 } elsif ($ref eq 'ARRAY') { 629 my $count = scalar(@{$body->{$_}}); 630 $count == 1 or carp "Repeated section '$_' appears $count times. Only handling first appearance"; # TODO: fix this 631 $new->{repeats}->{$_} = -1; 632 $new->{$_} = $self->subelement($body->{$_}->[0], $message_code) # ELSE, break the ref down (recursively) 633 or carp "Bad ref ($ref) in body for key $_. Subelement not created"; 634 } elsif ($ref) { 635 $new->{$_} = $self->subelement($body->{$_}, $message_code) # ELSE, break the ref down (recursively) 636 or carp "Bad ref ($ref) in body for key $_. Subelement not created"; 637 } else { 638 $new->{$_} = Business::EDI::DataElement->new($_, $body->{$_}); # Otherwise, a terminal (non-ref) data node means it's a DataElement 639 # like Business::EDI::DataElement->new('1225', '582830'); 640 } 641 (scalar(keys %$body) == 1) and return $new->{$_}; # important: if that's our only key/pair, return the object itself, no wrapper. 642 } 643 return $new; 644} 645 646 647# not really xpath, but xpath-lite-like. the idea here is to never crash on a valid path, just return undef. 648sub xpath { 649 my $self = shift; 650 my $path = shift or return; 651 my $class = ref($self) or croak "xpath() object method error: $self is not an object"; 652 $path eq '/' and return $self; 653 $path =~ m#([^-A-z_0-9/\.])# and croak "xpath does not handle '$1' in the path, just decending paths like 'SG27/LIN/1229'"; 654 $path =~ m#(//)# and croak "xpath does not handle '$1' in the path, just decending paths like 'SG27/LIN/1229'"; 655 $path =~ m#^/# and croak "xpath does not handle leading slashes in the path, just decending relative paths like 'SG27/LIN/1229'"; 656 657 my ($front, $back) = split "/", $path, 2; 658 defined $front or $front = ''; 659 defined $back or $back = ''; 660 $debug and print STDERR $class . "->xpath($path) ==> ->part($front)->xpath($back);\n"; 661 662 if ($front) { 663 $back or return $self->part($front); # no trailing part means we're done! 664 my @ret; 665 push @ret, $self->part($front) or return; # front might return multiple hits ('all_SG3', for example) 666 return grep {defined $_} map {$_->xpath($back)} @ret; 667 } 668 croak "xpath does not handle leading slashes in the path, just decending relative paths like 'SG27/LIN/1229'"; 669} 670 671sub xpath_value { 672 my $self = shift; 673 my @hits = $self->xpath(@_); 674 @hits or return; 675 wantarray or return $hits[0]->value; 676 return map {$_->value} @hits; 677} 678 679our $cgi; 680# Write your own CSS 681sub html { 682 my $self = shift; 683 my $empties = @_ ? shift : 0; 684 my $indent = @_ ? shift : 0; 685 my $obtype = ref $self or return $self; 686 my $x = ' ' x $indent; 687 688 my $extra = ''; 689 $obtype =~ s/^Business::EDI::// or return "$x<div class='edi_error'>$obtype object</div>"; 690 if ($obtype =~ /::(.*)$/) { 691 $extra = " edi_$1"; 692 $extra =~ s/::/_/; 693 $obtype =~ s/::.*$//; 694 } 695 696 my $html = "$x<div class='edi_node edi_$obtype$extra'>"; 697 my %tophash; 698 foreach (qw/code label desc value/) { # get top values, if existing 699 $tophash{$_} = $self->$_ if (eval {$self->$_}); 700 } 701 $cgi ||= CGI->new(); 702 foreach (qw/code label desc value/) { # same order, w/ some fanciness for label (title attribute based on desc) 703 defined $tophash{$_} or next; 704 my $attrs = {class=>"edi_$_"}; 705 ($_ eq 'label') and $attrs->{title} = $tophash{desc}; 706 $html .= "\n$x " . $cgi->span($attrs, $self->$_); 707 } 708 709 my @keys = grep {$_ ne 'label' and $_ ne 'value' and $_ ne 'code' and $_ ne 'desc'} $self->part_keys; # disclude stuff we already got 710 #my @parts = map {$self->part($_)} $self->part_keys; 711 my @parts = $self->{array} ? @{$self->{array}} : map {$self->part($_)} @keys; 712 $debug and print STDERR $tophash{label}, " has ", scalar(@keys), " in part_keys: ", join(' ', @keys), "\n"; 713 # $_->{array} and print "$tophash{label} has ", scalar(@{$_->{array}}), " in array: " . join(' ', map {$_->{code}} @{$_->{array}}), "\n"; 714 $debug and print STDERR $tophash{label}, " has ", scalar(@parts), " in 'parts' : ", join(' ', map {ref($_) ? $_->{code} : $_} @parts), "\n"; 715 if (@parts) { 716 $html .= "\n$x <ul>"; 717 foreach (@parts) { 718 (ref $_ and $_->{code}) or next; 719 $debug and print STDERR "html(): $tophash{label} => " . $_->{code} . " subcall\n"; 720 $html .= "\n$x <li>\n" . $_->html($empties, $indent + 8) . "\n$x </li>"; 721 } 722 $html .= "\n$x </ul>" 723 } 724 return "$html\n$x</div>"; 725} 726 727 7281; 729 730# END of Business::EDI 731# ======================================================================================= 732 733package Business::EDI::Segment_group; 734use strict; use warnings; 735use Carp; 736use base qw/Business::EDI/; 737our $VERSION = 0.02; 738our $debug; 739 740sub sg_code { 741 my $self = shift or return; 742 @_ and croak "sg_code is read only (no args)"; 743 return $self->{sg_code}; 744} 745 746sub desc { # build a description on the fly 747 my $self = shift or return; 748 my $sgcode = $self->sg_code; 749 $sgcode =~ s/^SG//i; 750 return $self->{message_code} . " Segment Group $sgcode"; 751} 752 753# Business::EDI::Segment_group gets its own part method to handle meta-mapped SGs INSIDE other SGs, 754# but it falls back to the main part method after that. 755 756sub part { 757 my $self = shift; 758 my $class = ref($self) or croak("part object method error: $self is not an object"); 759 my $name = shift or return; 760 my $code = $self->{message_code} or return $self->carp_error("Message type (code) unset. Cannot assess metamapping."); 761 my $spec = $self->{spec} or return $self->carp_error("Message spec (code) unset. Cannot assess metamapping."); 762 my $sg = $spec->metamap($code, $name); 763 my $str_spec = "in spec " . $spec->version; 764 if ($sg) { 765 $debug and warn "SG Message/field '$code/$name' ==> '$code/all_$sg' via mapping $str_spec"; 766 if ($sg =~ /\//) { 767 my $obj; 768 my @chunks = split '/', $sg; 769 my $first = shift @chunks; 770 my $last = pop @chunks; 771 $first eq $self->{sg_code} or return $self->carp_error("Mapped target $sg descends from $code/$first $str_spec, not " . $self->{sg_code}); 772 foreach (@chunks) { 773 $obj = $obj ? $obj->SUPER::part("all_$_") : $self->SUPER::part("all_$_"); 774 $obj or warn "Mapped SG $sg part 'all_$_' not found $str_spec"; 775 $obj or return; 776 } 777 return $obj ? $obj->SUPER::part("all_$last", @_) : $self->SUPER::part("all_$last", @_); # only the last part gets the remaining args 778 } else { 779 return $self->carp_error("Mapped target $sg is not under " . $self->{code} . " $str_spec"); 780 } 781 } else { 782 $debug and warn "Message/field '$code/$name' not mapped $str_spec. Skipping metamapping"; 783 } 784 return $self->SUPER::part($name, @_); 785} 786 787 7881; 789 790package Business::EDI::Message; 791use strict; use warnings; 792use Carp; 793use base qw/Business::EDI/; 794our $VERSION = 0.02; 795our $debug; 796 797# Business::EDI::Message gets its own part method to handle meta-mapped SGs, 798# but it falls back to the main part method after that. 799 800sub part { 801 my $self = shift; 802 my $class = ref($self) or croak("part object method error: $self is not an object"); 803 my $name = shift or return; 804 my $code = $self->{message_code} or return carp_error("Message type (code) unset. Cannot assess metamapping."); 805 my $spec = $self->{spec} or return carp_error("Message spec (code) unset. Cannot assess metamapping."); 806 my $sg = $spec->metamap($code, $name); 807 if ($sg) { 808 $sg =~ s#/#/all_#; # e.g. SG26/SG30 => SG26/all_SG30 809 $debug and warn "Message/field '$code/$name' => '$code/all_$sg' via mapping"; 810 $name = "all_$sg"; # new target from mapping 811 } else { 812 $debug and warn "Message/field '$code/$name' not mapped. Skipping metamapping"; 813 } 814 return $self->SUPER::part($name, @_); 815} 816 817# This is a very high level method. 818# We look inside a message body BEFORE we know what it is, and what spec it was written to. 819# Second argument is a flag for "string only", in which case we just return the composed version string (e.g. 'D96A') 820# otherwise we return a Business::EDI::Message object, or undef on failure. 821# 822# my $message = Business:EDI::Message->new($body); 823# my $version = Business:EDI::Message->new($body, 1); 824# 825# Handles ALL valid message types 826 827sub new { 828 my $class = shift; 829 my $body = shift or return $class->carp_error("missing required argument to detect_version()"); 830 ref($body) eq 'ARRAY' or return $class->carp_error("detect_version_string argument must be ARRAYref, not '" . ref($body) . "'"); 831 foreach my $node (@$body) { 832 my ($tag, $segbody, @xtra) = @$node; 833 unless ($tag) { carp "EDI tag received is empty"; next }; 834 unless ($segbody) { carp "EDI segment '$tag' has no body"; next }; # IIIIIIiiii, ain't got noboooOOoody! 835 if (scalar @xtra) { carp scalar(@xtra) . " unexpected extra elements encountered in detect_version(). Ignoring!";} 836 $tag eq 'UNH' or next; 837 838 my $agency = $segbody->{S009}->{'0051'}; # Thankfully these are true in all syntaxes/specs 839 my $pre = $segbody->{S009}->{'0052'}; 840 my $release = $segbody->{S009}->{'0054'}; 841 my $type = $segbody->{S009}->{'0065'}; 842 $agency and $agency eq 'UN' or return $class->carp_error("$tag/S009/0051 does not designate 'UN' as controlling agency"); 843 $pre and uc($pre) eq 'D' or return $class->carp_error("$tag/S009/0052 does not designate 'D' as spec (prefix) version"); 844 $release or return $class->carp_error("$tag/S009/0054 (spec release version) is empty (example value: '96A')"); 845 846 @_ and $_[0] and return "$pre$release"; # "string only" 847 my $edi = Business::EDI->new(version => "$pre$release") or 848 return $class->carp_error("Spec unrecognized: Failed to create new Business::EDI object with version => '$pre$release'"); 849 return $edi->message($type, $body); 850 } 851} 852 8531; 854 855__END__ 856 857=head1 NAME 858 859Business::EDI - Top level class for generating U.N. EDI interchange objects and subobjects. 860 861=head1 SYNOPSIS 862 863 use Business::EDI; 864 865 my $edi = Business::EDI-new('d09b'); # set the EDI spec version 866 my $rtc = $edi->codelist('ResponseTypeCode', $json) or die "Unrecognized code!"; 867 printf "EDI response type: %s - %s (%s)\n", $rtc->code, $rtc->label, $rtc->value; 868 869 my $msg = Business::EDI::Message->new($ordrsp) or die "Failed Message constructor"; 870 foreach ($msg->xpath('line_detail/all_LIN') { 871 ($_->part(7143) || '') eq 'EN' or next; 872 print $_->part(7140)->value, "\n"; # print all the 13-digit (EN) ISBNs 873 } 874 875 876=head1 DESCRIPTION 877 878The focus of functionality is to provide object based access to EDI messages and subelements. 879At present, the EDI input processed by Business::EDI objects is JSON from the B<edi4r> ruby library, and 880there is no EDI output beyond the perl objects themselves. 881 882=head1 NAMESPACE 883 884When you C<use Business::EDI;> the following package namespaces are also loaded: 885 L<Business::EDI::Segment_group> 886 L<Business::EDI::Message> 887 888That's why the example message constructor in SYNOPSIS would succeed without having done C<use Business::EDI::Message;> 889 890=head1 EDI Structure 891 892Everything depends on the spec. That means you have to have declared a spec version before you can create 893or parse a given chunk of data. The exception is a whole EDI message, because each message declares its 894spec version internally. 895 896EDI has a hierachical specification defining data. From top to bottom, it includes: 897 898=over 899 900=item B<Communication> - containing one or more messages (not yet modeled here) 901 902=item B<Message> - containing segment groups and segments 903 904=item B<Segment Group> - containing segments 905 906=item B<Segment> - containing composites, codelists and data elements 907 908=item B<Composite> - containing multiple codelists and/or data elements 909 910=item B<Codelist> - enumerated value from a spec-defined set 911 912=item B<Data Element> - unenumerated value 913 914=back 915 916This module handles messages and everything below, but not (yet) communications. 917 918=head1 CLASS FUNCTIONS 919 920Much more documentation needed here... 921 922=head2 new() 923 924Constructor 925 926=head1 OBJECT METHODS (General) 927 928=head2 value() 929 930Get/set accessor for the value of the field. 931 932=head2 code() 933 934The string code designating this node's type. The code is what is what the spec uses to refer to the object's definition. 935For example, a composite "C504", segment "RFF", data element "7140", etc. 936 937Don't be confused when dealing with CodeList objects. Calling code() gets you the 4-character code of the CodeList field, NOT 938what that CodeList is currently set to. For that use value(). 939 940=head2 desc() 941 942English description of the element. 943 944=head1 METHODS (for Traversal) 945 946=head2 part_keys() 947 948This method returns strings that can be fed to part() like: 949 foreach ($x->part_keys) { something($x->part($_)) } 950 951This is similar to doing: 952 foreach (keys %x) { something($x{$_}) } 953 954In this way an object can be exhaustively, recursively parsed without further knowledge of it. 955 956=head2 part($key) 957 958Returns subelement(s) of the object. The key can reference any subobject allowed by the spec. If the subobject is repeatable, 959then prepending "all_" to the key will return an array of all such subobjects. This is the safest and most comprehensive approach. 960Using part($key) without "all_" to retrieve when there is only one $key subobject will succeed. 961Using part($key) without "all_" to retrieve when there are multiple $key subobjects will FAIL. Since that difference is only dependent on data, 962you should always use "all_" when dealing with a repeatable field (or xpath, see below). 963 964Examples: 965 966 my $qty = $detail->part('QTY'); # FAILURE PRONE! 967 my @qtys = $detail->part('all_QTY'); # OK! 968 969 970=head2 xpath($path) 971 972$path can traverse multiple depths in representation via one call. For example: 973 974 $message->xpath('all_SG26/all_QTY/6063') 975 976is like this function foo(): 977 978 sub foo { 979 my @x; 980 for my $sg ($message->part->('all_SG26') { 981 for ($sg->part('all_QTY') { 982 push @x, $->part('6063'); 983 } 984 } 985 return @x; 986 } 987 988The xpath version is much nicer! However this is nowhere near as fully featured as 989W3C xpath for XML. This is more like a multple-depth part(). 990 991Examples: 992 my @obj_1154 = $message->xpath('line_detail/SG31/RFF/C506/1154'); 993 994=head2 xpath_value($path) 995 996Returns value(s) instead of object(s). 997 998Examples: 999 'ORDRSP' eq $ordrsp->xpath_value('UNH/S009/0065') or die "Wrong Message Type!"; 1000 1001 1002=head1 WARNINGS 1003 1004This code is experimental. EDI is a big spec with many revisions. 1005 1006At the lower levels, all data elements, codelists, composites and segments from the most recent spec (D09B) are present. 1007 1008=head1 SEE ALSO 1009 1010 Business::EDI::Spec 1011 edi4r - http://edi4r.rubyforge.org 1012 1013=head1 AUTHOR 1014 1015Joe Atzberger 1016 1017