package Convert::IBM390;

use Carp;
use POSIX qw(mktime);
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(asc2eb eb2asc eb2ascp packeb unpackeb hexdump
  packed2num num2packed zoned2num num2zoned fcs_xlate
  set_codepage set_translation);
$VERSION = '0.27';

%EXPORT_TAGS = ( all => [ @EXPORT_OK ] );

# $warninv = issue warning message if a field is invalid.  Default
# is FALSE (don't issue the message).  Used by packed2num, num2packed,
# zoned2num, num2zoned.
$Convert::IBM390::warninv = 0;

my ($a2e_table, $e2a_table, $e2ap_table);
$a2e_table = pack "H512",
 "00010203372d2e2f1605150b0c0d0e0f101112133c3d322618193f271c1d1e1f".
 "405a7f7b5b6c507d4d5d5c4e6b604b61f0f1f2f3f4f5f6f7f8f97a5e4c7e6e6f".
 "7cc1c2c3c4c5c6c7c8c9d1d2d3d4d5d6d7d8d9e2e3e4e5e6e7e8e9ade0bd5f6d".
 "79818283848586878889919293949596979899a2a3a4a5a6a7a8a9c04fd0a107".
 "202122232425061728292a2b2c090a1b30311a333435360838393a3b04143eff".
 "41aa4ab19fb26ab5bbb49a8ab0caafbc908feafabea0b6b39dda9b8bb7b8b9ab".
 "6465626663679e687471727378757677ac69edeeebefecbf80fdfefbfcbaae59".
 "4445424643479c4854515253585556578c49cdcecbcfcce170dddedbdc8d8edf";

$e2a_table = pack "H512",
 "000102039c09867f978d8e0b0c0d0e0f101112139d0a08871819928f1c1d1e1f".
 "808182838485171b88898a8b8c050607909116939495960498999a9b14159e1a".
 "20a0e2e4e0e1e3e5e7f1a22e3c282b7c26e9eaebe8edeeefecdf21242a293b5e".
 "2d2fc2c4c0c1c3c5c7d1a62c255f3e3ff8c9cacbc8cdcecfcc603a2340273d22".
 "d8616263646566676869abbbf0fdfeb1b06a6b6c6d6e6f707172aabae6b8c6a4".
 "b57e737475767778797aa1bfd05bdeaeaca3a5b7a9a7b6bcbdbedda8af5db4d7".
 "7b414243444546474849adf4f6f2f3f57d4a4b4c4d4e4f505152b9fbfcf9faff".
 "5cf7535455565758595ab2d4d6d2d3d530313233343536373839b3dbdcd9da9f";

$e2ap_table =
  ' ' x 64 .
  '           .<(+|&         !$*); -/         ,%_>?         `:#@\'="'.
  ' abcdefghi       jklmnopqr       ~stuvwxyz   [               ]  '.
  '{ABCDEFGHI      }JKLMNOPQR      \\ STUVWXYZ      0123456789      ';

# Days Before This Month, Leap and Common years
my @dbtm_com =
  ( 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 );
my @dbtm_leap =
  ( 0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335 );

# ASCII to EBCDIC
sub asc2eb {
 my $String = shift;
 return "" if $String eq "";
 return fcs_xlate($String, $a2e_table);
}

# EBCDIC to ASCII
sub eb2asc {
 my $String = shift;
 return "" if $String eq "";
 return fcs_xlate($String, $e2a_table);
}

# EBCDIC to ASCII printable
sub eb2ascp {
 my $String = shift;
 return "" if $String eq "";
 return fcs_xlate($String, $e2ap_table);
}

