File Coverage

blib/lib/Business/Edifact/Interchange.pm

Criterion	Covered	Total	%
statement	114	133	85.7
branch	20	34	58.8
condition	1	2	50.0
subroutine	17	19	89.4
pod	13	13	100.0
total	165	201	82.0

package Business::Edifact::Interchange;

use warnings;
use strict;
use 5.010;
use Carp;
use Encode;
use Business::Edifact::Message;

=head1 NAME

Business::Edifact::Interchange - Parse Edifact Messages For Book Ordering

=head1 VERSION

Version 0.07

=cut

our $VERSION = '0.07';

#  UNOA and UNOB "correspond to the basic ascii sets of iso 646 and iso 6937"
# Version 4 of edifact should extend this to unicode
my %encoding_map = (
    'UNOA' => 'ascii',
    'UNOB' => 'ascii',
    'UNOC' => 'iso-8859-1',
    'UNOD' => 'iso-8859-2',
    'UNOE' => 'iso-8859-5',
    'UNOF' => 'iso-8859-7',
);

=head1 SYNOPSIS

This is a support module for EDI ordering modules being developed for the
Koha and Evergreen OS Library Management Systems

    use Business::Edifact::Interchange;

    my $foo = Business::Edifact::Interchange->new();
    $foo->parse($edifact_message);
    or
    $foo->parse_file($filename);
    ...

The standards for using Edifact in Library Book Supply are available from

    www.editeur.org


=head1 SUBROUTINES/METHODS

=head2 new

Create an Business::Edifact::Interchange object

=cut

sub new {
    my $class       = shift;
    my $print_trace = shift;

    my $self = {};

    bless $self, $class;
    return $self;
}

=head2 parse

parse the edifact interchange passed in the message

=cut

