summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ext/B/B/Deparse.pm2
-rwxr-xr-xlib/AutoLoader.t2
-rw-r--r--lib/DBM_Filter/t/encode.t27
-rw-r--r--lib/DBM_Filter/t/utf8.t24
-rw-r--r--lib/ExtUtils/Constant/Utils.pm12
-rw-r--r--lib/ExtUtils/Embed.pm6
-rw-r--r--lib/ExtUtils/t/Embed.t17
-rw-r--r--lib/PerlIO/via/t/QuotedPrint.t12
-rw-r--r--lib/bytes.t17
-rw-r--r--lib/dumpvar.pl31
-rw-r--r--lib/utf8.t18
-rw-r--r--miniperlmain.c12
-rw-r--r--perl.h4
13 files changed, 147 insertions, 37 deletions
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index a9abfec268..6bb2f683f2 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -3588,7 +3588,7 @@ sub const {
return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
} elsif ($sv->FLAGS & SVf_POK) {
my $str = $sv->PV;
- if ($str =~ /[^ -~]/) { # ASCII for non-printing
+ if ($str =~ /[[:^print:]]/) {
return single_delim("qq", '"', uninterp escape_str unback $str);
} else {
return single_delim("q", "'", unback $str);
diff --git a/lib/AutoLoader.t b/lib/AutoLoader.t
index 9f0804b004..da7071b32b 100755
--- a/lib/AutoLoader.t
+++ b/lib/AutoLoader.t
@@ -121,7 +121,7 @@ is( $foo->bazmarkhianish($1), 'foo', '(again)' );
eval {
$foo->blechanawilla;
};
-like( $@, qr/syntax error/, 'require error propagates' );
+like( $@, qr/syntax error/i, 'require error propagates' );
# test recursive autoloads
open(F, '>', File::Spec->catfile( $fulldir, 'a.al'))
diff --git a/lib/DBM_Filter/t/encode.t b/lib/DBM_Filter/t/encode.t
index 7b71a98b2e..2c3ee0bf43 100644
--- a/lib/DBM_Filter/t/encode.t
+++ b/lib/DBM_Filter/t/encode.t
@@ -87,14 +87,25 @@ my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db2, "tied to SDBM_File";
-VerifyData(\%h2,
- {
- 'alpha' => "\xCE\xB1",
- 'beta' => "\xCE\xB2",
- "\xCE\xB3"=> "gamma",
- 'euro' => "\xA4",
- "" => "",
- });
+if (ord('A') == 193) { # EBCDIC.
+ VerifyData(\%h2,
+ {
+ 'alpha' => "\xB4\x58",
+ 'beta' => "\xB4\x59",
+ "\xB4\x62"=> "gamma",
+ "\x65\x75\x72\x6F" => "\xA4",
+ "" => "",
+ });
+} else {
+ VerifyData(\%h2,
+ {
+ 'alpha' => "\xCE\xB1",
+ 'beta' => "\xCE\xB2",
+ "\xCE\xB3"=> "gamma",
+ 'euro' => "\xA4",
+ "" => "",
+ });
+}
undef $db2;
{
diff --git a/lib/DBM_Filter/t/utf8.t b/lib/DBM_Filter/t/utf8.t
index e37afa2d4a..f884e04eea 100644
--- a/lib/DBM_Filter/t/utf8.t
+++ b/lib/DBM_Filter/t/utf8.t
@@ -69,13 +69,23 @@ my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db2, "tied to SDBM_File";
-VerifyData(\%h2,
- {
- 'alpha' => "\xCE\xB1",
- 'beta' => "\xCE\xB2",
- "\xCE\xB3"=> "gamma",
- "" => "",
- });
+if (ord('A') == 193) { # EBCDIC.
+ VerifyData(\%h2,
+ {
+ 'alpha' => "\xB4\x58",
+ 'beta' => "\xB4\x59",
+ "\xB4\x62"=> "gamma",
+ "" => "",
+ });
+} else {
+ VerifyData(\%h2,
+ {
+ 'alpha' => "\xCE\xB1",
+ 'beta' => "\xCE\xB2",
+ "\xCE\xB3"=> "gamma",
+ "" => "",
+ });
+}
undef $db2;
{
diff --git a/lib/ExtUtils/Constant/Utils.pm b/lib/ExtUtils/Constant/Utils.pm
index 3ef2228c87..2a0625e451 100644
--- a/lib/ExtUtils/Constant/Utils.pm
+++ b/lib/ExtUtils/Constant/Utils.pm
@@ -54,7 +54,11 @@ sub C_stringify {
s/\t/\\t/g;
s/\f/\\f/g;
s/\a/\\a/g;
- s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
+ if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
+ s/([[:^print:]])/sprintf "\\x{%X}", ord $1/ge;
+ } else {
+ s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
+ }
unless ($] < 5.006) {
# This will elicit a warning on 5.005_03 about [: :] being reserved unless
# I cheat
@@ -87,7 +91,11 @@ sub perl_stringify {
s/\a/\\a/g;
unless ($] < 5.006) {
if ($] > 5.007) {
- s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
+ if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
+ s/([[:^print:]])/sprintf "\\x{%X}", ord $1/ge;
+ } else {
+ s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
+ }
} else {
# Grr 5.6.1. And I don't think I can use utf8; to force the regexp
# because 5.005_03 will fail.
diff --git a/lib/ExtUtils/Embed.pm b/lib/ExtUtils/Embed.pm
index 79bca4dfe2..78451c7d8f 100644
--- a/lib/ExtUtils/Embed.pm
+++ b/lib/ExtUtils/Embed.pm
@@ -225,11 +225,13 @@ sub ldopts {
if ($^O eq 'MSWin32') {
$libperl = $Config{libperl};
}
- else {
+ elsif ($^O eq 'os390' && $Config{usedl}) {
+ # Nothing for OS/390 (z/OS) dynamic.
+ } else {
$libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0]
|| ($Config{libperl} =~ /^lib(\w+)(\Q$lib_ext\E|\.\Q$Config{dlext}\E)$/
? "-l$1" : '')
- || "-lperl";
+ || "-lperl";
}
my $lpath = File::Spec->catdir($Config{archlibexp}, 'CORE');
diff --git a/lib/ExtUtils/t/Embed.t b/lib/ExtUtils/t/Embed.t
index 3f4c28628c..a7ebaa2a9c 100644
--- a/lib/ExtUtils/t/Embed.t
+++ b/lib/ExtUtils/t/Embed.t
@@ -79,7 +79,9 @@ if ($^O eq 'VMS') {
push(@cmd,"-L$lib",File::Spec->catfile($lib,$Config{'libperl'}),$Config{'libc'});
}
}
- else { # Not MSWin32.
+ elsif ($^O eq 'os390' && $Config{usedl}) {
+ # Nothing for OS/390 (z/OS) dynamic.
+ } else { # Not MSWin32 or OS/390 (z/OS) dynamic.
push(@cmd,"-L$lib",'-lperl');
local $SIG{__WARN__} = sub {
warn $_[0] unless $_[0] =~ /No library found for .*perl/
@@ -164,7 +166,12 @@ static struct perl_vars *my_plvarsp;
struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; }
#endif
+#ifdef NO_ENV_ARRAY_IN_MAIN
+extern char **environ;
+int main(int argc, char **argv)
+#else
int main(int argc, char **argv, char **env)
+#endif
{
PerlInterpreter *my_perl;
#ifdef PERL_GLOBAL_STRUCT
@@ -177,7 +184,11 @@ int main(int argc, char **argv, char **env)
(void)argc; /* PERL_SYS_INIT3 may #define away their use */
(void)argv;
+#ifdef NO_ENV_ARRAY_IN_MAIN
+ PERL_SYS_INIT3(&argc,&argv,&environ);
+#else
PERL_SYS_INIT3(&argc,&argv,&env);
+#endif
my_perl = perl_alloc();
@@ -187,7 +198,11 @@ int main(int argc, char **argv, char **env)
my_puts("ok 3");
+#ifdef NO_ENV_ARRAY_IN_MAIN
+ perl_parse(my_perl, NULL, (sizeof(cmds)/sizeof(char *))-1, cmds, environ);
+#else
perl_parse(my_perl, NULL, (sizeof(cmds)/sizeof(char *))-1, cmds, env);
+#endif
my_puts("ok 4");
diff --git a/lib/PerlIO/via/t/QuotedPrint.t b/lib/PerlIO/via/t/QuotedPrint.t
index baf0d1f4e4..40bca4fe60 100644
--- a/lib/PerlIO/via/t/QuotedPrint.t
+++ b/lib/PerlIO/via/t/QuotedPrint.t
@@ -30,11 +30,21 @@ This is a tést for quoted-printable text that has hàrdly any speçial characters
in it.
EOD
-my $encoded = <<EOD;
+my $encoded;
+
+if (ord('A') == 193) { # EBCDIC.
+ $encoded = <<EOD;
+This is a t=51st for quoted-printable text that has h=44rdly any spe=48ial =
+characters
+in it.
+EOD
+} else {
+ $encoded = <<EOD;
This is a t=E9st for quoted-printable text that has h=E0rdly any spe=E7ial =
characters
in it.
EOD
+}
# Create the encoded test-file
diff --git a/lib/bytes.t b/lib/bytes.t
index ea1b9f629b..c1ea9ead80 100644
--- a/lib/bytes.t
+++ b/lib/bytes.t
@@ -1,3 +1,4 @@
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
@@ -42,9 +43,19 @@ my $c = chr(0x100);
} else {
is(bytes::ord($c), 0xc4, "bytes::ord under use bytes looks at the 1st byte");
}
- is(bytes::substr($c, 0, 1), "\xc4", "bytes::substr under use bytes looks at bytes");
- is(bytes::index($c, "\x80"), 1, "bytes::index under use bytes looks at bytes");
- is(bytes::rindex($c, "\xc4"), 0, "bytes::rindex under use bytes looks at bytes");
+ # In z/OS \x41,\x8c are the codepoints corresponding to \x80,\xc4 respectively under ASCII platform
+ if (ord('A') == 193) { # EBCDIC?
+ is(bytes::substr($c, 0, 1), "\x8c", "bytes::substr under use bytes looks at bytes");
+ is(bytes::index($c, "\x41"), 1, "bytes::index under use bytes looks at bytes");
+ is(bytes::rindex($c, "\x8c"), 0, "bytes::rindex under use bytes looks at bytes");
+
+ }
+ else{
+ is(bytes::substr($c, 0, 1), "\xc4", "bytes::substr under use bytes looks at bytes");
+ is(bytes::index($c, "\x80"), 1, "bytes::index under use bytes looks at bytes");
+ is(bytes::rindex($c, "\xc4"), 0, "bytes::rindex under use bytes looks at bytes");
+ }
+
}
{
diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl
index fa5b4dfb47..0268cea8bc 100644
--- a/lib/dumpvar.pl
+++ b/lib/dumpvar.pl
@@ -41,7 +41,12 @@ sub unctrl {
local($v) ;
return \$_ if ref \$_ eq "GLOB";
- s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ if (ord('A') == 193) { # EBCDIC.
+ # EBCDIC has no concept of "\cA" or "A" being related
+ # to each other by a linear/boolean mapping.
+ } else {
+ s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ }
$_;
}
@@ -63,11 +68,19 @@ sub stringify {
and %overload:: and defined &{'overload::StrVal'};
if ($tick eq 'auto') {
- if (/[\000-\011\013-\037\177]/) {
- $tick = '"';
- }else {
- $tick = "'";
- }
+ if (ord('A') == 193) {
+ if (/[\000-\011]/ or /[\013-\024\31-\037\177]/) {
+ $tick = '"';
+ } else {
+ $tick = "'";
+ }
+ } else {
+ if (/[\000-\011\013-\037\177]/) {
+ $tick = '"';
+ } else {
+ $tick = "'";
+ }
+ }
}
if ($tick eq "'") {
s/([\'\\])/\\$1/g;
@@ -80,7 +93,11 @@ sub stringify {
} elsif ($unctrl eq 'quote') {
s/([\"\\\$\@])/\\$1/g if $tick eq '"';
s/\033/\\e/g;
- s/([\000-\037\177])/'\\c'._escaped_ord($1)/eg;
+ if (ord('A') == 193) { # EBCDIC.
+ s/([\000-\037\177])/'\\c'.chr(193)/eg; # Unfinished.
+ } else {
+ s/([\000-\037\177])/'\\c'._escaped_ord($1)/eg;
+ }
}
$_ = uniescape($_);
s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
diff --git a/lib/utf8.t b/lib/utf8.t
index 81ebc22161..a5827f48c0 100644
--- a/lib/utf8.t
+++ b/lib/utf8.t
@@ -349,7 +349,11 @@ SKIP: {
ok( utf8::is_utf8($c), "utf8::is_utf8 unicode");
is(utf8::upgrade($a), 1, "utf8::upgrade basic");
- is(utf8::upgrade($b), 2, "utf8::upgrade beyond");
+ if (ord('A') == 193) { # EBCDIC.
+ is(utf8::upgrade($b), 1, "utf8::upgrade beyond");
+ } else {
+ is(utf8::upgrade($b), 2, "utf8::upgrade beyond");
+ }
is(utf8::upgrade($c), 2, "utf8::upgrade unicode");
is($a, "A", "basic");
@@ -381,7 +385,11 @@ SKIP: {
utf8::encode($c);
is($a, "A", "basic");
- is(length($b), 2, "beyond length");
+ if (ord('A') == 193) { # EBCDIC.
+ is(length($b), 1, "beyond length");
+ } else {
+ is(length($b), 2, "beyond length");
+ }
is(length($c), 2, "unicode length");
ok(utf8::valid($a), "utf8::valid basic");
@@ -406,7 +414,11 @@ SKIP: {
ok(utf8::valid($c), " utf8::valid unicode");
ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
- ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
+ if (ord('A') == 193) { # EBCDIC.
+ ok( utf8::is_utf8(pack('U',0x0ff)), " utf8::is_utf8 beyond");
+ } else {
+ ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
+ }
ok( utf8::is_utf8($c), " utf8::is_utf8 unicode");
}
diff --git a/miniperlmain.c b/miniperlmain.c
index 601008719f..ca27aaf545 100644
--- a/miniperlmain.c
+++ b/miniperlmain.c
@@ -53,8 +53,14 @@ static struct perl_vars* my_plvarsp;
struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; }
#endif
+#ifdef NO_ENV_ARRAY_IN_MAIN
+extern char **environ;
+int
+main(int argc, char **argv)
+#else
int
main(int argc, char **argv, char **env)
+#endif
{
dVAR;
int exitstatus;
@@ -73,7 +79,11 @@ main(int argc, char **argv, char **env)
/* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */
PERL_GPROF_MONCONTROL(0);
+#ifdef NO_ENV_ARRAY_IN_MAIN
+ PERL_SYS_INIT3(&argc,&argv,&environ);
+#else
PERL_SYS_INIT3(&argc,&argv,&env);
+#endif
#if defined(USE_ITHREADS)
/* XXX Ideally, this should really be happening in perl_alloc() or
@@ -106,7 +116,7 @@ main(int argc, char **argv, char **env)
perl_free(my_perl);
-#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL)
+#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL) && !defined(NO_ENV_ARRAY_IN_MAIN)
/*
* The old environment may have been freed by perl_free()
* when PERL_TRACK_MEMPOOL is defined, but without having
diff --git a/perl.h b/perl.h
index 94eb86085e..e4c8755df4 100644
--- a/perl.h
+++ b/perl.h
@@ -5595,6 +5595,10 @@ extern void moncontrol(int);
# define do_aexec(really, mark,sp) do_aexec5(really, mark, sp, 0, 0)
#endif
+#if defined(OEMVS)
+#define NO_ENV_ARRAY_IN_MAIN
+#endif
+
/* and finally... */
#define PERL_PATCHLEVEL_H_IMPLICIT
#include "patchlevel.h"
View Lorry Controller Status