fix 2 environment handling bugs

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index 973a306..fa1407f 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1,7 +1,7 @@
 /*    perl.c
  *
  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -171,7 +171,12 @@ S_init_tls_and_interp(PerlInterpreter *my_perl)
        MUTEX_INIT(&PL_my_ctx_mutex);
 #  endif
     }
-    else {
+#if defined(USE_ITHREADS)
+    else
+#else
+    /* This always happens for non-ithreads  */
+#endif
+    {
        PERL_SET_THX(my_perl);
     }
 }
@@ -321,8 +326,8 @@ perl_construct(pTHXx)
     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);       /* ext/re needs these */
     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);       /* even without DEBUGGING. */
 #ifdef USE_ITHREADS
-    PL_regex_padav = newAV();
-    av_push(PL_regex_padav,(SV*)newAV());    /* First entry is an array of empty elements */
+    /* First entry is an array of empty elements */
+    Perl_av_create_and_push(aTHX_ &PL_regex_padav,(SV*)newAV());
     PL_regex_pad = AvARRAY(PL_regex_padav);
 #endif
 #ifdef USE_REENTRANT_API
@@ -580,6 +585,7 @@ perl_destruct(pTHXx)
 
     if (CALL_FPTR(PL_threadhook)(aTHX)) {
         /* Threads hook has vetoed further cleanup */
+       PL_veto_cleanup = TRUE;
         return STATUS_EXIT;
     }
 
