From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Wed, 12 Jul 2006 00:01:29 +0000 (+0300)
Subject: z/OS: t/ - mostly EBCDIC fixes
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=250d67eb8e42c118b44bb5437965a1f4a8a0d828;p=p5sagit%2Fp5-mst-13.2.git

z/OS: t/ - mostly EBCDIC fixes
Message-Id: <200607112101.k6BL1TGr321715@kosh.hut.fi>

p4raw-id: //depot/perl@28550
---

diff --git a/t/comp/parser.t b/t/comp/parser.t
index e1eff35..a050858 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 4de1a19..5d27ea5 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 b0308b0..503f6f7 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 a6eeeb5..c138491 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 88c0372..b7cdfb0 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 57c6a64..d58a87d 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 e4ba07f..0de38e1 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 c7dc49f..3881aec 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 33909c0..32a1826 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 d422bee..b906285 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 aad638d..e27771b 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 fa4cbf5..225b770 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 = $_;