From: Jarkko Hietaniemi Date: Thu, 13 Jul 2006 23:10:27 +0000 (+0300) Subject: z/OS: CPAN-ized ext/ and lib/ X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cf0d1c66a0d97cdcc6938d91401fa36b9b5a67ac;p=p5sagit%2Fp5-mst-13.2.git z/OS: CPAN-ized ext/ and lib/ Message-ID: <44B6A8B3.5070605@iki.fi> p4raw-id: //depot/perl@28568 --- diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index 255a6d9..0c62250 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -138,7 +138,11 @@ esc_q_utf8(pTHX_ SV* sv, register const char *src, register STRLEN slen) for (s = src; s < send; s += UTF8SKIP(s)) { const UV k = utf8_to_uvchr((U8*)s, NULL); - if (k > 127) { +#ifdef EBCDIC + if (!isprint(k) || k > 256) { +#else + if (k > 127) { +#endif /* 4: \x{} then count the number of hex digits. */ grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 : #if UVSIZE == 4 @@ -172,7 +176,12 @@ esc_q_utf8(pTHX_ SV* sv, register const char *src, register STRLEN slen) *r++ = '\\'; *r++ = (char)k; } - else if (k < 0x80) + else +#ifdef EBCDIC + if (isprint(k) && k < 256) +#else + if (k < 0x80) +#endif *r++ = (char)k; else { /* The return value of sprintf() is unportable. diff --git a/ext/Data/Dumper/t/dumper.t b/ext/Data/Dumper/t/dumper.t index 8ab5f1d..05e51a4 100755 --- a/ext/Data/Dumper/t/dumper.t +++ b/ext/Data/Dumper/t/dumper.t @@ -48,7 +48,15 @@ sub TEST { : "not ok $TNUM$name\n--Expected--\n$WANT\n--Got--\n$@$t\n"); ++$TNUM; - eval "$t"; + if ($Is_ebcdic) { # EBCDIC. + if ($TNUM == 311 || $TNUM == 314) { + eval $string; + } else { + eval $t; + } + } else { + eval "$t"; + } print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n"; $t = eval $string; @@ -1285,20 +1293,37 @@ EOT #XXX} { - $b = "Bad. XS didn't escape dollar sign"; + if ($Is_ebcdic) { + $b = "Bad. XS didn't escape dollar sign"; +############# 322 + $WANT = <<"EOT"; # Careful. This is '' string written inside '' here doc +#\$VAR1 = '\$b\"\@\\\\\xB1'; +EOT + $a = "\$b\"\@\\\xB1\x{100}"; + chop $a; + TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; + if ($XS) { + $WANT = <<'EOT'; # While this is "" string written inside "" here doc +#$VAR1 = "\$b\"\@\\\x{b1}"; +EOT + TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; + } + } else { + $b = "Bad. XS didn't escape dollar sign"; ############# 322 - $WANT = <<"EOT"; # Careful. This is '' string written inside '' here doc + $WANT = <<"EOT"; # Careful. This is '' string written inside '' here doc #\$VAR1 = '\$b\"\@\\\\\xA3'; EOT - $a = "\$b\"\@\\\xA3\x{100}"; - chop $a; - TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; - if ($XS) { - $WANT = <<'EOT'; # While this is "" string written inside "" here doc + $a = "\$b\"\@\\\xA3\x{100}"; + chop $a; + TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; + if ($XS) { + $WANT = <<'EOT'; # While this is "" string written inside "" here doc #$VAR1 = "\$b\"\@\\\x{a3}"; EOT - TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; + TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; + } } # XS used to produce "$b\"' which is 4 chars, not 3. [ie wrongly qq(\$b\\\")] ############# 328 diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index 38e83dc..72a686c 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -481,7 +481,8 @@ CODE: /* Native bytes - can always encode */ U8 *d = (U8 *) SvGROW(dst, 2*slen+1); /* +1 or assertion will botch */ while (s < e) { - UV uv = NATIVE_TO_UNI((UV) *s++); + UV uv = NATIVE_TO_UNI((UV) *s); + s++; /* Above expansion of NATIVE_TO_UNI() is safer this way. */ if (UNI_IS_INVARIANT(uv)) *d++ = (U8)UTF_TO_NATIVE(uv); else { diff --git a/ext/Encode/t/utf8strict.t b/ext/Encode/t/utf8strict.t index b2bf6b3..37e7713 100644 --- a/ext/Encode/t/utf8strict.t +++ b/ext/Encode/t/utf8strict.t @@ -40,14 +40,25 @@ BEGIN { 0x0000FFFF => 1, # 5.3.1 ); $NTESTS += scalar keys %ORD; - %SEQ = ( - qq/ed 9f bf/ => 0, # 2.3.1 - qq/ee 80 80/ => 0, # 2.3.2 - qq/f4 8f bf bf/ => 0, # 2.3.3 - qq/f4 90 80 80/ => 1, # 2.3.4 -- out of range so NG - # "3 Malformed sequences" are checked by perl. - # "4 Overlong sequences" are checked by perl. - ); + if (ord('A') == 193) { + %SEQ = ( + qq/dd 64 73 73/ => 0, # 2.3.1 + qq/dd 67 41 41/ => 0, # 2.3.2 + qq/ee 42 73 73 73/ => 0, # 2.3.3 + qq/f4 90 80 80/ => 1, # 2.3.4 -- out of range so NG + # "3 Malformed sequences" are checked by perl. + # "4 Overlong sequences" are checked by perl. + ); + } else { + %SEQ = ( + qq/ed 9f bf/ => 0, # 2.3.1 + qq/ee 80 80/ => 0, # 2.3.2 + qq/f4 8f bf bf/ => 0, # 2.3.3 + qq/f4 90 80 80/ => 1, # 2.3.4 -- out of range so NG + # "3 Malformed sequences" are checked by perl. + # "4 Overlong sequences" are checked by perl. + ); + } $NTESTS += scalar keys %SEQ; } use strict; diff --git a/ext/MIME/Base64/Base64.xs b/ext/MIME/Base64/Base64.xs index 795f901..afbad93 100644 --- a/ext/MIME/Base64/Base64.xs +++ b/ext/MIME/Base64/Base64.xs @@ -258,7 +258,11 @@ decode_base64(sv) MODULE = MIME::Base64 PACKAGE = MIME::QuotedPrint +#ifdef EBCDIC +#define qp_isplain(c) ((c) == '\t' || ((!isprint(c) && (c) != '='))) +#else #define qp_isplain(c) ((c) == '\t' || (((c) >= ' ' && (c) <= '~') && (c) != '=')) +#endif SV* encode_qp(sv,...) diff --git a/ext/Storable/t/downgrade.t b/ext/Storable/t/downgrade.t index a227360..d977a00 100644 --- a/ext/Storable/t/downgrade.t +++ b/ext/Storable/t/downgrade.t @@ -217,11 +217,12 @@ if ($] >= 5.006) { if ($] > 5.007002) { print "# We have utf8 hashes, so test that the utf8 hashes in are valid\n"; my $hash = thaw_hash ('Hash with utf8 keys', \%U_HASH); + my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5"); for (keys %$hash) { my $l = 0 + /^\w+$/; my $r = 0 + $hash->{$_} =~ /^\w+$/; cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); - cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1); + cmp_ok ($l, '==', $_ eq "ch${a_circumflex}teau" ? 0 : 1); } if (eval "use Hash::Util; 1") { print "# We have Hash::Util, so test that the restricted utf8 hash is valid\n"; @@ -230,7 +231,7 @@ if ($] > 5.007002) { my $l = 0 + /^\w+$/; my $r = 0 + $hash->{$_} =~ /^\w+$/; cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); - cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1); + cmp_ok ($l, '==', $_ eq "ch${a_circumflex}teau" ? 0 : 1); } test_locked_hash ($hash); } else { @@ -391,7 +392,7 @@ begin 301 Locked hash end begin 301 Locked hash placeholder -C!049`0````(.%`````69I).%H@H%F:23A:(`````!)>%F9,` +C!049`0````(.%`````69I).%H@H%F:23A:($````!)>%F9,` end diff --git a/ext/Storable/t/overload.t b/ext/Storable/t/overload.t index 31b861d..ceac2b0 100644 --- a/ext/Storable/t/overload.t +++ b/ext/Storable/t/overload.t @@ -88,7 +88,12 @@ ok 11, "$b->{ref}->{over}" eq "$b"; ok 12, $b + $b == 314; # nfreeze data generated by make_overload.pl -my $f = unpack 'u', q{7!084$0Q(05-?3U9%4DQ/040*!'-N;W<`}; +my $f = ''; +if (ord ('A') == 193) { # EBCDIC. + $f = unpack 'u', q{7!084$0S(P>)MUN7%V=/6P<0*!**5EJ8`}; +}else { + $f = unpack 'u', q{7!084$0Q(05-?3U9%4DQ/040*!'-N;W<`}; +} # see note at the end of do_retrieve in Storable.xs about why this test has to # use a reference to an overloaded reference, rather than just a reference. diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index ec0c5c9..1bdbb08 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -587,6 +587,11 @@ Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) switch (pthread_cond_timedwait(cond, mut, &ts)) { case 0: got_it = 1; break; case ETIMEDOUT: break; +#ifdef OEMVS + case -1: + if (errno == ETIMEDOUT || errno == EAGAIN) + break; +#endif default: Perl_croak_nocontext("panic: cond_timedwait"); break; diff --git a/lib/CGI/t/util-58.t b/lib/CGI/t/util-58.t index 70a6189..4751b4c 100644 --- a/lib/CGI/t/util-58.t +++ b/lib/CGI/t/util-58.t @@ -11,6 +11,11 @@ BEGIN { use Test::More tests => 2; use_ok("CGI::Util"); my $uri = "\x{5c0f}\x{98fc} \x{5f3e}.txt"; # KOGAI, Dan, in Kanji -is(CGI::Util::escape($uri), "%E5%B0%8F%E9%A3%BC%20%E5%BC%BE.txt", - "# Escape string with UTF-8 flag"); +if (ord('A') == 193) { # EBCDIC. + is(CGI::Util::escape($uri), "%FC%C3%A0%EE%F9%E5%E7%F8%20%FC%C3%C7%CA.txt", + "# Escape string with UTF-8 (UTF-EBCDIC) flag"); +} else { + is(CGI::Util::escape($uri), "%E5%B0%8F%E9%A3%BC%20%E5%BC%BE.txt", + "# Escape string with UTF-8 flag"); +} __END__ diff --git a/lib/Digest/t/base.t b/lib/Digest/t/base.t index c398346..b2614f7 100644 --- a/lib/Digest/t/base.t +++ b/lib/Digest/t/base.t @@ -32,17 +32,25 @@ plan tests => 12; my $ctx = LenDigest->new; ok($ctx->digest, "X0000"); -ok($ctx->hexdigest, "5830303030"); -ok($ctx->b64digest, "WDAwMDA"); + +my $EBCDIC = ord('A') == 193; + +if ($EBCDIC) { + ok($ctx->hexdigest, "e7f0f0f0f0"); + ok($ctx->b64digest, "5/Dw8PA"); +} else { + ok($ctx->hexdigest, "5830303030"); + ok($ctx->b64digest, "WDAwMDA"); +} $ctx->add("foo"); ok($ctx->digest, "f0003"); $ctx->add("foo"); -ok($ctx->hexdigest, "6630303033"); +ok($ctx->hexdigest, $EBCDIC ? "86f0f0f0f3" : "6630303033"); $ctx->add("foo"); -ok($ctx->b64digest, "ZjAwMDM"); +ok($ctx->b64digest, $EBCDIC ? "hvDw8PM" : "ZjAwMDM"); open(F, ">xxtest$$") || die; binmode(F); @@ -61,7 +69,7 @@ eval { }; ok($@ =~ /^Number of bits must be multiple of 8/); -$ctx->add_bits("01010101"); +$ctx->add_bits($EBCDIC ? "11100100" : "01010101"); ok($ctx->digest, "U0001"); eval { diff --git a/lib/Digest/t/file.t b/lib/Digest/t/file.t index 2184ac2..f431a38 100644 --- a/lib/Digest/t/file.t +++ b/lib/Digest/t/file.t @@ -37,8 +37,14 @@ print F "foo\0\n"; close(F) || die "Can't write '$file': $!"; ok(digest_file($file, "Foo"), "0005"); -ok(digest_file_hex($file, "Foo"), "30303035"); -ok(digest_file_base64($file, "Foo"), "MDAwNQ"); + +if (ord('A') == 193) { # EBCDIC. + ok(digest_file_hex($file, "Foo"), "f0f0f0f5"); + ok(digest_file_base64($file, "Foo"), "8PDw9Q"); +} else { + ok(digest_file_hex($file, "Foo"), "30303035"); + ok(digest_file_base64($file, "Foo"), "MDAwNQ"); +} unlink($file) || warn "Can't unlink '$file': $!"; diff --git a/lib/Pod/t/pod2html-lib.pl b/lib/Pod/t/pod2html-lib.pl index 7443fe0..db33f7d 100644 --- a/lib/Pod/t/pod2html-lib.pl +++ b/lib/Pod/t/pod2html-lib.pl @@ -28,7 +28,7 @@ sub convert_n_test { $expect = ; $expect =~ s/\[PERLADMIN\]/$Config::Config{perladmin}/; if (ord("A") == 193) { # EBCDIC. - $expect =~ s/item_mat%3c%21%3e/item_mat%4c%5a%6e/; + $expect =~ s/item_mat_3c_21_3e/item_mat_4c_5a_6e/; } # result diff --git a/lib/Tie/File/t/09_gen_rs.t b/lib/Tie/File/t/09_gen_rs.t index 041131f..e590210 100644 --- a/lib/Tie/File/t/09_gen_rs.t +++ b/lib/Tie/File/t/09_gen_rs.t @@ -4,6 +4,8 @@ my $file = "tf$$.txt"; print "1..59\n"; +use Fcntl 'O_RDONLY'; + my $N = 1; use Tie::File; print "ok $N\n"; $N++; @@ -148,7 +150,7 @@ if (setup_badly_terminated_file(2)) { # termination. $badrec = "world${RECSEP}hello"; if (setup_badly_terminated_file(1)) { - tie(@a, "Tie::File", $file, mode => 0, recsep => $RECSEP) + tie(@a, "Tie::File", $file, mode => O_RDONLY, recsep => $RECSEP) or die "Couldn't tie file: $!"; my $z = $#a; $z = $a[1];