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 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 <DATA> 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- a/lib/Pod/t/pod2html-lib.pl
+++ b/lib/Pod/t/pod2html-lib.pl
@@ -28,7 +28,7 @@ sub convert_n_test {
        $expect = <DATA>;
        $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 (file)
--- 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];