z/OS: t/ - mostly EBCDIC fixes

Message-Id: <200607112101.k6BL1TGr321715@kosh.hut.fi>

p4raw-id: //depot/perl@28550

12 files changed, 116 insertions, 26 deletions

diff --git a/t/comp/parser.t b/t/comp/parser.t
index e1eff35c11..a05085879f 100644
--- a/t/comp/parser.t
+++ b/t/comp/parser.t
@@ -135,7 +135,7 @@ EOF
 {
     local $SIG{__WARN__} = sub { }; # silence mandatory warning
     eval q{ my $x = -F 1; };
-    like( $@, qr/(?:syntax|parse) error .* near "F 1"/, "unknown filetest operators" );
+    like( $@, qr/(?i:syntax|parse) error .* near "F 1"/, "unknown filetest operators" );
     is(
         eval q{ sub F { 42 } -F 1 },
 	'-42',
diff --git a/t/op/caller.t b/t/op/caller.t
index 4de1a191a8..5d27ea594b 100644
--- a/t/op/caller.t
+++ b/t/op/caller.t
@@ -77,15 +77,15 @@ sub testwarn {
     testwarn("\0" x 12);
 
     use warnings;
-    BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUU\025", 'default bits on via "use warnings"' ); }
-    BEGIN { testwarn("UUUUUUUUUUU\025", "#1"); }
+    BEGIN { is( ${^WARNING_BITS}, "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\025", 'default bits on via "use warnings"' ); }
+    BEGIN { testwarn("\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\025", "#1"); }
     # run-time :
     # the warning mask has been extended by warnings::register
-    testwarn("UUUUUUUUUUUU");
+    testwarn("\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55");
 
     use warnings::register;
-    BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUUU", 'warning bits on via "use warnings::register"' ) }
-    testwarn("UUUUUUUUUUUU","#3");
+    BEGIN { is( ${^WARNING_BITS}, "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", 'warning bits on via "use warnings::register"' ) }
+    testwarn("\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55","#3");
 }
 
 
diff --git a/t/op/chop.t b/t/op/chop.t
index b0308b0902..503f6f70ca 100755
--- a/t/op/chop.t
+++ b/t/op/chop.t
@@ -183,7 +183,7 @@ ok($@ =~ /Can\'t modify.*chop.*in.*assignment/);
 eval 'chomp($x, $y) = (1, 2);';
 ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/);
 
-my @chars = ("N", "\xd3", substr ("\xd4\x{100}", 0, 1), chr 1296);
+my @chars = ("N", ord('A') == 193 ? "\xee" : "\xd3", substr ("\xd4\x{100}", 0, 1), chr 1296);
 foreach my $start (@chars) {
   foreach my $end (@chars) {
     local $/ = $end;
diff --git a/t/op/exec.t b/t/op/exec.t
index a6eeeb522f..c13849199a 100755
--- a/t/op/exec.t
+++ b/t/op/exec.t
@@ -96,7 +96,7 @@ unless( ok($rc == 255 << 8 or $rc == -1 or $rc == 256 or $rc == 512) ) {
 
 unless ( ok( $! == 2  or  $! =~ /\bno\b.*\bfile/i or  
              $! == 13 or  $! =~ /permission denied/i or
-             $! == 22 or  $! =~ /invalid argument/  ) ) {
+             $! == 22 or  $! =~ /invalid argument/i  ) ) {
     printf "# \$! eq %d, '%s'\n", $!, $!;
 }
 
diff --git a/t/op/index.t b/t/op/index.t
index 88c0372454..b7cdfb0958 100755
--- a/t/op/index.t
+++ b/t/op/index.t
@@ -86,8 +86,15 @@ is(rindex($a, "foo",    ), 0);
 }
 
 {
-    my $search = "foo \xc9 bar";
-    my $text = "a\xa3\xa3a $search    $search quux";
+    my $search;
+    my $text;
+    if (ord('A') == 193) {
+	$search = "foo \x71 bar";
+	$text = "a\xb1\xb1a $search    $search quux";
+    } else {
+	$search = "foo \xc9 bar";
+	$text = "a\xa3\xa3a $search    $search quux";
+    }
 
     my $text_utf8 = $text;
     utf8::upgrade($text_utf8);
diff --git a/t/op/pack.t b/t/op/pack.t
index 57c6a648cf..d58a87d63c 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -1488,7 +1488,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]");
@@ -1516,7 +1516,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");
+    }
 }
 
 {
@@ -1531,10 +1535,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');
+    }
 }
 
 {
diff --git a/t/op/pat.t b/t/op/pat.t
index e4ba07f93f..0de38e14df 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -2639,7 +2639,11 @@ print "# some Unicode properties\n";
     print "# more whitespace: U+0085, U+2028, U+2029\n";
 
     # U+0085 needs to be forced to be Unicode, the \x{100} does that.
-    print "<\x{100}\x{0085}>" =~ /<\x{100}\s>/ ? "ok 845\n" : "not ok 845\n";
+    if ($ordA == 193) {
+	print "<\x{100}\x{0085}>" =~ /<\x{100}e>/ ? "ok 845\n" : "not ok 845\n";
+    } else {
+	print "<\x{100}\x{0085}>" =~ /<\x{100}\s>/ ? "ok 845\n" : "not ok 845\n";
+    }
     print "<\x{2028}>" =~ /<\s>/ ? "ok 846\n" : "not ok 846\n";
     print "<\x{2029}>" =~ /<\s>/ ? "ok 847\n" : "not ok 847\n";
 }
