Non-VMS-fixed and Win32-skipped version of

[p5sagit/p5-mst-13.2.git] / t / op / pack.t

diff --git a/t/op/pack.t b/t/op/pack.t
index 6b9ceeb..2fd1312 100755 (executable)
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -1,6 +1,6 @@
 #!./perl -w
 
-print "1..611\n";
+print "1..615\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -49,7 +49,7 @@ sub ok {
   } else {
     if ($err) {
       chomp $err;
-      print "not ok $test # \$\@ = $err\n";
+      print "not ok $test # $err\n";
     } else {
       if (defined $wrong) {
         $wrong = ", got $wrong";
@@ -378,9 +378,8 @@ sub numbers_with_total {
     $max_is_integer = 1 if $max - 1 < ~0;
 
     my $calc_sum;
-    if ($total =~ /^0b[01]*?([01]{1,$len})/) {
-      no warnings qw(overflow portable);
-      $calc_sum = oct "0b$1";
+    if (ref $total) {
+      $calc_sum = &$total($len);
     } else {
       $calc_sum = $total;
       # Shift into range by some multiple of the total
@@ -410,7 +409,8 @@ sub numbers_with_total {
         print "ok $test # unpack '%$_$format' gave $sum,"
           . " expected $calc_sum\n";
       } else {
-        print "not ok $test # For list (" . join (", ", @_) . ") (total $total)"
+       my $text = ref $total ? &$total($len) : $total;
+        print "not ok $test # For list (" . join (", ", @_) . ") (total $text)"
           . " packed with $format unpack '%$_$format' gave $sum,"
             . " expected $calc_sum\n";
       }
@@ -446,10 +446,17 @@ numbers ('d', -(2**34), -1, 0, 1, 2**34);
 
 numbers_with_total ('q', -1,
                     -9223372036854775808, -1, 0, 1,9223372036854775807);
-# This total is icky, but need a way to express 2**65-1 that is going to
-# work independant of whether NVs can preserve 65 bits.
-# (long double is 128 bits on sparc, so they certianly can)
-numbers_with_total ('Q', "0b" . "1" x 65,
+# This total is icky, but the true total is 2**65-1, and need a way to generate
+# the epxected checksum on any system including those where NVs can preserve
+# 65 bits. (long double is 128 bits on sparc, so they certainly can)
+# or where rounding is down not up on binary conversion (crays)
+numbers_with_total ('Q', sub {
+                      my $len = shift;
+                      $len = 65 if $len > 65; # unmasked total is 2**65-1 here
+                      my $total = 1 + 2 * (int (2**($len - 1)) - 1);
+                      return 0 if $total == $total - 1; # Overflowed integers
+                      return $total; # NVs still accurate to nearest integer
+                    },
                     0, 1,9223372036854775807, 9223372036854775808,
                     18446744073709551615);
 
@@ -550,20 +557,24 @@ ok ("@{[unpack('U*', pack('U*', 100, 200, 300))]}" eq "100 200 300");
 # is unpack U the reverse of pack U for byte string?
 ok ("@{[unpack('U*', pack('U*', 100, 200))]}" eq "100 200");
 
-# does unpack C unravel pack U?
-ok ("@{[unpack('C*', pack('U*', 100, 200))]}" eq "100 195 136");
+if (ord('A') == 193) {
+    ok(1, undef, "skipped") for 1..4; # EBCDIC
+} else {
+    # does unpack C unravel pack U?
+    ok ("@{[unpack('C*', pack('U*', 100, 200))]}" eq "100 195 136");
 
-# does pack U0C create Unicode?
-ok ("@{[pack('U0C*', 100, 195, 136)]}" eq v100.v200);
+    # does pack U0C create Unicode?
+     ok ("@{[pack('U0C*', 100, 195, 136)]}" eq v100.v200);
 
-# does pack C0U create characters?
-ok ("@{[pack('C0U*', 100, 200)]}" eq pack("C*", 100, 195, 136));
+    # does pack C0U create characters?
+    ok ("@{[pack('C0U*', 100, 200)]}" eq pack("C*", 100, 195, 136));
 
-# does unpack U0U on byte data warn?
-{
-    local $SIG{__WARN__} = sub { $@ = "@_" };
-    my @null = unpack('U0U', chr(255));
-    ok ($@ =~ /^Malformed UTF-8 character /, undef, $@);
+    # does unpack U0U on byte data warn?
+    {
+        local $SIG{__WARN__} = sub { $@ = "@_" };
+        my @null = unpack('U0U', chr(255));
+        ok ($@ =~ /^Malformed UTF-8 character /, undef, $@);
+    }
 }
 
 {
@@ -653,5 +664,43 @@ foreach (
     my ($u, $v) = qw(foo xyzzy);
     my $p = pack($t, $u, $v);
     my @u = unpack($t, $p);
-    print @u == 2 && $u[0] eq $u && $u[1] eq $v ? "ok 611\n" : "not ok 611\n";
+    ok(@u == 2 && $u[0] eq $u && $u[1] eq $v);
+}
+
+{
+    # 612
+
+    ok((unpack("w/a*", "\x02abc"))[0] eq "ab");
+
+    # 613: "w/a*" should be seen as one unit
+
+    ok(scalar unpack("w/a*", "\x02abc") eq "ab");
+}
+
+{
+    # 614
+    
+    # from Wolfgang Laun: fix in change #13163
+
+    my $s = 'ABC' x 10;
+    my $x = 42;
+    my $buf = pack( 'Z*/A* C',  $s, $x );
+    my $y;
+
+    my $h = $buf;
+    $h =~ s/[^[:print:]]/./g;
+    ( $s, $y ) = unpack( "Z*/A* C", $buf );
+    ok($h eq "30.ABCABCABCABCABCABCABCABCABCABC*" &&
+       length $buf == 34 &&
+       $s eq "ABCABCABCABCABCABCABCABCABCABC" &
+       $y == 42);
+}
+
+{
+    # 615
+
+    # from Wolfgang Laun: fix in change #13288
+
+    eval { my $t=unpack("P*", "abc") };
+    ok($@ =~ /P must have an explicit size/);
 }