summaryrefslogtreecommitdiff
path: root/ext
diff options
context:
space:
mode:
Diffstat (limited to 'ext')
-rw-r--r--ext/Data/Dumper/Dumper.xs13
-rwxr-xr-xext/Data/Dumper/t/dumper.t43
-rw-r--r--ext/Encode/Encode.xs3
-rw-r--r--ext/Encode/t/utf8strict.t27
-rw-r--r--ext/MIME/Base64/Base64.xs4
-rw-r--r--ext/Storable/t/downgrade.t7
-rw-r--r--ext/Storable/t/overload.t7
-rw-r--r--ext/threads/shared/shared.xs5
8 files changed, 85 insertions, 24 deletions
diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs
index 255a6d99eb..0c62250c54 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 8ab5f1ddcc..05e51a45c2 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 38e83dce5d..72a686ce39 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 b2bf6b39a0..37e771340f 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 795f9017d5..afbad93c52 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 a227360b24..d977a0007d 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 <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 31b861d5a2..ceac2b08dc 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 ec0c5c9ce0..1bdbb08a45 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;
View Lorry Controller Status