diff --git a/t/op/sprintf.t b/t/op/sprintf.t
index c7dc49f08f..3881aec771 100755
--- a/t/op/sprintf.t
+++ b/t/op/sprintf.t
@@ -421,7 +421,7 @@ __END__
 >%0v2.2d<	>''<	><
 >%vc,%d<	>[63, 64, 65]<	>%vc,63 INVALID<
 >%v%,%d<	>[63, 64, 65]<	>%v%,63 INVALID<
->%vd,%d<	>[1, 2, 3]<	>49,2<
+>%vd,%d<	>["\x1", 2, 3]<	>1,2<
 >%vf,%d<	>[1, 2, 3]<	>%vf,1 INVALID<
 >%vF,%d<	>[1, 2, 3]<	>%vF,1 INVALID<
 >%ve,%d<	>[1, 2, 3]<	>%ve,1 INVALID<
@@ -433,7 +433,7 @@ __END__
 >%vs,%d<	>[1, 2, 3]<	>%vs,1 INVALID<
 >%v_<	>''<	>%v_ INVALID<
 >%v#x<	>''<	>%v#x INVALID<
->%v02x<	>"foo\012"<	>66.6f.6f.0a<
+>%v02x<	>"\x66\x6f\x6f\012"<	>66.6f.6f.0a<
 >%#v.8b<	>"\141\000\142"<	>0b01100001.00000000.0b01100010<	>perl #39530<
 >%#v.4o<	>"\141\000\142"<	>0141.0000.0142<	>perl #39530<
 >%#v.3i<	>"\141\000\142"<	>097.000.098<	>perl #39530<
diff --git a/t/op/utfhash.t b/t/op/utfhash.t
index 33909c0cbc..32a182635a 100644
--- a/t/op/utfhash.t
+++ b/t/op/utfhash.t
@@ -175,6 +175,17 @@ foreach ("\x7f","\xff")
 }
 
 {
+    local $/; # Slurp.
+    my $utf8      = <DATA>;
+    my $utfebcdic = <DATA>;
+    if (ord('A') == 65) {
+	eval $utf8;
+    } elsif (ord('A') == 193) {
+	eval $utfebcdic;
+    }
+}
+__END__
+{
   # See if utf8 barewords work [perl #22969]
   use utf8;
   my %hash = (тест => 123);
@@ -186,3 +197,16 @@ foreach ("\x7f","\xff")
   is($hash{тест}, 123);
   is($hash{'тест'}, 123);
 }
+__END__
+{
+  # See if utf8 barewords work [perl #22969]
+  use utf8; # UTF-EBCDIC, really.
+  my %hash = (���������� => 123);
+  is($hash{����������}, $hash{'����������'});
+  is($hash{����������}, 123);
+  is($hash{'����������'}, 123);
+  %hash = (���������� => 123);
+  is($hash{����������}, $hash{'����������'});
+  is($hash{����������}, 123);
+  is($hash{'����������'}, 123);
+}
diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t
index d422bee3c8..b906285514 100644
--- a/t/run/fresh_perl.t
+++ b/t/run/fresh_perl.t
@@ -828,6 +828,12 @@ foo at - line 1.
 ######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com>
 -lw
 BEGIN {
+  if ($^O eq 'os390') {
+    require File::Glob;
+    import File::Glob ':glob';
+  }
+}
+BEGIN {
   eval 'require Fcntl';
   if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest?
 }
@@ -844,6 +850,12 @@ EXPECT
 ######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com>
 -lw
 BEGIN {
+  if ($^O eq 'os390') {
+    require File::Glob;
+    import File::Glob ':glob';
+  }
+}
+BEGIN {
   eval 'require Fcntl';
   if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest?
 }
