fix occasional op/time.t failure

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

diff --git a/t/op/pack.t b/t/op/pack.t
index 66d2ee6..f37c73f 100755 (executable)
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -15,7 +15,7 @@ my $no_signedness = $] > 5.009 ? '' :
 plan tests => 14697;
 
 use strict;
-use warnings;
+use warnings qw(FATAL all);
 use Config;
 
 my $Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define');
@@ -43,7 +43,7 @@ if ($no_signedness) {
 }
 
 for my $size ( 16, 32, 64 ) {
-  if (exists $Config{"u${size}size"} and $Config{"u${size}size"} != ($size >> 3)) {
+  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/;
   }
 }
@@ -129,6 +129,7 @@ sub list_eq ($$) {
 
     my $foo;
     open(BIN, $Perl) || die "Can't open $Perl: $!\n";
+    binmode BIN;
     sysread BIN, $foo, 8192;
     close BIN;
 
@@ -368,7 +369,7 @@ SKIP: {
 # temps
 sub foo { my $a = "a"; return $a . $a++ . $a++ }
 {
-  use warnings;
+  use warnings qw(NONFATAL all);;
   my $warning;
   local $SIG{__WARN__} = sub {
       $warning = $_[0];
@@ -710,7 +711,10 @@ sub byteorder
       skip "cannot pack '$format' on this perl", 5
         if is_valid_error($@);
 
-      print "# [$value][$nat][$be][$le][$@]\n";
+      {
+        use warnings qw(NONFATAL utf8);
+        print "# [$value][$nat][$be][$le][$@]\n";
+      }
 
       SKIP: {
         skip "cannot compare native byteorder with big-/little-endian", 1
@@ -943,6 +947,8 @@ SKIP: {
 
     # does unpack U0U on byte data warn?
     {
+       use warnings qw(NONFATAL all);;
+
         my $bad = pack("U0C", 255);
         local $SIG{__WARN__} = sub { $@ = "@_" };
         my @null = unpack('U0U', $bad);
@@ -1191,11 +1197,6 @@ SKIP: {
 }
 
 {  # 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' );
@@ -1234,7 +1235,7 @@ SKIP: {
 }
 
 { # syntax checks (W.Laun)
-  use warnings;
+  use warnings qw(NONFATAL all);;
   my @warning;
   local $SIG{__WARN__} = sub {
       push( @warning, $_[0] );
@@ -1355,6 +1356,7 @@ SKIP: {
             my $p = eval { pack $junk1, @list2 };
              skip "cannot pack '$type' on this perl", 12
                if is_valid_error($@);
+            die "pack $junk1 failed: $@" if $@;
 
             my $half = int( (length $p)/2 );
             for my $move ('', "X$half", "X!$half", 'x1', 'x!8', "x$half") {
@@ -1405,6 +1407,7 @@ is(scalar unpack('A /A /A Z20', '3004bcde'), 'bcde');
   $b =~ s/(?:17000+|16999+)\d+(e-45) /17$1 /gi; # stringification is gamble
   is($b, "@a @a");
 
+  use warnings qw(NONFATAL all);;
   my $warning;
   local $SIG{__WARN__} = sub {
       $warning = $_[0];
@@ -1488,7 +1491,7 @@ $_ = 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 = "X\x0901234567\n" x 100; # \t would not be EBCDIC TAB
     my @a = unpack("(a1 c/a)*", $a);
     is(scalar @a, 200,       "[perl #15288]");
     is($a[-1], "01234567\n", "[perl #15288]");
@@ -1496,6 +1499,7 @@ is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_
 }
 
 {
+    use warnings qw(NONFATAL all);;
     my $warning;
     local $SIG{__WARN__} = sub {
         $warning = $_[0];
@@ -1515,7 +1519,11 @@ is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_
     is($x[1], $y[1], "checksum advance ok");
 
     # verify that the checksum is not overflowed with C0
-    is(unpack("C0%128U", "abcd"), unpack("U0%128U", "abcd"), "checksum not overflowed");
+    if (ord('A') == 193) {
+       is(unpack("C0%128U", "/bcd"), unpack("U0%128U", "abcd"), "checksum not overflowed");
+    } else {
+       is(unpack("C0%128U", "abcd"), unpack("U0%128U", "abcd"), "checksum not overflowed");
+    }
 }
 
 {
@@ -1530,10 +1538,15 @@ is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_
 {
     # counted length prefixes shouldn't change C0/U0 mode
     # (note the length is actually 0 in this test)
-    is(join(',', unpack("aC/UU",   "b\0\341\277\274")), 'b,8188');
-    is(join(',', unpack("aC/CU",   "b\0\341\277\274")), 'b,8188');
-    is(join(',', unpack("aU0C/UU", "b\0\341\277\274")), 'b,225');
-    is(join(',', unpack("aU0C/CU", "b\0\341\277\274")), 'b,225');
+    if (ord('A') == 193) {
+       is(join(',', unpack("aU0C/UU", "b\0\341\277\274")), 'b,0');
+       is(join(',', unpack("aU0C/CU", "b\0\341\277\274")), 'b,0');
+    } else {
+       is(join(',', unpack("aC/UU",   "b\0\341\277\274")), 'b,8188');
+       is(join(',', unpack("aC/CU",   "b\0\341\277\274")), 'b,8188');
+       is(join(',', unpack("aU0C/UU", "b\0\341\277\274")), 'b,225');
+       is(join(',', unpack("aU0C/CU", "b\0\341\277\274")), 'b,225');
+    }
 }
 
 {