Change 28550 by [EMAIL PROTECTED] on 2006/07/12 06:53:22
Subject: [PATCH] z/OS: t/ - mostly EBCDIC fixes
From: Jarkko Hietaniemi <[EMAIL PROTECTED]>
Date: Wed, 12 Jul 2006 00:01:29 +0300 (EEST)
Message-Id: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/t/comp/parser.t#23 edit
... //depot/perl/t/op/caller.t#13 edit
... //depot/perl/t/op/chop.t#20 edit
... //depot/perl/t/op/exec.t#24 edit
... //depot/perl/t/op/index.t#12 edit
... //depot/perl/t/op/pack.t#111 edit
... //depot/perl/t/op/pat.t#239 edit
... //depot/perl/t/op/sprintf.t#60 edit
... //depot/perl/t/op/utfhash.t#7 edit
... //depot/perl/t/run/fresh_perl.t#34 edit
... //depot/perl/t/uni/case.pl#11 edit
... //depot/perl/t/uni/class.t#9 edit
Differences ...
==== //depot/perl/t/comp/parser.t#23 (text) ====
Index: perl/t/comp/parser.t
--- perl/t/comp/parser.t#22~28404~ 2006-06-20 01:52:12.000000000 -0700
+++ perl/t/comp/parser.t 2006-07-11 23:53:22.000000000 -0700
@@ -135,7 +135,7 @@
{
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',
==== //depot/perl/t/op/caller.t#13 (text) ====
Index: perl/t/op/caller.t
--- perl/t/op/caller.t#12~28335~ 2006-05-29 15:58:46.000000000 -0700
+++ perl/t/op/caller.t 2006-07-11 23:53:22.000000000 -0700
@@ -77,15 +77,15 @@
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");
}
==== //depot/perl/t/op/chop.t#20 (xtext) ====
Index: perl/t/op/chop.t
--- perl/t/op/chop.t#19~26045~ 2005-11-08 06:24:39.000000000 -0800
+++ perl/t/op/chop.t 2006-07-11 23:53:22.000000000 -0700
@@ -183,7 +183,7 @@
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;
==== //depot/perl/t/op/exec.t#24 (xtext) ====
Index: perl/t/op/exec.t
--- perl/t/op/exec.t#23~25810~ 2005-10-20 15:38:36.000000000 -0700
+++ perl/t/op/exec.t 2006-07-11 23:53:22.000000000 -0700
@@ -96,7 +96,7 @@
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", $!, $!;
}
==== //depot/perl/t/op/index.t#12 (xtext) ====
Index: perl/t/op/index.t
--- perl/t/op/index.t#11~27116~ 2006-02-07 04:19:17.000000000 -0800
+++ perl/t/op/index.t 2006-07-11 23:53:22.000000000 -0700
@@ -86,8 +86,15 @@
}
{
- 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);
==== //depot/perl/t/op/pack.t#111 (xtext) ====
Index: perl/t/op/pack.t
--- perl/t/op/pack.t#110~25249~ 2005-07-31 23:57:09.000000000 -0700
+++ perl/t/op/pack.t 2006-07-11 23:53:22.000000000 -0700
@@ -1488,7 +1488,7 @@
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($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 @@
{
# 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');
+ }
}
{
==== //depot/perl/t/op/pat.t#239 (xtext) ====
Index: perl/t/op/pat.t
--- perl/t/op/pat.t#238~28548~ 2006-07-11 07:55:17.000000000 -0700
+++ perl/t/op/pat.t 2006-07-11 23:53:22.000000000 -0700
@@ -2639,7 +2639,11 @@
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";
}
==== //depot/perl/t/op/sprintf.t#60 (xtext) ====
Index: perl/t/op/sprintf.t
--- perl/t/op/sprintf.t#59~28411~ 2006-06-21 00:44:24.000000000 -0700
+++ perl/t/op/sprintf.t 2006-07-11 23:53:22.000000000 -0700
@@ -421,7 +421,7 @@
>%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 @@
>%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<
==== //depot/perl/t/op/utfhash.t#7 (text) ====
Index: perl/t/op/utfhash.t
--- perl/t/op/utfhash.t#6~22463~ 2004-03-07 13:34:01.000000000 -0800
+++ perl/t/op/utfhash.t 2006-07-11 23:53:22.000000000 -0700
@@ -175,6 +175,17 @@
}
{
+ 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 @@
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);
+}
==== //depot/perl/t/run/fresh_perl.t#34 (text) ====
Index: perl/t/run/fresh_perl.t
--- perl/t/run/fresh_perl.t#33~25239~ 2005-07-28 10:18:13.000000000 -0700
+++ perl/t/run/fresh_perl.t 2006-07-11 23:53:22.000000000 -0700
@@ -828,6 +828,12 @@
######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <[EMAIL PROTECTED]>
-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 @@
######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <[EMAIL PROTECTED]>
-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 @@
# 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/;
==== //depot/perl/t/uni/case.pl#11 (text) ====
Index: perl/t/uni/case.pl
--- perl/t/uni/case.pl#10~26036~ 2005-11-07 07:18:51.000000000 -0800
+++ perl/t/uni/case.pl 2006-07-11 23:53:22.000000000 -0700
@@ -78,6 +78,9 @@
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 @@
#
# 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
==== //depot/perl/t/uni/class.t#9 (text) ====
Index: perl/t/uni/class.t
--- perl/t/uni/class.t#8~25020~ 2005-06-30 03:01:55.000000000 -0700
+++ perl/t/uni/class.t 2006-07-11 23:53:22.000000000 -0700
@@ -50,7 +50,13 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 = $_;
End of Patch.