sub parse {
    my $self = shift;
    my $doc  = shift;
    $self->{separator} = {
        component => q{\:},
        data      => q{\+},
        decimal   => q{.},
        release   => q{\?},
        reserved  => q{ },
        segment   => q{\'},
    };
    $self->{sep_class} = '\:\+\'\?';
    if ( $doc =~ s/^UNA// ) {    # optional
        my $element = substr $doc, 0, 6, q{};
        $self->read_service_string_advice($element);
    }
    my @segments =
      split /(?{separator}->{release})$self->{separator}->{segment} */,
      $doc;
    $self->{interchange} = [];
    $self->{messages}    = [];
    $self->{msg_cnt}     = 0;
    if ( $segments[0] =~ m/^UNB/ ) {

        my $hdr = shift @segments;
        my @hdr_fields =
          split /(?{separator}->{release})$self->{separator}->{data}/,
          $hdr;
        push @{ $self->{interchange} },
          $self->interchange_header( @hdr_fields[ 1 .. $#hdr_fields ] );
    }
    else {
        croak 'Interchange does not begin with an Interchange header';
    }
    my $current_msg;
    while ( my $segment = shift @segments ) {
        my ( $tag, @data ) =
          split /(?{separator}->{release})$self->{separator}->{data}/,
          $segment;
        if ( $tag =~ /UNH/ ) {
            $current_msg = $self->message_header(@data);
            next;
        }
        if ( $tag =~ /UNT/ ) {
            $self->message_trailer( $current_msg, @data );
            $current_msg = undef;
            next;
        }
        if ( $tag =~ /^UNZ/ ) {
            $self->interchange_trailer(@data);
            next;
        }
        if ( $tag =~ /^UNG/ ) {
            $self->message_group_header(@data);
            next;
        }
        if ( $tag =~ /^UNE/ ) {
            $self->message_group_trailer(@data);
            next;
        }

        $self->user_data_segment( $current_msg, $tag, @data );
    }
    return;
}

=head2 parse_file

Reads an edifact message from a file and parses it
Will strip the lineendings added to files by some suppliers

=cut

sub parse_file {
    my $self     = shift;
    my $filename = shift;
    $filename ||= 'SampleQuote3.txt';

    open my $fh, '<', $filename or croak "Cannot open $filename : $!";
    my @lines = <$fh>;
    close $fh;

    for (@lines) {
        chomp;
        s/\r$//;
    }
    my $msg;
    if ( @lines == 1 ) {
        $msg = $lines[0];
    }
    elsif ( @lines > 1 ) {
        $msg = join q{}, @lines;
    }
    if ($msg) {
        $self->parse($msg);
    }
    return;
}

=head2 user_data_segment

internal method for handling message data segments
pass to the current Business::Edifact::Message object for fuller passing

=cut

sub user_data_segment {
    my ( $self, $msg, $tag, @data ) = @_;

    my $d = $self->split_components(@data);

    # un release data
    $msg->add_segment( $tag, $d );

    return;
}

=head2 message_header

create a new Business::Edifact::Message object

=cut

sub message_header {
    my ( $self, @data ) = @_;

    my $msg = Business::Edifact::Message->new( $self->split_components(@data) );

    return $msg;
}

=head2 message_trailer

End message add completed message to my messages array

=cut

sub message_trailer {
    my ( $self, $msg, @data ) = @_;

    $self->{msg_cnt}++;
    push @{ $self->{messages} }, $msg;
    return;
}

=head2 interchange_trailer

internal method to parse and validate the
interchange trailer

=cut

sub interchange_trailer {
    my ( $self, @data ) = @_;

    if ( $data[0] != $self->{msg_cnt} ) {
        carp "Message count error trailer says $data[0] I counted "
          . $self->{msg_cnt};
    }
    if ( $data[1] ne $self->{control_ref} ) {

        carp 'Error mismatched control refs Header:'
          . $self->{control_ref}
          . ' Trailer:'
          . $data[1];
    }

    return;
}

=head2 read_service_string_advice

internal method to parse the service string advice
and set the separator values for the interchange
accordingly

=cut

sub read_service_string_advice {
    my $self = shift;
    my $ssa  = shift;

    # The six characters represent
    # component data element separator :
    # Data element sep                 +
    # Decimal notation                 .
    # Release Indicator                ?
    # Reseved (space)
    # Segment terminator               '
    if ( $ssa eq q{:+.? '} ) {

        # 'Standard Service String Advice';
        return;
    }
    else {

        #'Non standard Service String Advice';
        my @char = unpack 'C6', $ssa;
        foreach (@char) {
            $_ = quotemeta $_;
        }
        $self->{separator} = {
            component => $char[0],
            data      => $char[1],
            decimal   => $char[2],
            release   => $char[3],
            reserved  => $char[4],
            segment   => $char[5],
        };
        $self->{sep_class} = join q{}, $char[0], $char[1], $char[3], $char[5];
    }
    return;
}

=head2 split_components

internal method to split data field into components

=cut

sub split_components {
    my ( $self, @data ) = @_;
    my $d_arr = [];
    for my $data_field (@data) {
        my @components =
          split
          /(?{separator}->{release})$self->{separator}->{component}/,
          $data_field;
        foreach (@components) {
            s/$self->{separator}->{release}([$self->{sep_class}])/$1/g;

            # convert data to utf-8
            $_ = $self->{enc}->decode($_);
        }
        push @{$d_arr}, \@components;
    }
    return $d_arr;
}

=head2 interchange_header

Internal method to parse the interchange header

=cut

sub interchange_header {
    my ( $self, @hdr ) = @_;
    $self->{control_ref} = $hdr[4];
    my $charencoding = 'iso-8859-1';
    my $syntax_id = substr $hdr[0], 0, 4;
    if ( exists $encoding_map{$syntax_id} ) {
        $charencoding = $encoding_map{$syntax_id};
    }
    $self->{enc} = find_encoding($charencoding);
    croak qq(encoding "$charencoding" not found) unless ref $self->{enc};
    my $interchange_header = $self->split_components(@hdr);

    # syntax identifier :: Syntax_id a4 'UNO'[ABC]:Syntax_version
    # interchange_sender :: Sender_id:id_code_qualifier[:Address]
    # interchange_recipient :: Recepient_id:code_qualifier[:Address]
    # DateTime of Prep : YYMMDD:HHMM
    # Interchange Control Ref
    # Password
    # Application Ref
    # [Priority Code]
    # [Ack Request]
    # [Comm Agreement ID]
    # [Test Indicator [ 1 == a test]]
    return $interchange_header;
}

=head2 message_group_header

internal method to parse the message group header
(Currently a nop )

=cut

sub message_group_header {
    my ( $self, @data ) = @_;

    #TBD parse data
    #say 'message_group_header';

    return;
}

=head2 message_group_trailer

internal method to parse the message group trailer
(Currently a nop )

=cut

sub message_group_trailer {
    my ( $self, @data ) = @_;

    #TBD parse data
    #say 'message_group_trailer';

    return;
}

=head2 messages

Returns and array_ref of Edifact::Message objects representing
the contents of the interchange

=cut

sub messages {
    my $self = shift;
    if ( exists $self->{messages} ) {
        return $self->{messages};
    }
    return;
}

=head1 WARNINGS

At present this is tested for quotes. Beware suppliers' interpretation of the
Edifact Standard can vary considerably. (And the standard is large enough to
allow considerable leeway on this). Its intended to expand this module based on
practical experience.

=head1 AUTHOR

Colin Campbell, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Business::Edifact::Interchange


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2011-2014 Colin Campbell.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1;    # End of Business::Edifact::Interchange