Koha/Edifact.pm

   1 package Koha::Edifact;
   2
   3 # Copyright 2014,2015 PTFS-Europe Ltd
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use strict;
  21 use warnings;
  22 use File::Slurp qw( read_file );
  23 use Carp qw( carp croak );
  24 use Koha::Edifact::Segment;
  25 use Koha::Edifact::Message;
  26
  27 my $separator = {
  28     component => q{\:},
  29     data      => q{\+},
  30     decimal   => q{.},
  31     release   => q{\?},
  32     reserved  => q{ },
  33     segment   => q{\'},
  34 };
  35
  36 sub new {
  37     my ( $class, $param_hashref ) = @_;
  38     my $transmission;
  39     my $self = ();
  40
  41     if ( $param_hashref->{filename} ) {
  42         if ( $param_hashref->{transmission} ) {
  43             carp
  44 "Cannot instantiate $class : both filename and transmission passed";
  45             return;
  46         }
  47         $transmission = read_file( $param_hashref->{filename} );
  48     }
  49     else {
  50         $transmission = $param_hashref->{transmission};
  51     }
  52     $self->{transmission} = _init($transmission);
  53
  54     bless $self, $class;
  55     return $self;
  56 }
  57
  58 sub interchange_header {
  59     my ( $self, $field ) = @_;
  60
  61     my %element = (
  62         sender                        => 1,
  63         recipient                     => 2,
  64         datetime                      => 3,
  65         interchange_control_reference => 4,
  66         application_reference         => 6,
  67     );
  68     if ( !exists $element{$field} ) {
  69         carp "No interchange header field $field available";
  70         return;
  71     }
  72     my $data = $self->{transmission}->[0]->elem( $element{$field} );
  73     return $data;
  74 }
  75
  76 sub interchange_trailer {
  77     my ( $self, $field ) = @_;
  78     my $trailer = $self->{transmission}->[-1];
  79     if ( $field eq 'interchange_control_count' ) {
  80         return $trailer->elem(0);
  81     }
  82     elsif ( $field eq 'interchange_control_reference' ) {
  83         return $trailer->elem(1);
  84     }
  85     carp "Trailer field $field not recognized";
  86     return;
  87 }
  88
  89 sub new_data_iterator {
  90     my $self   = shift;
  91     my $offset = 0;
  92     while ( $self->{transmission}->[$offset]->tag() ne 'UNH' ) {
  93         ++$offset;
  94         if ( $offset == @{ $self->{transmission} } ) {
  95             carp 'Cannot find message start';
  96             return;
  97         }
  98     }
  99     $self->{data_iterator} = $offset;
 100     return 1;
 101 }
 102
 103 sub next_segment {
 104     my $self = shift;
 105     if ( defined $self->{data_iterator} ) {
 106         my $seg = $self->{transmission}->[ $self->{data_iterator} ];
 107         if ( $seg->tag eq 'UNH' ) {
 108
 109             $self->{msg_type} = $seg->elem( 1, 0 );
 110         }
 111         elsif ( $seg->tag eq 'LIN' ) {
 112             $self->{msg_type} = 'detail';
 113         }
 114
 115         if ( $seg->tag ne 'UNZ' ) {
 116             $self->{data_iterator}++;
 117         }
 118         else {
 119             $self->{data_iterator} = undef;
 120         }
 121         return $seg;
 122     }
 123     return;
 124 }
 125
 126 # for debugging return whole transmission
 127 sub get_transmission {
 128     my $self = shift;
 129
 130     return $self->{transmission};
 131 }
 132
 133 sub message_type {
 134     my $self = shift;
 135     return $self->{msg_type};
 136 }
 137
 138 sub _init {
 139     my $msg = shift;
 140     if ( !$msg ) {
 141         return;
 142     }
 143     if ( $msg =~ s/^UNA(.{6})// ) {
 144         if ( service_string_advice($1) ) {
 145             return segmentize($msg);
 146
 147         }
 148         return;
 149     }
 150     else {
 151         my $s = substr $msg, 10;
 152         croak "File does not start with a Service string advice :$s";
 153     }
 154 }
 155
 156 # return an array of Message objects
 157 sub message_array {
 158     my $self = shift;
 159
 160     # return an array of array_refs 1 ref to a message
 161     my $msg_arr = [];
 162     my $msg     = [];
 163     my $in_msg  = 0;
 164     foreach my $seg ( @{ $self->{transmission} } ) {
 165         if ( $seg->tag eq 'UNH' ) {
 166             $in_msg = 1;
 167             push @{$msg}, $seg;
 168         }
 169         elsif ( $seg->tag eq 'UNT' ) {
 170             $in_msg = 0;
 171             if ( @{$msg} ) {
 172                 push @{$msg_arr}, Koha::Edifact::Message->new($msg);
 173                 $msg = [];
 174             }
 175         }
 176         elsif ($in_msg) {
 177             push @{$msg}, $seg;
 178         }
 179     }
 180     return $msg_arr;
 181 }
 182
 183 #
 184 # internal parsing routines used in _init
 185 #
 186 sub service_string_advice {
 187     my $ssa = shift;
 188
 189     # At present this just validates that the ssa
 190     # is standard Edifact
 191     # TBD reset the seps if non standard
 192     if ( $ssa ne q{:+.? '} ) {
 193         carp " Non standard Service String Advice [$ssa]";
 194         return;
 195     }
 196
 197     # else use default separators
 198     return 1;
 199 }
 200
 201 sub segmentize {
 202     my $raw = shift;
 203
 204     # In practice edifact uses latin-1 but check
 205     # Transport now converts to utf-8 on ingest
 206     # Do not convert here
 207     #my $char_set = 'iso-8859-1';
 208     #if ( $raw =~ m/^UNB[+]UNO(.)/ ) {
 209     #    $char_set = msgcharset($1);
 210     #}
 211     #from_to( $raw, $char_set, 'utf8' );
 212
 213     my $re = qr{
 214 (?>         # dont backtrack into this group
 215     [?].     # either the escape character
 216             # followed by any other character
 217      |      # or
 218      [^'?]   # a character that is neither escape
 219              # nor split
 220              )+
 221 }x;
 222     my @segmented;
 223     while ( $raw =~ /($re)/g ) {
 224         push @segmented, Koha::Edifact::Segment->new( { seg_string => $1 } );
 225     }
 226     return \@segmented;
 227 }
 228
 229 sub msgcharset {
 230     my $code = shift;
 231     if ( $code =~ m/^[^ABCDEF]$/ ) {
 232         $code = 'default';
 233     }
 234     my %encoding_map = (
 235         A       => 'ascii',
 236         B       => 'ascii',
 237         C       => 'iso-8859-1',
 238         D       => 'iso-8859-1',
 239         E       => 'iso-8859-1',
 240         F       => 'iso-8859-1',
 241         default => 'iso-8859-1',
 242     );
 243     return $encoding_map{$code};
 244 }
 245
 246 1;
 247 __END__
 248
 249 =head1 NAME
 250
 251 Edifact - Edifact message handler
 252
 253 =head1 DESCRIPTION
 254
 255    Koha module for parsing Edifact messages
 256
 257 =head1 SUBROUTINES
 258
 259 =head2 new
 260
 261      my $e = Koha::Edifact->new( { filename => 'myfilename' } );
 262      or
 263      my $e = Koha::Edifact->new( { transmission => $msg_variable } );
 264
 265      instantiate the Edifact parser, requires either to be passed an in-memory
 266      edifact message as transmission or a filename which it will read on creation
 267
 268 =head2 interchange_header
 269
 270      will return the data in the header field designated by the parameter
 271      specified. Valid parameters are: 'sender', 'recipient', 'datetime',
 272     'interchange_control_reference', and 'application_reference'
 273
 274 =head2 interchange_trailer
 275
 276      called either with the string 'interchange_control_count' or
 277      'interchange_control_reference' will return the corresponding field from
 278      the interchange trailer
 279
 280 =head2 new_data_iterator
 281
 282      Sets the object's data_iterator to point to the UNH segment
 283
 284 =head2 next_segment
 285
 286      Returns the next segment pointed to by the data_iterator. Increments the
 287      data_iterator member or destroys it if segment UNZ has been reached
 288
 289 =head2 get_transmission
 290
 291      This method is useful in debugg:ing. Call on an Edifact object
 292      it returns the object's transmission member
 293
 294 =head2 message_type
 295
 296      return the object's message type
 297
 298 =head2 message_array
 299
 300      return an array of Message objects contained in the Edifact transmission
 301
 302 =head1 Internal Methods
 303
 304 =head2 _init
 305
 306   Called by the constructor to do the parsing of the transmission
 307
 308 =head2 service_string_advice
 309
 310   Examines the Service String Advice returns 1 if the default separartors are in use
 311   undef otherwise
 312
 313 =head2 segmentize
 314
 315    takes a raw Edifact message and returns a reference to an array of
 316    its segments
 317
 318 =head2 msgcharset
 319
 320     Return the character set the message was encoded in. The default is iso-8859-1
 321
 322     We preserve this info but will have converted to utf-8 on ingest
 323
 324 =head1 AUTHOR
 325
 326    Colin Campbell <colin.campbell@ptfs-europe.com>
 327
 328
 329 =head1 COPYRIGHT
 330
 331    Copyright 2014,2015, PTFS-Europe Ltd
 332    This program is free software, You may redistribute it under
 333    under the terms of the GNU General Public License
 334
 335
 336 =cut