source: trunk/essentials/dev-lang/perl/t/op/pack.t

#!./perl
# FIXME - why isn't this -w clean in maint?

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
}

# This is truth in an if statement, and could be a skip message
my $no_endianness = $] > 5.009 ? '' :
  "Endianness pack modifiers not available on this perl";
my $no_signedness = $] > 5.009 ? '' :
  "Signed/unsigned pack modifiers not available on this perl";

plan tests => 13864;

use strict;
# use warnings;
use Config;

my $Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define');
my $Perl = which_perl();
my @valid_errors = (qr/^Invalid type '\w'/);

my $ByteOrder = 'unknown';
my $maybe_not_avail = '(?:hto[bl]e|[bl]etoh)';
if ($no_endianness) {
  push @valid_errors, qr/^Invalid type '[<>]'/;
} elsif ($Config{byteorder} =~ /^1234(?:5678)?$/) {
  $ByteOrder = 'little';
  $maybe_not_avail = '(?:htobe|betoh)';
}
elsif ($Config{byteorder} =~ /^(?:8765)?4321$/) {
  $ByteOrder = 'big';
  $maybe_not_avail = '(?:htole|letoh)';
}
else {
  push @valid_errors, qr/^Can't (?:un)?pack (?:big|little)-endian .*? on this platform/;
}

if ($no_signedness) {
  push @valid_errors, qr/^'!' allowed only after types sSiIlLxX in (?:un)?pack/;
}

for my $size ( 16, 32, 64 ) {
  if (defined $Config{"u${size}size"} and $Config{"u${size}size"} != ($size >> 3)) {
    push @valid_errors, qr/^Perl_my_$maybe_not_avail$size\(\) not available/;
  }
}

my $IsTwosComplement = pack('i', -1) eq "\xFF" x $Config{intsize};
print "# \$IsTwosComplement = $IsTwosComplement\n";

sub is_valid_error
{
  my $err = shift;

  for my $e (@valid_errors) {
    $err =~ $e and return 1;
  }

  return 0;
}

sub encode_list {
  my @result = map {_qq($_)} @_;
  if (@result == 1) {
    return @result;
  }
  return '(' . join (', ', @result) . ')';
}


sub list_eq ($$) {
  my ($l, $r) = @_;
  return 0 unless @$l == @$r;
  for my $i (0..$#$l) {
    if (defined $l->[$i]) {
      return 0 unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
    } else {
      return 0 if defined $r->[$i]
    }
  }
  return 1;
}

##############################################################################
#
# Here starteth the tests
#

{
    my $format = "c2 x5 C C x s d i l a6";
    # Need the expression in here to force ary[5] to be numeric.  This avoids
    # test2 failing because ary2 goes str->numeric->str and ary doesn't.
    my @ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,
               "abcdef");
    my $foo = pack($format,@ary);
    my @ary2 = unpack($format,$foo);

    is($#ary, $#ary2);

    my $out1=join(':',@ary);
    my $out2=join(':',@ary2);
    # Using long double NVs may introduce greater accuracy than wanted.
    $out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/;
    $out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/;
    is($out1, $out2);

    like($foo, qr/def/);
}
# How about counting bits?

