OS/390 cleanable gunk.

[p5sagit/p5-mst-13.2.git] / perl.c

diff --git a/perl.c b/perl.c
index 73212c0..8b3066e 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -21,7 +21,7 @@
 #include <unistd.h>
 #endif
 
-#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
+#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
 char *getenv (char *); /* Usually in <stdlib.h> */
 #endif
 
@@ -469,8 +469,10 @@ perl_destruct(pTHXx)
     }
 
     /* jettison our possibly duplicated environment */
-
-#ifdef USE_ENVIRON_ARRAY
+    /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
+     * so we certainly shouldn't free it here
+     */
+#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
     if (environ != PL_origenviron) {
        I32 i;
 
@@ -2189,8 +2191,10 @@ Perl_moreswitches(pTHX_ char *s)
        return s;
     case 'F':
        PL_minus_F = TRUE;
-       PL_splitstr = savepv(s + 1);
-       s += strlen(s);
+       PL_splitstr = ++s;
+       while (*s && !isSPACE(*s)) ++s;
+       *s = '\0';
+       PL_splitstr = savepv(PL_splitstr);
        return s;
     case 'a':
        PL_minus_a = TRUE;
@@ -2269,7 +2273,7 @@ Perl_moreswitches(pTHX_ char *s)
                s++;
        }
        return s;
-    case 'I':  /* -I handled both here and in parse_perl() */
+    case 'I':  /* -I handled both here and in parse_body() */
        forbid_setid("-I");
        ++s;
        while (*s && isSPACE(*s))
@@ -2766,6 +2770,11 @@ sed %s -e \"/^[^#]/b\" \
                Perl_croak(aTHX_ "Can't do seteuid!\n");
        }
 #endif /* IAMSUID */
+
+        DEBUG_P(PerlIO_printf(Perl_debug_log,
+                              "PL_preprocess: cmd=\"%s\"\n",
+                              SvPVX(cmd)));
+
        PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
        SvREFCNT_dec(cmd);
        SvREFCNT_dec(cpp);
@@ -3370,17 +3379,10 @@ S_init_predump_symbols(pTHX)
     PL_osname = savepv(OSNAME);
 }
 
-STATIC void
-S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
+void
+Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
 {
     char *s;
-    SV *sv;
-    GV* tmpgv;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
-    char **dup_env_base = 0;
-    int dup_env_count = 0;
-#endif
-
     argc--,argv++;     /* skip name of script */
     if (PL_doswitches) {
        for (; argc > 0 && **argv == '-'; argc--,argv++) {
@@ -3398,6 +3400,48 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
                sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
        }
     }
+    if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
+       GvMULTI_on(PL_argvgv);
+       (void)gv_AVadd(PL_argvgv);
+       av_clear(GvAVn(PL_argvgv));
+       for (; argc > 0; argc--,argv++) {
+           SV *sv = newSVpv(argv[0],0);
+           av_push(GvAVn(PL_argvgv),sv);
+           if (PL_widesyscalls)
+               (void)sv_utf8_decode(sv);
+       }
+    }
+}
+
+#ifdef HAS_PROCSELFEXE
+/* This is a function so that we don't hold on to MAXPATHLEN
+   bytes of stack longer than necessary
+ */
+STATIC void
+S_procself_val(pTHX_ SV *sv, char *arg0)
+{
+    char buf[MAXPATHLEN];
+    int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+    if (len > 0) {
+       sv_setpvn(sv,buf,len);
+    }
+    else {
+       sv_setpv(sv,arg0);
+    }
+}
+#endif /* HAS_PROCSELFEXE */
+
+STATIC void
+S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
+{
+    char *s;
+    SV *sv;
+    GV* tmpgv;
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+    char **dup_env_base = 0;
+    int dup_env_count = 0;
+#endif
+
     PL_toptarget = NEWSV(0,0);
     sv_upgrade(PL_toptarget, SVt_PVFM);
     sv_setpvn(PL_toptarget, "", 0);
@@ -3407,6 +3451,9 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
     PL_formtarget = PL_bodytarget;
 
     TAINT;
+
+    init_argv_symbols(argc,argv);
+
     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
 #ifdef MACOS_TRADITIONAL
        /* $0 is not majick on a Mac */
@@ -3416,22 +3463,16 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
        magicname("0", "0", 1);
 #endif
     }
-    if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
+    if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
+#ifdef HAS_PROCSELFEXE
+       S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+#else
 #ifdef OS2
        sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
 #else
        sv_setpv(GvSV(tmpgv),PL_origargv[0]);
 #endif
-    if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
-       GvMULTI_on(PL_argvgv);
-       (void)gv_AVadd(PL_argvgv);
-       av_clear(GvAVn(PL_argvgv));
-       for (; argc > 0; argc--,argv++) {
-           SV *sv = newSVpv(argv[0],0);
-           av_push(GvAVn(PL_argvgv),sv);
-           if (PL_widesyscalls)
-               (void)sv_utf8_decode(sv);
-       }
+#endif
     }
     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
        HV *hv;
@@ -3491,8 +3532,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 #endif /* USE_ENVIRON_ARRAY */
     }
     TAINT_NOT;
-    if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
+    if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+        SvREADONLY_off(GvSV(tmpgv));
        sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
+        SvREADONLY_on(GvSV(tmpgv));
+    }
 }
 
 STATIC void