X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fpack.t;h=e5b82035251c39efaf9e511c194ec157899a1ee1;hb=40837afcb0b195c90e4d9b17d791c9d4dd4f223b;hp=20fdb37eb7fd9cc8bf7b648277297a3cec6ee446;hpb=196b62db48c48e65dfbfa734e2c0981779160ea3;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/op/pack.t b/t/op/pack.t
index 20fdb37..e5b8203 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 5625;
+plan tests => 5852;
 
 use strict;
 use warnings;
@@ -26,12 +26,12 @@ sub encode_list {
 
 sub list_eq ($$) {
   my ($l, $r) = @_;
-  return unless @$l == @$r;
+  return 0 unless @$l == @$r;
   for my $i (0..$#$l) {
     if (defined $l->[$i]) {
-      return unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
+      return 0 unless defined ($r->[$i]) && $l->[$i] eq $r->[$i];
     } else {
-      return if defined $r->[$i]
+      return 0 if defined $r->[$i]
     }
   }
   return 1;
@@ -139,11 +139,28 @@ sub list_eq ($$) {
     }
     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);
 }
 
 
 {
-  # test exceptions
+  print "# test exceptions\n";
   my $x;
   eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
   like($@, qr/^Unterminated compressed integer/);
@@ -153,10 +170,62 @@ sub list_eq ($$) {
 
   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/);
+
+ 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."
+       if (($^O eq 'VMS') && !defined($Config{useieee}));
+
+    skip "-- MPE/iX has serious fp indigestionf on w-packed infinities"
+       if (($^O eq 'mpeix'));
+
+    my $inf = eval '2**10000';
+
+    skip "Couldn't generate infinity - got error '$@'"
+      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");
+  }
+
+ SKIP: {
+
+    skip "-- the full range of an IEEE double may not be available in this configuration."
+       if (($^O eq 'VMS') && !defined($Config{useieee}));
+
+    # This should be about the biggest thing possible on an IEEE double
+    my $big = eval '2**1023';
+
+    skip "Couldn't generate 2**1023 - got error '$@'", 3
+      unless defined $big and $big != $big / 2;
+
+    eval { $x = pack 'w', $big };
+    is ($@, '', "Should be able to pack 'w', $big # 2**1023");
+
+    my $y = eval {unpack 'w', $x};
+    is ($@, '',
+	"Should be able to unpack 'w' the result of pack 'w', $big # 2**1023");
+
+    # I'm getting about 1e-16 on FreeBSD
+    my $quotient = int (100 * ($y - $big) / $big);
+    ok($quotient < 2 && $quotient > -2,
+       "Round trip pack, unpack 'w' of $big is withing 1% ($quotient%)");
+  }
+
 }
 
-#
-# test the "p" template
+print "# test the 'p' template\n";
 
 # literals
 is(unpack("p",pack("p","foo")), "foo");
@@ -185,8 +254,8 @@ like(pack("p", undef), qr/^\0+/);
 #				 see #ifdef __osf__ in pp.c pp_unpack
 is((unpack("i",pack("i",-1))), -1);
 