# Pack a Perl list into an EBCDIC record (structure).
sub packeb {
 my ($template, @inlist) = @_;
 my ($datumtype, $len, $star, $ndec, $item, $ebstring, $padl);

 my $espace = "\x40";  # EBCDIC space
 my $nspace = ' ';     # Native space
 my $ii = 0;
 my $tp = 0;  # Template position -- where are we in the template?
 my $result = "";

 while ($tp < length($template)) {
# Have we gone past the end of the list of values?  If so, stop.
    last if $ii >= @inlist;

    $star = ' ';  # '*' if a star is found, blank otherwise
    $datumtype = substr($template, $tp, 1);
    $tp++;
    next if $datumtype =~ /\s/;
    if (substr($template, $tp, 1) eq '*') {
       $star = '*';
       $len = ($datumtype =~ /[pz]/) ? 8 :
         ($datumtype =~ /[x\@]/) ? 0 : @inlist - $ii;
       $tp++;
    } elsif (substr($template, $tp, 1) =~ /\d/) {
       substr($template, $tp) =~ m/^(\d+)/;
       $len = $1;  $tp += length($len);
# Decimal places (this result will be ignored if the datumtype
# is not packed or zoned).
       $ndec = 0;
       if (substr($template, $tp, 1) eq '.') {
          $tp++;
          substr($template, $tp) =~ m/^(\d+)/;
          $ndec = $1;  $tp += length($ndec);
       }
    } else {
       $len = ($datumtype =~ /[pz]/) ? 8 : 1;
    }

    if ($len > 32767) {
      Carp::croak("Field length too large in packeb: $datumtype$len");
    }
    $_ = $datumtype;
    DSWITCH: {
     if (/\@/) {  # Here $len is really an offset.
        my $Lr = length($result);
        if ($len > $Lr) {	# Grow
           $result .= "\x00" x ($len - $Lr);
        } elsif ($len < $Lr) {	# Shrink
           $result = substr($result, 0, $len);
        } else { ; }
        last DSWITCH;
     }
     if (/x/) {
        $result .= "\x00" x $len;
        last DSWITCH;
     }
     # [Ee]:  EBCDIC character string
     if (/[Ee]/) {
        $item = $inlist[$ii];  $ii++;
        $len = length($item) if $star eq '*';
        $ebstring = asc2eb($item);
        $padl = $len - length($ebstring);
        if ($padl == 0) { ; }
        elsif ($padl < 0) {
           $ebstring = substr($ebstring, 0, $len);
        } else {
           if ($datumtype eq 'E') {  # Pad with EBCDIC spaces
              $ebstring .= $espace x $padl;
           } else {
              $ebstring .= "\x00" x $padl;
           }
        }
        $result .= $ebstring;
        last DSWITCH;
     }
     # [Cc]: characters without translation.  Same as Perl's [Aa].
     if (/[Cc]/) {
        $item = $inlist[$ii];  $ii++;
        $len = length($item) if $star eq '*';
        if ($datumtype eq 'C') {
           $result .= pack("A$len", $item);
        } else {
           $result .= pack("a$len", $item);
        }
        last DSWITCH;
     }

     # [pP]: S/390 packed decimal.  $len is a field length.
     if (/[pP]/) {
        Carp::croak("Field length too large in packeb: $datumtype$len")
            if $len > 16;
        $item = $inlist[$ii];  $ii++;
        $result .= num2packed($item, $len, $ndec, $datumtype eq 'P');
        last DSWITCH;
     }

     # i: S/390 fullword (signed). */
     if (/i/) {
        for (my $j = 0; $j < $len; $j++) {
           $item = $inlist[$ii];  $ii++;
           $result .= pack("N", $item);
        }
        last DSWITCH;
     }
     # s: S/390 halfword (signed). */
     if (/s/) {
        for (my $j = 0; $j < $len; $j++) {
           $item = $inlist[$ii];  $ii++;
           $result .= pack("n", $item);
        }
        last DSWITCH;
     }
     # S: S/390 halfword (unsigned). */
     if (/S/) {
        for (my $j = 0; $j < $len; $j++) {
           $item = $inlist[$ii];  $ii++;
           $result .= substr(pack("N", $item), 2,2);
        }
        last DSWITCH;
     }

     # [zZ]: S/390 zoned decimal.  $len is a field length.
     if (/[zZ]/) {
        Carp::croak("Field length too large in packeb: z$len") if $len > 32;
        $item = $inlist[$ii];  $ii++;
        $result .= num2zoned($item, $len, $ndec, $datumtype eq 'Z');
        last DSWITCH;
     }
     # [Hh]: hex, high-order nybble always first
     if (/[Hh]/) {
        $item = $inlist[$ii];  $ii++;
        $len = length($item) if $star eq '*';
        $result .= pack("H$len", $item);
        last DSWITCH;
     }

     Carp::croak("Invalid type in packeb: '$datumtype'");
    }
 }
 return $result;
}