{
    my $x;
    is( ($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")), 16 );

    is( ($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")), 12 );

    is( ($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")), 9 );
}

{
    my $sum = 129; # ASCII
    $sum = 103 if $Is_EBCDIC;

    my $x;
    is( ($x = unpack("%32B*", "Now is the time for all good blurfl")), $sum );

    my $foo;
    open(BIN, $Perl) || die "Can't open $Perl: $!\n";
    sysread BIN, $foo, 8192;
    close BIN;

    $sum = unpack("%32b*", $foo);
    my $longway = unpack("b*", $foo);
    is( $sum, $longway =~ tr/1/1/ );
}

{
  my $x;
  is( ($x = unpack("I",pack("I", 0xFFFFFFFF))), 0xFFFFFFFF );
}

{
    # check 'w'
    my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33,
             '4503599627365785','23728385234614992549757750638446');
    my $x = pack('w*', @x);
    my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f8480808014A0808'.
                       '0800087ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';

    is($x, $y);

    my @y = unpack('w*', $y);
    my $a;
    while ($a = pop @x) {
        my $b = pop @y;
        is($a, $b);
    }

    @y = unpack('w2', $x);

    is(scalar(@y), 2);
    is($y[1], 130);
    $x = pack('w*', 5000000000); $y = '';
    eval {
    use Math::BigInt;
    $y = pack('w*', Math::BigInt::->new(5000000000));
    };
    is($x, $y);

    $x = pack 'w', ~0;
    $y = pack 'w', (~0).'';
    is($x, $y);
    is(unpack ('w',$x), ~0);
    is(unpack ('w',$y), ~0);

    $x = pack 'w', ~0 - 1;
    $y = pack 'w', (~0) - 2;

    if (~0 - 1 == (~0) - 2) {
        is($x, $y, "NV arithmetic");
    } else {
        isnt($x, $y, "IV/NV arithmetic");
    }
    cmp_ok(unpack ('w',$x), '==', ~0 - 1);
    cmp_ok(unpack ('w',$y), '==', ~0 - 2);

    # These should spot that pack 'w' is using NV, not double, on platforms
    # where IVs are smaller than doubles, and harmlessly pass elsewhere.
    # (tests for change 16861)
    my $x0 = 2**54+3;
    my $y0 = 2**54-2;

    $x = pack 'w', $x0;
    $y = pack 'w', $y0;

    if ($x0 == $y0) {
        is($x, $y, "NV arithmetic");
    } else {
        isnt($x, $y, "IV/NV arithmetic");
    }
    cmp_ok(unpack ('w',$x), '==', $x0);
    cmp_ok(unpack ('w',$y), '==', $y0);
}


{
  print "# test exceptions\n";
  my $x;
  eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
  like($@, qr/^Unterminated compressed integer/);

  eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff};
  like($@, qr/^Unterminated compressed integer/);

  eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
  like($@, qr/^Unterminated compressed integer/);

  eval { $x = pack 'w', -1 };
  like ($@, qr/^Cannot compress negative numbers/);

  eval { $x = pack 'w', '1'x(1 + length ~0) . 'e0' };
  like ($@, qr/^Can only compress unsigned integers/);

  # Check that the warning behaviour on the modifiers !, < and > is as we
  # expect it for this perl.
  my $can_endian = $no_endianness ? '' : 'sSiIlLqQjJfFdDpP';
  my $can_shriek = 'sSiIlL';
  $can_shriek .= 'nNvV' unless $no_signedness;
  # h and H can't do either, so act as sanity checks in blead
  foreach my $base (split '', 'hHsSiIlLqQjJfFdDpPnNvV') {
    foreach my $mod ('', '<', '>', '!', '<!', '>!', '!<', '!>') {
    SKIP: {
        # Avoid void context warnings.
        my $a = eval {pack "$base$mod"};
        skip "pack can't $base", 1 if $@ =~ /^Invalid type '\w'/;
        # Which error you get when 2 would be possible seems to be emergent
        # behaviour of pack's format parser.

        my $fails_shriek = $mod =~ /!/ && index ($can_shriek, $base) == -1;
        my $fails_endian = $mod =~ /[<>]/ && index ($can_endian, $base) == -1;
        my $shriek_first = $mod =~ /^!/;

        if ($no_endianness and ($mod eq '<!' or $mod eq '>!')) {
          # The ! isn't seem as part of $base. Instead it's seen as a modifier
          # on > or <
          $fails_shriek = 1;
          undef $fails_endian;
        } elsif ($fails_shriek and $fails_endian) {
          if ($shriek_first) {
            undef $fails_endian;
          }
        }

        if ($fails_endian) {
          if ($no_endianness) {
            # < and > are seen as pattern letters, not modifiers
            like ($@, qr/^Invalid type '[<>]'/, "pack can't $base$mod");
          } else {
            like ($@, qr/^'[<>]' allowed only after types/,
                  "pack can't $base$mod");
          }
        } elsif ($fails_shriek) {
          like ($@, qr/^'!' allowed only after types/,
                "pack can't $base$mod");
        } else {
          is ($@, '', "pack can $base$mod");
        }
      }
    }
  }

 SKIP: {
    skip $no_endianness, 2*3 + 2*8 if $no_endianness;
    for my $mod (qw( ! < > )) {
      eval { $x = pack "a$mod", 42 };
      like ($@, qr/^'$mod' allowed only after types \S+ in pack/);

      eval { $x = unpack "a$mod", 'x'x8 };
      like ($@, qr/^'$mod' allowed only after types \S+ in unpack/);
    }

    for my $mod (qw( <> >< !<> !>< <!> >!< <>! ><! )) {
      eval { $x = pack "sI${mod}s", 42, 47, 11 };
      like ($@, qr/^Can't use both '<' and '>' after type 'I' in pack/);

      eval { $x = unpack "sI${mod}s", 'x'x16 };
      like ($@, qr/^Can't use both '<' and '>' after type 'I' in unpack/);
    }
  }

 SKIP: {
    # Is this a stupid thing to do on VMS, VOS and other unusual platforms?

    skip("-- the IEEE infinity model is unavailable in this configuration.", 1)
       if (($^O eq 'VMS') && !defined($Config{useieee}));

    skip("-- $^O has serious fp indigestion on w-packed infinities", 1)
       if (
           ($^O eq 'mpeix')
           ||
           ($^O eq 'ultrix')
           ||
           ($^O =~ /^svr4/ && -f "/etc/issue" && -f "/etc/.relid") # NCR MP-RAS
           );

    my $inf = eval '2**1000000';

    skip("Couldn't generate infinity - got error '$@'", 1)
      unless defined $inf and $inf == $inf / 2 and $inf + 1 == $inf;

    local our $TODO;
    $TODO = "VOS needs a fix for posix-1022 to pass this test."
      if ($^O eq 'vos');

    eval { $x = pack 'w', $inf };
    like ($@, qr/^Cannot compress integer/, "Cannot compress integer");
  }