-# test the pack lengths of s S i I l L
-# test the pack lengths of n N v V
+print "# test the pack lengths of s S i I l L n N v V\n";
+
 my @lengths = qw(s 2 S 2 i -4 I -4 l 4 L 4 n 2 N 4 v 2 V 4);
 while (my ($format, $expect) = splice @lengths, 0, 2) {
   my $len = length(pack($format, 0));
@@ -200,7 +269,8 @@ while (my ($format, $expect) = splice @lengths, 0, 2) {
 }
 
 
-# test unpack-pack lengths
+print "# test unpack-pack lengths\n";
+
 my @templates = qw(c C i I s S l L n N v V f d q Q);
 
 foreach my $t (@templates) {
@@ -208,7 +278,7 @@ foreach my $t (@templates) {
         my @t = eval { unpack("$t*", pack("$t*", 12, 34)) };
 
         # quads not supported everywhere
-        skip "Quads not supported", 4 if $@ =~ /Invalid type in pack/;
+        skip "Quads not supported", 4 if $@ =~ /Invalid type/;
         is( $@, '' );
 
         is(scalar @t, 2);
@@ -297,7 +367,7 @@ foreach (
     }
 }
 
-# packing native shorts/ints/longs
+print "# packing native shorts/ints/longs\n";
 
 is(length(pack("s!", 0)), $Config{shortsize});
 is(length(pack("i!", 0)), $Config{intsize});
@@ -319,11 +389,12 @@ sub numbers_with_total {
       $total += $_;
     }
   }
+  print "# numbers test for $format\n";
   foreach (@_) {
     SKIP: {
         my $out = eval {unpack($format, pack($format, $_))};
         skip "cannot pack '$format' on this perl", 2 if
-          $@ =~ /Invalid type in pack: '$format'/;
+          $@ =~ /Invalid type '$format'/;
 
         is($@, '');
         is($out, $_);
@@ -336,14 +407,14 @@ sub numbers_with_total {
     # UVs (in which case ~0 is NV, ~0-1 will be the same NV) then we can't
     # correctly in perl calculate UV totals for long checksums, as pp_unpack
     # is using UV maths, and we've only got NVs.
-    $skip_if_longer_than = $Config{d_nv_preserves_uv_bits};
+    $skip_if_longer_than = $Config{nv_preserves_uv_bits};
   }
 
   foreach ('', 1, 2, 3, 15, 16, 17, 31, 32, 33, 53, 54, 63, 64, 65) {
     SKIP: {
       my $sum = eval {unpack "%$_$format*", pack "$format*", @_};
       skip "cannot pack '$format' on this perl", 3
-        if $@ =~ /Invalid type in pack: '$format'/;
+        if $@ =~ /Invalid type '$format'/;
 
       is($@, '');
       ok(defined $sum);
@@ -375,7 +446,7 @@ sub numbers_with_total {
         } else {
             $calc_sum = $total;
             # Shift into range by some multiple of the total
-            my $mult = int ($total / $max_p1);
+            my $mult = $max_p1 ? int ($total / $max_p1) : undef;
             # Need this to make sure that -1 + (~0+1) is ~0 (ie still integer)
             $calc_sum = $total - $mult;
             $calc_sum -= $mult * $max;
@@ -452,7 +523,7 @@ numbers_with_total ('Q', sub {
                     0, 1,9223372036854775807, 9223372036854775808,
                     18446744073709551615);
 
-# pack nvNV byteorders
+print "# pack nvNV byteorders\n";
 
 is(pack("n", 0xdead), "\xde\xad");
 is(pack("v", 0xdead), "\xad\xde");
@@ -464,10 +535,10 @@ is(pack("V", 0xdeadbeef), "\xef\xbe\xad\xde");
 
   my ($x, $y, $z);
   eval { ($x) = unpack '/a*','hello' };
-  like($@, qr!/ must follow a numeric type!);
+  like($@, qr!'/' must follow a numeric type!);
   undef $x;
   eval { $x = unpack '/a*','hello' };
-  like($@, qr!/ must follow a numeric type!);
+  like($@, qr!'/' must follow a numeric type!);
 
   undef $x;
   eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" };
@@ -483,10 +554,10 @@ is(pack("V", 0xdeadbeef), "\xef\xbe\xad\xde");
 
   undef $x;
   eval { ($x) = pack '/a*','hello' };
-  like($@,  qr!Invalid type in pack: '/'!);
+  like($@,  qr!Invalid type '/'!);
   undef $x;
   eval { $x = pack '/a*','hello' };
-  like($@,  qr!Invalid type in pack: '/'!);
+  like($@,  qr!Invalid type '/'!);
 
   $z = pack 'n/a* N/Z* w/A*','string','hi there ','etc';
   my $expect = "\000\006string\0\0\0\012hi there \000\003etc";
@@ -674,7 +745,7 @@ foreach (
   my ($template, $in, @out) = @$_;
   my @got = eval {unpack $template, $in};
   is($@, '');
-  list_eq (\@got, \@out) ||
+  ok (list_eq (\@got, \@out)) ||
     printf "# list unpack ('$template', %s) gave %s expected %s\n",
            _qq($in), encode_list (@got), encode_list (@out);
 
@@ -726,7 +797,7 @@ foreach (
     # from Wolfgang Laun: fix in change #13288
 
     eval { my $t=unpack("P*", "abc") };
-    like($@, qr/P must have an explicit size/);
+    like($@, qr/'P' must have an explicit size/);
 }
 
 {   # Grouping constructs
@@ -767,6 +838,105 @@ foreach (
     is("@a", "@b");
 }
 
+{  # more on grouping (W.Laun)
+  use warnings;
+  my $warning;
+  local $SIG{__WARN__} = sub {
+      $warning = $_[0];
+  };
+  # @ absolute within ()-group
+  my $badc = pack( '(a)*', unpack( '(@1a @0a @2)*', 'abcd' ) );
+  is( $badc, 'badc' );
+  my @b = ( 1, 2, 3 );
+  my $buf = pack( '(@1c)((@2C)@3c)', @b );
+  is( $buf, "\0\1\0\0\2\3" );
+  my @a = unpack( '(@1c)((@2c)@3c)', $buf );
+  is( "@a", "@b" );
+
+  # various unpack count/code scenarios 
+  my @Env = ( a => 'AAA', b => 'BBB' );
+  my $env = pack( 'S(S/A*S/A*)*', @Env/2, @Env );
+
+  # unpack full length - ok
+  my @pup = unpack( 'S/(S/A* S/A*)', $env );
+  is( "@pup", "@Env" );
+
+  # warn when count/code goes beyond end of string
+  # \0002 \0001 a \0003 AAA \0001 b \0003 BBB
+  #     2     4 5     7  10    1213
+  eval { @pup = unpack( 'S/(S/A* S/A*)', substr( $env, 0, 13 ) ) };
+  like( $@, qr{length/code after end of string} );
+  
+  # postfix repeat count
+  $env = pack( '(S/A* S/A*)' . @Env/2, @Env );
+
+  # warn when count/code goes beyond end of string
+  # \0001 a \0003 AAA \0001  b \0003 BBB
+  #     2 3c    5   8    10 11    13  16
+  eval { @pup = unpack( '(S/A* S/A*)' . @Env/2, substr( $env, 0, 11 ) ) };
+  like( $@, qr{length/code after end of string} );
+
+  # catch stack overflow/segfault
+  eval { $_ = pack( ('(' x 105) . 'A' . (')' x 105) ); };
+  like( $@, qr{Too deeply nested \(\)-groups} );
+}
+
+{ # syntax checks (W.Laun)
+  use warnings;
+  my @warning;
+  local $SIG{__WARN__} = sub {
+      push( @warning, $_[0] );
+  };
+  eval { my $s = pack( 'Ax![4c]A', 1..5 ); };
+  like( $@, qr{Malformed integer in \[\]} );
+
+  eval { my $buf = pack( '(c/*a*)', 'AAA', 'BB' ); };
+  like( $@, qr{'/' does not take a repeat count} );
+
+  eval { my @inf = unpack( 'c/1a', "\x03AAA\x02BB" ); };
+  like( $@, qr{'/' does not take a repeat count} );
+
+  eval { my @inf = unpack( 'c/*a', "\x03AAA\x02BB" ); };
+  like( $@, qr{'/' does not take a repeat count} );
+
+  # white space where possible 
+  my @Env = ( a => 'AAA', b => 'BBB' );
+  my $env = pack( ' S ( S / A*   S / A* )* ', @Env/2, @Env );
+  my @pup = unpack( ' S / ( S / A*   S / A* ) ', $env );
+  is( "@pup", "@Env" );
+
+  # white space in 4 wrong places
+  for my $temp (  'A ![4]', 'A [4]', 'A *', 'A 4' ){
+      eval { my $s = pack( $temp, 'B' ); };
+      like( $@, qr{Invalid type } );
+  }
+
+  # warning for commas
+  @warning = ();
+  my $x = pack( 'I,A', 4, 'X' );
+  like( $warning[0], qr{Invalid type ','} );
+
+  # comma warning only once
+  @warning = ();
+  $x = pack( 'C(C,C)C,C', 65..71  );
+  like( scalar @warning, 1 );
+
+  # forbidden code in []
+  eval { my $x = pack( 'A[@4]', 'XXXX' ); };
+  like( $@, qr{Within \[\]-length '\@' not allowed} );
+
+  # @ repeat default 1
+  my $s = pack( 'AA@A', 'A', 'B', 'C' );
+  my @c = unpack( 'AA@A', $s );
+  is( $s, 'AC' ); 
+  is( "@c", "A C C" ); 
+
+  # no unpack code after /
+  eval { my @a = unpack( "C/", "\3" ); };
+  like( $@, qr{Code missing after '/'} );
+
+}
+
 {  # Repeat count [SUBEXPR]
    my @codes = qw( x A Z a c C B b H h s v n S i I l V N L p P f F d
 		   s! S! i! I! l! L! j J);
@@ -884,9 +1054,69 @@ numbers ('F', -(2**34), -1, 0, 1, 2**34);
 SKIP: {
     my $t = eval { unpack("D*", pack("D", 12.34)) };
 
-    skip "Long doubles not in use", 56 if $@ =~ /Invalid type in pack/;
+    skip "Long doubles not in use", 56 if $@ =~ /Invalid type/;
 
     is(length(pack("D", 0)), $Config{longdblsize});
     numbers ('D', -(2**34), -1, 0, 1, 2**34);
 }
 
+# Maybe this knowledge needs to be "global" for all of pack.t
+# Or a "can checksum" which would effectively be all the number types"
+my %cant_checksum = map {$_=> 1} qw(A Z u w);
+# not a b B h H
+foreach my $template (qw(A Z c C s S i I l L n N v V q Q j J f d F D u U w)) {
+  SKIP: {
+    my $packed = eval {pack "${template}4", 1, 4, 9, 16};
+    if ($@) {
+      die unless $@ =~ /Invalid type '$template'/;
+      skip ("$template not supported on this perl",
+            $cant_checksum{$template} ? 4 : 8);
+    }
+    my @unpack4 = unpack "${template}4", $packed;
+    my @unpack = unpack "${template}*", $packed;
+    my @unpack1 = unpack "${template}", $packed;
+    my @unpack1s = scalar unpack "${template}", $packed;
+    my @unpack4s = scalar unpack "${template}4", $packed;
+    my @unpacks = scalar unpack "${template}*", $packed;
+
+    my @tests = ( ["${template}4 vs ${template}*", \@unpack4, \@unpack],
+                  ["scalar ${template} ${template}", \@unpack1s, \@unpack1],
+                  ["scalar ${template}4 vs ${template}", \@unpack4s, \@unpack1],
+                  ["scalar ${template}* vs ${template}", \@unpacks, \@unpack1],
+                );
+
+    unless ($cant_checksum{$template}) {
+      my @unpack4_c = unpack "\%${template}4", $packed;
+      my @unpack_c = unpack "\%${template}*", $packed;
+      my @unpack1_c = unpack "\%${template}", $packed;
+      my @unpack1s_c = scalar unpack "\%${template}", $packed;
+      my @unpack4s_c = scalar unpack "\%${template}4", $packed;
+      my @unpacks_c = scalar unpack "\%${template}*", $packed;
+
+      push @tests,
+        ( ["% ${template}4 vs ${template}*", \@unpack4_c, \@unpack_c],
+          ["% scalar ${template} ${template}", \@unpack1s_c, \@unpack1_c],
+          ["% scalar ${template}4 vs ${template}*", \@unpack4s_c, \@unpack_c],
+          ["% scalar ${template}* vs ${template}*", \@unpacks_c, \@unpack_c],
+        );
+    }
+    foreach my $test (@tests) {
+      ok (list_eq ($test->[1], $test->[2]), $test->[0]) ||
+        printf "# unpack gave %s expected %s\n",
+          encode_list (@{$test->[1]}), encode_list (@{$test->[2]});
+    }
+  }
+}
+
+ok(pack('u2', 'AA'), "[perl #8026]"); # used to hang and eat RAM in perl 5.7.2
+
+$_ = pack('c', 65); # 'A' would not be EBCDIC-friendly
+is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_
+
+{
+    my $a = "X\t01234567\n" x 100;
+    my @a = unpack("(a1 c/a)*", $a);
+    is(scalar @a, 200,       "[perl #15288]");
+    is($a[-1], "01234567\n", "[perl #15288]");
+    is($a[-2], "X",          "[perl #15288]");
+}