package Koha::Edifact;

# Copyright 2014,2015 PTFS-Europe Ltd
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# Koha is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <https://www.gnu.org/licenses>.

use strict;
use warnings;
use File::Slurp qw( read_file );
use Carp        qw( carp croak );
use JSON        qw( encode_json );
use Koha::Edifact::Segment;
use Koha::Edifact::Message;

my $separator = {
    component => q{\:},
    data      => q{\+},
    decimal   => q{.},
    release   => q{\?},
    reserved  => q{ },
    segment   => q{\'},
};

sub new {
    my ( $class, $param_hashref ) = @_;
    my $transmission;
    my $self = {};

    if ( $param_hashref->{filename} ) {
        if ( $param_hashref->{transmission} ) {
            carp "Cannot instantiate $class : both filename and transmission passed";
            return;
        }
        $transmission = read_file( $param_hashref->{filename} );
    } else {
        $transmission = $param_hashref->{transmission};
    }
    $self->{transmission} = _init($transmission);

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

sub interchange_header {
    my ( $self, $field ) = @_;

    my %element = (
        sender                        => 1,
        recipient                     => 2,
        datetime                      => 3,
        interchange_control_reference => 4,
        application_reference         => 6,
    );
    if ( !exists $element{$field} ) {
        carp "No interchange header field $field available";
        return;
    }
    my $data = $self->{transmission}->[0]->elem( $element{$field} );
    return $data;
}

sub interchange_trailer {
    my ( $self, $field ) = @_;
    my $trailer = $self->{transmission}->[-1];
    if ( $field eq 'interchange_control_count' ) {
        return $trailer->elem(0);
    } elsif ( $field eq 'interchange_control_reference' ) {
        return $trailer->elem(1);
    }
    carp "Trailer field $field not recognized";
    return;
}

sub new_data_iterator {
    my $self   = shift;
    my $offset = 0;
    while ( $self->{transmission}->[$offset]->tag() ne 'UNH' ) {
        ++$offset;
        if ( $offset == @{ $self->{transmission} } ) {
            carp 'Cannot find message start';
            return;
        }
    }
    $self->{data_iterator} = $offset;
    return 1;
}

sub next_segment {
    my $self = shift;
    if ( defined $self->{data_iterator} ) {
        my $seg = $self->{transmission}->[ $self->{data_iterator} ];
        if ( $seg->tag eq 'UNH' ) {

            $self->{msg_type} = $seg->elem( 1, 0 );
        } elsif ( $seg->tag eq 'LIN' ) {
            $self->{msg_type} = 'detail';
        }

        if ( $seg->tag ne 'UNZ' ) {
            $self->{data_iterator}++;
        } else {
            $self->{data_iterator} = undef;
        }
        return $seg;
    }
    return;
}

# for debugging return whole transmission
sub get_transmission {
    my $self = shift;

    return $self->{transmission};
}

sub message_type {
    my $self = shift;
    return $self->{msg_type};
}

sub _init {
    my $msg = shift;
    if ( !$msg ) {
        return;
    }
    if ( $msg =~ s/^UNA(.{6})// ) {
        if ( service_string_advice($1) ) {
            return segmentize($msg);

        }
        return;
    } else {
        my $s = substr $msg, 10;
        croak "File does not start with a Service string advice :$s";
    }
}

# return an array of Message objects
sub message_array {
    my $self = shift;

    # return an array of array_refs 1 ref to a message
    my $msg_arr = [];
    my $msg     = [];
    my $in_msg  = 0;
    foreach my $seg ( @{ $self->{transmission} } ) {
        if ( $seg->tag eq 'UNH' ) {
            $in_msg = 1;
            push @{$msg}, $seg;
        } elsif ( $seg->tag eq 'UNT' ) {
            $in_msg = 0;
            if ( @{$msg} ) {
                push @{$msg_arr}, Koha::Edifact::Message->new($msg);
                $msg = [];
            }
        } elsif ($in_msg) {
            push @{$msg}, $seg;
        }
    }
    return $msg_arr;
}

sub to_json {
    my $self = shift;

    # Find interchange header (UNB)
    my $header_seg;
    my $trailer_seg;
    my @all_segments = @{ $self->{transmission} };

    # Get header and trailer
    for my $i ( 0 .. $#all_segments ) {
        if ( $all_segments[$i]->tag eq 'UNB' ) {
            $header_seg = $all_segments[$i];
        } elsif ( $all_segments[$i]->tag eq 'UNZ' ) {
            $trailer_seg = $all_segments[$i];
        }
    }

    # Build messages array
    my @json_messages;
    my $current_message;
    my @current_segments;
    my $current_line_id;

    for my $segment (@all_segments) {
        my $tag = $segment->tag;

        if ( $tag eq 'UNH' ) {

            # Start new message
            if ($current_message) {
                $current_message->{segments} = [@current_segments];
                push @json_messages, $current_message;
            }
            $current_message = {
                header   => $segment->as_string,
                segments => [],
            };
            @current_segments = ();
            $current_line_id  = undef;
        } elsif ( $tag eq 'UNT' ) {

            # End current message
            if ($current_message) {
                $current_message->{trailer}  = $segment->as_string;
                $current_message->{segments} = [@current_segments];
                push @json_messages, $current_message;
            }
            $current_message  = undef;
            @current_segments = ();
            $current_line_id  = undef;
        } elsif ( $tag eq 'UNB' || $tag eq 'UNZ' ) {

            # Skip - these are handled separately
            next;
        } elsif ($current_message) {

            # Process segment within message
            my $segment_data = {
                tag      => $tag,
                raw      => $segment->as_string,
                elements => [],
            };

            # Extract elements
            my $elem_count = 0;
            while ( defined( my $elem = $segment->elem($elem_count) ) ) {
                push @{ $segment_data->{elements} }, $elem;
                $elem_count++;
            }

            # Handle line_id assignment
            if ( $tag eq 'LIN' ) {
                $current_line_id = $segment->elem(0);
                $segment_data->{line_id} = $current_line_id if defined $current_line_id;
            } elsif ( $tag eq 'UNS' ) {

                # UNS (Section Control) marks transition to message summary
                # Reset line_id so subsequent segments are treated as message-level
                $current_line_id = undef;
            } elsif ( defined $current_line_id && $tag !~ /^(UNH|UNT|UNS|CNT)$/ ) {

                # Assign line_id to segments that belong to current line item
                # Exclude message control segments (UNH, UNT, UNS, CNT)
                # After UNS, current_line_id is undefined, so segments are message-level
                $segment_data->{line_id} = $current_line_id;
            }

            push @current_segments, $segment_data;
        }
    }

    # Handle any remaining message
    if ($current_message) {
        $current_message->{segments} = [@current_segments];
        push @json_messages, $current_message;
    }

    # Build final structure
    my $json_structure = {
        header   => $header_seg ? $header_seg->as_string : undef,
        messages => \@json_messages,
        trailer  => $trailer_seg ? $trailer_seg->as_string : undef,
    };

    return encode_json($json_structure);
}

#
# internal parsing routines used in _init
#
sub service_string_advice {
    my $ssa = shift;

    # At present this just validates that the ssa
    # is standard Edifact
    # TBD reset the seps if non standard
    if ( $ssa ne q{:+.? '} ) {
        carp " Non standard Service String Advice [$ssa]";
        return;
    }

    # else use default separators
    return 1;
}

sub segmentize {
    my $raw = shift;

    # In practice edifact uses latin-1 but check
    # Transport now converts to utf-8 on ingest
    # Do not convert here
    #my $char_set = 'iso-8859-1';
    #if ( $raw =~ m/^UNB[+]UNO(.)/ ) {
    #    $char_set = msgcharset($1);
    #}
    #from_to( $raw, $char_set, 'utf8' );

    my $re = qr{
(?>         # dont backtrack into this group
    [?].     # either the escape character
            # followed by any other character
     |      # or
     [^'?]   # a character that is neither escape
             # nor split
             )+
}x;
    my @segmented;
    while ( $raw =~ /($re)/g ) {
        push @segmented, Koha::Edifact::Segment->new( { seg_string => $1 } );
    }
    return \@segmented;
}

sub msgcharset {
    my $code = shift;
    if ( $code =~ m/^[^ABCDEF]$/ ) {
        $code = 'default';
    }
    my %encoding_map = (
        A       => 'ascii',
        B       => 'ascii',
        C       => 'iso-8859-1',
        D       => 'iso-8859-1',
        E       => 'iso-8859-1',
        F       => 'iso-8859-1',
        default => 'iso-8859-1',
    );
    return $encoding_map{$code};
}

1;
__END__

=head1 NAME

Edifact - Edifact message handler

=head1 DESCRIPTION

   Koha module for parsing Edifact messages

=head1 SUBROUTINES

=head2 new

     my $e = Koha::Edifact->new( { filename => 'myfilename' } );
     or
     my $e = Koha::Edifact->new( { transmission => $msg_variable } );

     instantiate the Edifact parser, requires either to be passed an in-memory
     edifact message as transmission or a filename which it will read on creation

=head2 interchange_header

     will return the data in the header field designated by the parameter
     specified. Valid parameters are: 'sender', 'recipient', 'datetime',
    'interchange_control_reference', and 'application_reference'

=head2 interchange_trailer

     called either with the string 'interchange_control_count' or
     'interchange_control_reference' will return the corresponding field from
     the interchange trailer

=head2 new_data_iterator

     Sets the object's data_iterator to point to the UNH segment

=head2 next_segment

     Returns the next segment pointed to by the data_iterator. Increments the
     data_iterator member or destroys it if segment UNZ has been reached

=head2 get_transmission

     This method is useful in debugging. Call on an Edifact object
     it returns the object's transmission member

=head2 message_type

     return the object's message type

=head2 message_array

     return an array of Message objects contained in the Edifact transmission

=head2 to_json

     returns a JSON representation of the complete edifact interchange.
     The JSON structure includes the interchange header, all messages with their
     segments (both raw and parsed), and the interchange trailer.
     Line items are grouped using line_id extracted from LIN segments.

=head1 Internal Methods

=head2 _init

  Called by the constructor to do the parsing of the transmission

=head2 service_string_advice

  Examines the Service String Advice returns 1 if the default separators are in use
  undef otherwise

=head2 segmentize

   takes a raw Edifact message and returns a reference to an array of
   its segments

=head2 msgcharset

    Return the character set the message was encoded in. The default is iso-8859-1

    We preserve this info but will have converted to utf-8 on ingest

=head1 AUTHOR

   Colin Campbell <colin.campbell@ptfs-europe.com>


=head1 COPYRIGHT

   Copyright 2014,2015, PTFS-Europe Ltd
   This program is free software, You may redistribute it under
   under the terms of the GNU General Public License


=cut