# Unpack an EBCDIC record into a Perl list.
sub unpackeb {
 my ($template, $ebrecord) = @_;
 my ($datumtype, $len, $ndec, $brem);

 my $s = 0;   # Points to current position within $ebrecord
 my $tp = 0;  # Template position -- where are we in the template?
 my @rlist = ();	# Result list

 while ($tp < length($template)) {
    $datumtype = substr($template, $tp, 1);
    $tp++;
# Have we gone past the end of the input?  If so, stop, unless they
# want to reposition within the record.
    last if $s >= length($ebrecord) && $datumtype ne '@';

    next if $datumtype =~ /\s/;
    $ndec = 0;
    if (substr($template, $tp, 1) eq '*') {
       $len = length($ebrecord) - $s;
       $len = int($len / 4)  if $datumtype =~ /[iI]/;
       $len = int($len / 2)  if $datumtype =~ /[sS]/;
       $tp++;
    } elsif (substr($template, $tp, 1) =~ /\d/) {
       substr($template, $tp) =~ m/^(\d+)/;
       $len = $1;  $tp += length($len);
# Decimal places (this result will be ignored if the datumtype
# is not packed or zoned).
       $ndec = 0;
       if (substr($template, $tp, 1) eq '.') {
          $tp++;
          substr($template, $tp) =~ m/^(\d+)/;
          $ndec = $1;  $tp += length($ndec);
       }
    } else {
       $len = 1;
    }
    if ($len > 32767) {
       Carp::croak("Field length too large in unpackeb: $datumtype$len");
    }

    $_ = $datumtype;
    $brem = length($ebrecord) - $s;  # Bytes REMaining
    DSWITCH: {
     # @: absolute offset
     if (/\@/) {
        if ($len >= length($ebrecord) || $len < 0) {
           Carp::croak("Absolute position is outside string: \@$len");
        }
        $s = $len;
        last DSWITCH;
     }

     # [Ee]:  EBCDIC character string.  $len is a field length.
     if (/[Ee]/) {
        $len = $brem  if $len > $brem;
        $a = eb2asc(substr($ebrecord, $s, $len));
        $a =~ s/[\0 ]+$//  if $datumtype eq 'E';
        push @rlist, $a;
        $s += $len;
        last DSWITCH;
     }

     # p: S/390 packed decimal.  $len is a field length.
     if (/p/) {
        $len = $brem  if $len > $brem;
        if ($len > 16) {
           Carp::croak("Field length too large in unpackeb: p$len");
        }
        push @rlist, packed2num(substr($ebrecord, $s, $len), $ndec);
        $s += $len;
        last DSWITCH;
     }
     # z: S/390 zoned decimal.  $len is a field length.
     if (/z/) {
        $len = $brem  if $len > $brem;
        if ($len > 32) {
           Carp::croak("Field length too large in unpackeb: z$len");
        }
        push @rlist, zoned2num(substr($ebrecord, $s, $len), $ndec);
        $s += $len;
        last DSWITCH;
     }
     # [Cc]: characters without translation
     if (/[Cc]/) {
        $len = $brem  if $len > $brem;
        push @rlist, substr($ebrecord, $s, $len);
        $s += $len;
        last DSWITCH;
     }

     # i: signed integer (System/390 fullword)
     if (/i/) {
        $len = int($brem / 4)  if $len > int($brem / 4);
        for (my $i = 0; $i < $len; $i++) {
           my @byt = unpack('cC3', substr($ebrecord, $s, 4));
           push @rlist, (16777216 * $byt[0] + 65536 * $byt[1] +
             256 * $byt[2] + $byt[3]);
           $s += 4;
        }
        last DSWITCH;
     }
     # s: signed short integer (System/390 halfword)
     if (/s/) {
        $len = int($brem / 2)  if $len > int($brem / 2);
        for (my $i = 0; $i < $len; $i++) {
           my @byt = unpack('cC', substr($ebrecord, $s, 2));
           push @rlist, (256 * $byt[0] + $byt[1]);
           $s += 2;
        }
        last DSWITCH;
     }

     # [hH]: unpack to printable hex digits
     if (/[hH]/) {
        $len = $brem * 2  if $len > $brem * 2;
        my $bytes = int($len/2);
        push @rlist, unpack("H$len", substr($ebrecord, $s, $bytes));
        $s += $bytes;
        last DSWITCH;
     }

     # v: varchar EBCDIC character string; i.e., a string of
     # EBCDIC characters preceded by a halfword length field (as
     # in DB2/MVS, for instance).  $len here is a repeat count,
     # but don't go beyond the end of the record.
     if (/v/) {
        for (my $i=0; $i < $len; $i++) {
            last if $len > $brem;
            my @byt = unpack('cC', substr($ebrecord, $s, 2));
            my $fieldlen = 256 * $byt[0] + $byt[1];
            $s += 2;
            $brem = length($ebrecord) - $s;

            $fieldlen = $brem  if $fieldlen > $brem;
            if ($fieldlen < 0) {
               push @rlist, undef();
            } elsif ($fieldlen == 0) {
               push @rlist, "";
            } else {
               push @rlist, eb2asc(substr($ebrecord, $s, $fieldlen));
            }
            $s += $fieldlen;
            $brem = length($ebrecord) - $s;
        }
        last DSWITCH;
     }
     # x: ignore these bytes (do not return an element)
     if (/x/) {
        $len = $brem  if $len > $brem;
        $s += $len;
        last DSWITCH;
     }

     # I: unsigned integer (4 bytes).  Same as Perl's 'N'.
     if (/I/) {
        $len = int($brem / 4)  if $len > int($brem / 4);
        for (my $i = 0; $i < $len; $i++) {
           push @rlist, unpack('N', substr($ebrecord, $s, 4));
           $s += 4;
        }
        last DSWITCH;
     }
     # S: unsigned short integer (2 bytes).  Same as Perl's 'n'.
     if (/S/) {
        $len = int($brem / 2)  if $len > int($brem / 2);
        for (my $i = 0; $i < $len; $i++) {
           push @rlist, unpack('n', substr($ebrecord, $s, 2));
           $s += 2;
        }
        last DSWITCH;
     }

     Carp::croak("Invalid type in unpackeb: '$datumtype'");
    }
 }

 return (wantarray) ? @rlist : $rlist[0];
}