@@ -1325,6 +1331,11 @@ Releases a Perl interpreter.  See L<perlembed>.
 void
 perl_free(pTHXx)
 {
+    dVAR;
+
+    if (PL_veto_cleanup)
+       return;
+
 #ifdef PERL_TRACK_MEMPOOL
     {
        /*
@@ -1381,7 +1392,7 @@ __attribute__((destructor))
 perl_fini(void)
 {
     dVAR;
-    if (PL_curinterp)
+    if (PL_curinterp  && !PL_veto_cleanup)
        FREE_THREAD_KEY;
 }
 
@@ -1545,8 +1556,10 @@ setuid perl scripts securely.\n");
                        break;
              }
         }
+
+#ifndef PERL_USE_SAFE_PUTENV
         /* Can we grab env area too to be used as the area for $0? */
-        if (s && PL_origenviron) {
+        if (s && PL_origenviron && !PL_use_safe_putenv) {
              if ((PL_origenviron[0] == s + 1)
                  ||
                  (aligned &&
@@ -1578,6 +1591,8 @@ setuid perl scripts securely.\n");
                   }
              }
         }
+#endif /* !defined(PERL_USE_SAFE_PUTENV) */
+
         PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
     }
 
@@ -1790,10 +1805,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
            {
                SV *opts_prog;
 
-               if (!PL_preambleav)
-                   PL_preambleav = newAV();
-               av_push(PL_preambleav,
-                       newSVpvs("use Config;"));
+               Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;"));
                if (*++s != ':')  {
                    STRLEN opts;
                
@@ -2054,18 +2066,11 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 
 #ifdef USE_SITECUSTOMIZE
     if (!minus_f) {
-       if (!PL_preambleav)
-           PL_preambleav = newAV();
-       av_unshift(PL_preambleav, 1);
-       (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
+       (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
+                                            Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
     }
 #endif
 
-    if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
-        PL_compiling.cop_warnings
-           = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
-    }
-
     if (!scriptname)
        scriptname = argv[0];
     if (PL_e_script) {
@@ -2477,33 +2482,46 @@ Perl_get_hv(pTHX_ const char *name, I32 create)
 /*
 =head1 CV Manipulation Functions
 
+=for apidoc p||get_cvn_flags
+
+Returns the CV of the specified Perl subroutine.  C<flags> are passed to
+C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
+exist then it will be declared (which has the same effect as saying
+C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
+then NULL is returned.
+
 =for apidoc p||get_cv
 
-Returns the CV of the specified Perl subroutine.  If C<create> is set and
-the Perl subroutine does not exist then it will be declared (which has the
-same effect as saying C<sub name;>).  If C<create> is not set and the
-subroutine does not exist then NULL is returned.
+Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
 
 =cut
 */
 
 CV*
-Perl_get_cv(pTHX_ const char *name, I32 create)
+Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
 {
-    GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
-    /* XXX unsafe for threads if eval_owner isn't held */
+    GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
     /* XXX this is probably not what they think they're getting.
      * It has the same effect as "sub name;", i.e. just a forward
      * declaration! */
-    if (create && !GvCVu(gv))
+    if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
+       SV *const sv = newSVpvn(name,len);
+       SvFLAGS(sv) |= flags & SVf_UTF8;
        return newSUB(start_subparse(FALSE, 0),
-                     newSVOP(OP_CONST, 0, newSVpv(name,0)),
+                     newSVOP(OP_CONST, 0, sv),
                      NULL, NULL);
+    }
     if (gv)
        return GvCVu(gv);
     return NULL;
 }
 
+CV*
+Perl_get_cv(pTHX_ const char *name, I32 flags)
+{
+    return get_cvn_flags(name, strlen(name), flags);
+}
+
 /* Be sure to refetch the stack pointer after calling these routines. */
 
 /*
@@ -3167,8 +3185,6 @@ Perl_moreswitches(pTHX_ char *s)
        return s;
     case 'A':
        forbid_setid('A', -1);
-       if (!PL_preambleav)
-           PL_preambleav = newAV();
        s++;
        {
            char * const start = s;
@@ -3185,7 +3201,7 @@ Perl_moreswitches(pTHX_ char *s)
            else if (*s != '\0') {
                Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start);
            }
-           av_push(PL_preambleav, sv);
+           Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
            return s;
        }
     case 'M':
@@ -3223,9 +3239,7 @@ Perl_moreswitches(pTHX_ char *s)
                sv_catpvs(sv,  "\0)");
            }
            s += strlen(s);
-           if (!PL_preambleav)
-               PL_preambleav = newAV();
-           av_push(PL_preambleav, sv);
+           Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
        }
        else
            Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
@@ -3299,7 +3313,7 @@ Perl_moreswitches(pTHX_ char *s)
 #endif
 
        PerlIO_printf(PerlIO_stdout(),
-                     "\n\nCopyright 1987-2006, Larry Wall\n");
+                     "\n\nCopyright 1987-2007, Larry Wall\n");
 #ifdef MACOS_TRADITIONAL
        PerlIO_printf(PerlIO_stdout(),
                      "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
@@ -3376,8 +3390,9 @@ this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n
 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
        my_exit(0);
     case 'w':
-       if (! (PL_dowarn & G_WARN_ALL_MASK))
+       if (! (PL_dowarn & G_WARN_ALL_MASK)) {
            PL_dowarn |= G_WARN_ON;
+       }
        s++;
        return s;
     case 'W':
@@ -4676,7 +4691,6 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
            environ[0] = NULL;
        }
        if (env) {
-          char** origenv = environ;
          char *s;
          SV *sv;
          for (; *env; env++) {
@@ -4691,11 +4705,6 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
            (void)hv_store(hv, *env, s - *env, sv, 0);
            if (env_is_not_environ)
                mg_set(sv);
-           if (origenv != environ) {
-             /* realloc has shifted us */
-             env = (env - origenv) + environ;
-             origenv = environ;
-           }
          }
       }
 #endif /* USE_ENVIRON_ARRAY */
@@ -5118,21 +5127,15 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
        if (PL_savebegin) {
            if (paramList == PL_beginav) {
                /* save PL_beginav for compiler */
-               if (! PL_beginav_save)
-                   PL_beginav_save = newAV();
-               av_push(PL_beginav_save, (SV*)cv);
+               Perl_av_create_and_push(aTHX_ &PL_beginav_save, (SV*)cv);
            }
            else if (paramList == PL_checkav) {
                /* save PL_checkav for compiler */
-               if (! PL_checkav_save)
-                   PL_checkav_save = newAV();
-               av_push(PL_checkav_save, (SV*)cv);
+               Perl_av_create_and_push(aTHX_ &PL_checkav_save, (SV*)cv);
            }
            else if (paramList == PL_unitcheckav) {
                /* save PL_unitcheckav for compiler */
-               if (! PL_unitcheckav_save)
-                   PL_unitcheckav_save = newAV();
-               av_push(PL_unitcheckav_save, (SV*)cv);
+               Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, (SV*)cv);
            }
        } else {
            if (!PL_madskills)