z/OS: non-CPAN ext and lib + main() without the third arg + Stephen McCamant's comment

Message-ID: <44B67921.6090901@iki.fi>

p4raw-id: //depot/perl@28567

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"