# Print an entire string in hexdump format, 32 bytes at a time
# (like a sysabend dump).
sub hexdump {
 my ($String, $startad, $charset) = @_;
 $startad ||= 0;
 $charset ||= "ascii";
 my ($i, $j, $d, $str, $pri, $hexes);
 my @outlines = ();
 my $L = length($String);
 for ($i = 0; $i < $L; $i += 32) {
    $str = substr($String, $i,32);
#   Generate a printable version of the string.
    if ($charset =~ m/ebc/i) {
       $pri = eb2ascp $str;
    } else {
       $pri = $str;
       $pri =~ tr/\000-\037\177-\377/ /;
    }
    $hexes = unpack("H64", $str);
    $hexes =~ tr/a-f/A-F/;
    if (($L - $i) < 32) {   # Pad with blanks if necessary.
       $pri = pack("A32", $pri);
       $hexes = pack("A64", $hexes);
    }
    $d = sprintf("%06X: ", $startad + $i);
    for ($j = 0; $j < 64; $j += 8) {
       $d .= substr($hexes, $j, 8) . " ";
       $d .= " " if $j == 24;
    }
    $d .= " *$pri*\n";
    push @outlines, $d;
 }
 return @outlines;
}

# Convert a Packed Decimal field to a Perl number.
sub packed2num {
 my ($packed, $ndec) = @_;
 $ndec ||= 0;
 my ($w, $xdigits, $arabic, $sign);
 $w = 2 * length($packed);
 $xdigits = unpack("H$w", $packed);
 $arabic = substr($xdigits, 0, $w-1);
 $sign = substr($xdigits, $w-1, 1);
 if ( $arabic !~ /^\d+$/ || $sign !~ /^[a-f]$/ ) {
    Carp::carp "packed2num: Invalid packed value $xdigits"
      if $Convert::IBM390::warninv;
    return undef();
 }
 $arabic = 0 - $arabic  if $sign =~ /[bd]/;
 $arabic /= 10 ** $ndec  if $ndec != 0;
 return $arabic + 0;
}

