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

diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index a9abfec..6bb2f68 100644 (file)
--- 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 9f0804b..da7071b 100755 (executable)
--- 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 7b71a98..2c3ee0b 100644 (file)
--- 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 e37afa2..f884e04 100644 (file)
--- 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 3ef2228..2a0625e 100644 (file)
--- 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 79bca4d..78451c7 100644 (file)
--- 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 3f4c286..a7ebaa2 100644 (file)
--- 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 baf0d1f..40bca4f 100644 (file)
--- a/lib/PerlIO/via/t/QuotedPrint.t
+++ b/lib/PerlIO/via/t/QuotedPrint.t
@@ -30,11 +30,21 @@ This is a t
 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 ea1b9f6..c1ea9ea 100644 (file)
--- 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 fa5b4df..0268cea 100644 (file)
--- 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 81ebc22..a5827f4 100644 (file)
--- 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 6010087..ca27aaf 100644 (file)
--- 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 94eb860..e4c8755 100644 (file)
--- 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"