X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fpack.t;h=6e3d6e4ff2e960afd8b081f21fc3f853840d7c89;hb=076d9a11d18d650bf0992032a42c6e83fb1c2ea6;hp=a4c5db01d2bf6f8879c99c7a3967b4b839625b6f;hpb=9c3dc5877366a4b76c59e7e1b537358b0b2bc2f8;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/op/pack.t b/t/op/pack.t
index a4c5db0..6e3d6e4 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 5826;
+plan tests => 5852;
 
 use strict;
 use warnings;
@@ -160,7 +160,7 @@ sub list_eq ($$) {
 
 
 {
-  # test exceptions
+  print "# test exceptions\n";
   my $x;
   eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
   like($@, qr/^Unterminated compressed integer/);
@@ -179,20 +179,44 @@ sub list_eq ($$) {
 
  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**10000';
 
-    skip "Couldn't generate infinity - got error '$@'"
+    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/);
+    like ($@, qr/^Cannot compress integer/, "Cannot compress integer");
   }
 
  SKIP: {
+
+    skip("-- the full range of an IEEE double may not be available in this configuration.", 3)
+       if (($^O eq 'VMS') && !defined($Config{useieee}));
+
+    skip("-- $^O does not like 2**1023", 3)
+       if (($^O eq 'ultrix'));
+
     # 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
+    skip("Couldn't generate 2**1023 - got error '$@'", 3)
       unless defined $big and $big != $big / 2;
 
     eval { $x = pack 'w', $big };
@@ -210,8 +234,7 @@ sub list_eq ($$) {
 
 }
 
-#
-# test the "p" template
+print "# test the 'p' template\n";
 
 # literals
 is(unpack("p",pack("p","foo")), "foo");
@@ -240,8 +263,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));
@@ -255,7 +278,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) {
@@ -263,7 +287,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);
@@ -352,7 +376,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});
@@ -374,11 +398,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, $_);
@@ -398,7 +423,7 @@ sub numbers_with_total {
     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);
@@ -430,7 +455,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;
@@ -507,7 +532,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");
@@ -519,10 +544,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" };
@@ -538,10 +563,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";
@@ -781,7 +806,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
@@ -822,6 +847,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);
@@ -939,7 +1063,7 @@ 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);
@@ -953,7 +1077,7 @@ 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 in pack: '$template'/;
+      die unless $@ =~ /Invalid type '$template'/;
       skip ("$template not supported on this perl",
             $cant_checksum{$template} ? 4 : 8);
     }
@@ -995,3 +1119,13 @@ 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)) {
 
 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]");
+}