@@ -868,7 +880,7 @@ BEGIN {
 # Test case cut down by jhi
 $SIG{__WARN__} = sub { $@ = shift };
 use Encode;
-my $t = "\xE9";
+my $t = ord('A') == 193 ? "\xEA" : "\xE9";
 Encode::_utf8_on($t);
 $t =~ s/([^a])//ge;
 $@ =~ s/ at .*/ at/;
diff --git a/t/uni/case.pl b/t/uni/case.pl
index aad638dc67..e27771b192 100644
--- a/t/uni/case.pl
+++ b/t/uni/case.pl
@@ -78,6 +78,9 @@ sub casetest {
 
     for my $i (sort keys %$spec) {
 	my $w = unidump($spec->{$i});
+	if (ord('A') == 193 && $i eq "\x8A\x73") {
+	    $w = '0178'; # It's a latin small Y with diaresis and not a latin small letter sharp 's'.
+	}
 	my $u = unpack "C0U", $i;
 	my $h = sprintf "%04X", $u;
 	my $c = chr($u); $c .= chr(0x100); chop $c;
@@ -118,7 +121,7 @@ sub casetest {
 		#
 		# 0130 -> 0069 0307 (00D1 0307)
 		#
-		if ($i =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) {
+		if ($h =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) {
 		    $e =~ s/004E/002B/; # N
 		    $e =~ s/004A/00A2/; # J
 		    $e =~ s/0048/00E7/; # H
diff --git a/t/uni/class.t b/t/uni/class.t
index fa4cbf58ae..225b77030d 100644
--- a/t/uni/class.t
+++ b/t/uni/class.t
@@ -50,7 +50,13 @@ sub test_regexp ($$) {
 
 use strict;
 
-my $str = join "", map chr($_), 0x20 .. 0x6F;
+my $str;
+
+if (ord('A') == 193) {
+    $str = join "", map chr($_), 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D, 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61, 0xF0 .. 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F, 0x7C, 0xC1 .. 0xC9, 0xD1 .. 0xD9, 0xE2 .. 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D, 0x79, 0x81 .. 0x89, 0x91 .. 0x96; # IBM-1047
+} else {
+    $str = join "", map chr($_), 0x20 .. 0x6F;
+}
 
 # make sure it finds built-in class
 is(($str =~ /(\p{Letter}+)/)[0], 'ABCDEFGHIJKLMNOPQRSTUVWXYZ');
@@ -91,6 +97,27 @@ my $updir = File::Spec->updir;
 
 no warnings 'utf8'; # we do not want warnings about surrogates etc
 
+sub char_range {
+    my ($h1, $h2) = @_;
+
+    my $str;
+
+    if (ord('A') == 193 && $h1 < 256) {
+	my $h3 = ($h2 || $h1) + 1;
+	if ($h3 - $h1 == 1) {
+	    $str = join "", pack 'U*', $h1 .. $h3; # Using pack since chr doesn't generate Unicode chars for value < 256.
+	} elsif ($h3 - $h1 > 1) {
+	    for (my $i = $h1; $i <= $h3; $i++) {
+		$str = join "", $str, pack 'U*', $i;
+	    }
+	}
+    } else {
+	$str = join "", map chr, $h1 .. (($h2 || $h1) + 1);
+    }
+
+    return $str;
+}
+
 # non-General Category and non-Script
 while (my ($abbrev, $files) = each %utf8::PVA_abbr_map) {
   my $prop_name = $utf8::PropertyAlias{$abbrev};
@@ -104,7 +131,8 @@ while (my ($abbrev, $files) = each %utf8::PVA_abbr_map) {
 
     next unless -e $filename;
     my ($h1, $h2) = map hex, (split(/\t/, (do $filename), 3))[0,1];
-    my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1);
+
+    my $str = char_range($h1, $h2);
 
     for my $p ($prop_name, $abbrev) {
       for my $c ($files->{$_}, $_) {
@@ -124,7 +152,8 @@ for my $p ('gc', 'sc') {
 
     next unless -e $filename;
     my ($h1, $h2) = map hex, (split(/\t/, (do $filename), 3))[0,1];
-    my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1);
+
+    my $str = char_range($h1, $h2);
 
     for my $x ($p, { gc => 'General Category', sc => 'Script' }->{$p}) {
       for my $y ($abbr, $utf8::PropValueAlias{$p}{$abbr}, $utf8::PVA_abbr_map{gc_sc}{$abbr}) {
@@ -162,7 +191,8 @@ SKIP:
     my $filename = File::Spec->catfile($dirname, $leafname);
 
     my ($h1, $h2) = map hex, (split(/\t/, (do $filename), 3))[0,1];
-    my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1);
+
+    my $str = char_range($h1, $h2);
 
     for my $x ('gc', 'General Category') {
       print "# $filename $x $_, $utf8::PA_reverse{$_}\n";
@@ -186,7 +216,8 @@ for (grep $utf8::Canonical{$_} =~ /^In/, keys %utf8::Canonical) {
   print "# In$_ $filename\n";
 
   my ($h1, $h2) = map hex, (split(/\t/, (do $filename), 3))[0,1];
-  my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1);
+
+  my $str = char_range($h1, $h2);
 
   my $blk = $_;