# Convert a Perl number to a packed field.
sub num2packed {
 my ($num, $outwidth, $ndec, $fsign) = @_;
 $outwidth ||= 8;
 $ndec ||= 0;
 if ( $num !~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ ) {
    Carp::carp "num2packed: Input is not a number"
      if $Convert::IBM390::warninv;
    return undef();
 }
 my ($outdig, $digits, $sign);
 $outdig = $outwidth * 2 - 1;
# sprintf will round to the appropriate number of places.
 $digits = sprintf("%0${outdig}.0f", abs($num * (10 ** $ndec)));
 Carp::croak("Number $num too long for packed decimal")
    if length($digits) > 31;
 $digits = substr($digits, -$outdig);
 $sign = ($num >= 0) ? (($fsign) ? "F" : "C") : "D";
 $outwidth *= 2;
 return pack("H$outwidth", $digits . $sign);
}

# Convert a Zoned Decimal field to a Perl number.
sub zoned2num {
 my ($zoned, $ndec) = @_;
 $ndec ||= 0;
 my ($w, $digits, $sign, $final);
 if ($zoned =~ m/[\xD0-\xD9]/) { $sign = -1; }
 else  { $sign = 1; }
 $zoned = eb2asc($zoned);
 $zoned =~ tr/ {ABCDEFGHI}JKLMNOPQR/001234567890123456789/;
 if ( $zoned !~ /^\d+$/ ) {
    Carp::carp "zoned2num: Invalid zoned value $zoned"
      if $Convert::IBM390::warninv;
    return undef();
 }
 $final = $sign * $zoned;
 $final /= 10 ** $ndec  if $ndec != 0;
 return $final + 0;
}

# Convert a Perl number to a zoned field.
# Last arg: use F instead of C for positives?
sub num2zoned {
 my ($num, $outwidth, $ndec, $unsigned) = @_;
 $outwidth ||= 8;
 $ndec ||= 0;
 if ( $num !~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ ) {
    Carp::carp "num2zoned: Input is not a number"
      if $Convert::IBM390::warninv;
    return undef();
 }
 my ($digits, $sign);
# sprintf will round to the appropriate number of places.
 $digits = sprintf("%0${outwidth}.0f", abs($num * (10 ** $ndec)));
 Carp::croak("Number $num too long for zoned decimal")
    if length($digits) > 31;
 $digits = substr($digits, -$outwidth);
 my $last = length($digits) - 1;
 unless ($unsigned) {
    if ($num >= 0) {
       substr($digits, $last, 1) =~ tr/0123456789/{ABCDEFGHI/;
    } else {
       substr($digits, $last, 1) =~ tr/0123456789/}JKLMNOPQR/;
    }
 }
 return asc2eb($digits);
}

# Full Collating Sequence Translate -- like tr///, but assumes that
# the searchstring is a complete 8-bit collating sequence
# (x'00' - x'FF').  I couldn't get tr to do this, and I have my
# doubts about whether it would be possible on systems where char
# is signed.  This approach works on AIX, where char is unsigned,
# and at least has a fighting chance of working elsewhere.
# The second argument is one of the translation tables defined
# above ($a2e_table, etc.).
sub fcs_xlate {
 my ($instring, $to_table) = @_;
 my ($i, $outstring);
 $outstring = "";
 for ($i = 0; $i < length($instring); $i++) {
    $outstring .= substr($to_table, ord(substr($instring, $i,1)), 1);
 }
 return $outstring;
}

sub _set_translation {
  die "Invalid tables" if @_ != 3 or grep { length($_) != 256 } @_;
  ($a2e_table, $e2a_table, $e2ap_table) = @_;
}

sub version {
 return "Convert::IBM390 version $VERSION Perl only";
}