Create a new local $_ without triggering tie by using local *_ = \my $a

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

diff --git a/perl.c b/perl.c
index c707900..dfc2a3f 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -354,6 +354,10 @@ perl_destruct(pTHXx)
 
     /* Destroy the main CV and syntax tree */
     if (PL_main_root) {
+       /* ensure comppad/curpad to refer to main's pad */
+       if (CvPADLIST(PL_main_cv)) {
+           PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
+       }
        op_free(PL_main_root);
        PL_main_root = Nullop;
     }
@@ -377,6 +381,7 @@ perl_destruct(pTHXx)
         * Non-referenced objects are on their own.
         */
        sv_clean_objs();
+       PL_sv_objcount = 0;
     }
 
     /* unhook hooks which will soon be, or use, destroyed data */
@@ -502,6 +507,8 @@ perl_destruct(pTHXx)
        PL_e_script = Nullsv;
     }
 
+    PL_perldb = 0;
+
     /* magical thingies */
 
     SvREFCNT_dec(PL_ofs_sv);   /* $, */
@@ -561,6 +568,15 @@ perl_destruct(pTHXx)
     PL_stderrgv = Nullgv;
     PL_last_in_gv = Nullgv;
     PL_replgv = Nullgv;
+    PL_DBgv = Nullgv;
+    PL_DBline = Nullgv;
+    PL_DBsub = Nullgv;
+    PL_DBsingle = Nullsv;
+    PL_DBtrace = Nullsv;
+    PL_DBsignal = Nullsv;
+    PL_DBassertion = Nullsv;
+    PL_DBcv = Nullcv;
+    PL_dbargs = Nullav;
     PL_debstash = Nullhv;
 
     /* reset so print() ends up where we expect */
@@ -595,6 +611,7 @@ perl_destruct(pTHXx)
     Safefree(PL_numeric_name);
     PL_numeric_name = Nullch;
     SvREFCNT_dec(PL_numeric_radix_sv);
+    PL_numeric_radix_sv = Nullsv;
 #endif
 
     /* clear utf8 character classes */
@@ -733,6 +750,7 @@ perl_destruct(pTHXx)
 #ifdef USE_ITHREADS
     /* free the pointer table used for cloning */
     ptr_table_free(PL_ptr_table);
+    PL_ptr_table = (PTR_TBL_t*)NULL;
 #endif
 
     /* free special SVs */
@@ -776,6 +794,7 @@ perl_destruct(pTHXx)
        }
     }
 #endif
+    PL_sv_count = 0;
 
 
 #if defined(PERLIO_LAYERS)
@@ -790,22 +809,32 @@ perl_destruct(pTHXx)
     SvREFCNT(&PL_sv_undef) = 0;
     SvREADONLY_off(&PL_sv_undef);
 
-    SvREFCNT(&PL_sv_placeholder) = 0;
-    SvREADONLY_off(&PL_sv_placeholder);
-
     Safefree(PL_origfilename);
+    PL_origfilename = Nullch;
     Safefree(PL_reg_start_tmp);
+    PL_reg_start_tmp = (char**)NULL;
+    PL_reg_start_tmpl = 0;
     if (PL_reg_curpm)
        Safefree(PL_reg_curpm);
     Safefree(PL_reg_poscache);
     free_tied_hv_pool();
     Safefree(PL_op_mask);
     Safefree(PL_psig_ptr);
+    PL_psig_ptr = (SV**)NULL;
     Safefree(PL_psig_name);
+    PL_psig_name = (SV**)NULL;
     Safefree(PL_bitcount);
+    PL_bitcount = Nullch;
     Safefree(PL_psig_pend);
+    PL_psig_pend = (int*)NULL;
+    PL_formfeed = Nullsv;
+    Safefree(PL_ofmt);
+    PL_ofmt = Nullch;
     nuke_stacks();
+    PL_tainting = FALSE;
+    PL_taint_warn = FALSE;
     PL_hints = 0;              /* Reset hints. Should hints be per-interpreter ? */
+    PL_debug = 0;
 
     DEBUG_P(debprofdump());
 
@@ -910,11 +939,11 @@ setuid perl scripts securely.\n");
 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
     /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
      * This MUST be done before any hash stores or fetches take place.
-     * If you set PL_hash_seed (and assumedly also PL_hash_seed_set) yourself,
-     * it is your responsibility to provide a good random seed!
+     * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
+     * yourself, it is your responsibility to provide a good random seed!
      * You can also define PERL_HASH_SEED in compile time, see hv.h. */
-    if (!PL_hash_seed_set)
-        PL_hash_seed = get_hash_seed();
+    if (!PL_rehash_seed_set)
+        PL_rehash_seed = get_hash_seed();
     {
         char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
 
@@ -923,7 +952,7 @@ setuid perl scripts securely.\n");
 
              if (i == 1)
                   PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
-                                PL_hash_seed);
+                                PL_rehash_seed);
         }
     }
 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
@@ -934,7 +963,7 @@ setuid perl scripts securely.\n");
     {
        /* Set PL_origalen be the sum of the contiguous argv[]
         * elements plus the size of the env in case that it is
-        * contiguous with the argv[].  This is used in mg.c:mg_set()
+        * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
         * as the maximum modifiable length of $0.  In the worst case
         * the area we are able to modify is limited to the size of
         * the original argv[0].  (See below for 'contiguous', though.)
@@ -1015,7 +1044,7 @@ setuid perl scripts securely.\n");
                   }
              }
         }
-        PL_origalen = s - PL_origargv[0];
+        PL_origalen = s - PL_origargv[0] + 1;
     }
 
     if (PL_do_undump) {
@@ -1329,7 +1358,6 @@ print \"  \\@INC:\\n    @INC\\n\";");
        }
     }
   switch_end:
-    sv_setsv(get_sv("/", TRUE), PL_rs);
 
     if (
 #ifndef SECURE_INTERNAL_GETENV
@@ -1667,7 +1695,8 @@ S_run_body(pTHX_ I32 oldscope)
 
     if (!PL_restartop) {
        DEBUG_x(dump_all());
-       PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+       if (!DEBUG_q_TEST)
+         PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
        DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
                              PTR2UV(thr)));
 
@@ -2289,7 +2318,7 @@ Perl_get_debug_opts(pTHX_ char **s)
     int i = 0;
     if (isALPHA(**s)) {
        /* if adding extra options, remember to update DEBUG_MASK */
-       static char debopts[] = "psltocPmfrxu HXDSTRJvC";
+       static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
 
        for (; isALNUM(**s); (*s)++) {
            char *d = strchr(debopts,**s);
@@ -2359,6 +2388,7 @@ Perl_moreswitches(pTHX_ char *s)
                   PL_rs = newSVpvn(&ch, 1);
              }
         }
+        sv_setsv(get_sv("/", TRUE), PL_rs);
         return s + numlen;
     }
     case 'C':
@@ -3244,7 +3274,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
            PL_euid == PL_statbuf.st_uid)
            if (!PL_do_undump)
                Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
-FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
+FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
 #endif /* IAMSUID */
 
        if (PL_euid) {  /* oops, we're not the setuid root perl */
@@ -3512,7 +3542,7 @@ Perl_init_debugger(pTHX)
     sv_setiv(PL_DBtrace, 0);
     PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
     sv_setiv(PL_DBsignal, 0);
-    PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
+    PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
     sv_setiv(PL_DBassertion, 0);
     PL_curstash = ostash;
 }