dup saved_curcop in PL_parser

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

diff --git a/gv.c b/gv.c
index c22f73a..f24a7f1 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -99,6 +99,7 @@ Perl_gv_IOadd(pTHX_ register GV *gv)
                          PL_op->op_type ==  OP_REWINDDIR ||
                          PL_op->op_type ==  OP_CLOSEDIR ?
                          "dirhandle" : "filehandle";
+       /* diag_listed_as: Bad symbol for filehandle */
         Perl_croak(aTHX_ "Bad symbol for %s", fh);
     }
 
@@ -1087,6 +1088,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                             (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
                             (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
                    {
+                       /* diag_listed_as: Variable "%s" is not imported%s */
                        Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
                            sv_type == SVt_PVAV ? '@' :
                            sv_type == SVt_PVHV ? '%' : '$',
@@ -1232,10 +1234,22 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                if (strEQ(name2, "IG")) {
                    HV *hv;
                    I32 i;
-                   if (!PL_psig_ptr) {
-                       Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
-                       Newxz(PL_psig_name, SIG_SIZE, SV*);
+                   if (!PL_psig_name) {
+                       Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
                        Newxz(PL_psig_pend, SIG_SIZE, int);
+                       PL_psig_ptr = PL_psig_name + SIG_SIZE;
+                   } else {
+                       /* I think that the only way to get here is to re-use an
+                          embedded perl interpreter, where the previous
+                          use didn't clean up fully because
+                          PL_perl_destruct_level was 0. I'm not sure that we
+                          "support" that, in that I suspect in that scenario
+                          there are sufficient other garbage values left in the
+                          interpreter structure that something else will crash
+                          before we get here. I suspect that this is one of
+                          those "doctor, it hurts when I do this" bugs.  */
+                       Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
+                       Zero(PL_psig_pend, SIG_SIZE, int);
                    }
                    GvMULTI_on(gv);
                    hv = GvHVn(gv);
@@ -1244,9 +1258,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                        SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
                        if (init)
                            sv_setsv(*init, &PL_sv_undef);
-                       PL_psig_ptr[i] = 0;
-                       PL_psig_name[i] = 0;
-                       PL_psig_pend[i] = 0;
                    }
                }
                break;
@@ -1385,6 +1396,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        ro_magicalize:
            SvREADONLY_on(GvSVn(gv));
            /* FALL THROUGH */
+       case '0':
        case '1':
        case '2':
        case '3':
@@ -1652,9 +1664,14 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
 }
 
 /* Updates and caches the CV's */
+/* Returns:
+ * 1 on success and there is some overload
+ * 0 if there is no overload
+ * -1 if some error occurred and it couldn't croak
+ */
 
-bool
-Perl_Gv_AMupdate(pTHX_ HV *stash)
+int
+Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
 {
   dVAR;
   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
@@ -1669,7 +1686,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
       const AMT * const amtp = (AMT*)mg->mg_ptr;
       if (amtp->was_ok_am == PL_amagic_generation
          && amtp->was_ok_sub == newgen) {
-         return (bool)AMT_OVERLOADED(amtp);
+         return AMT_OVERLOADED(amtp) ? 1 : 0;
       }
       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
   }
@@ -1745,12 +1762,17 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
                                                       FALSE)))
                {
                    /* Can be an import stub (created by "can"). */
-                   const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
-                   Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
-                               "in package \"%.256s\"",
-                              (GvCVGEN(gv) ? "Stub found while resolving"
-                               : "Can't resolve"),
-                              name, cp, hvname);
+                   if (destructing) {
+                       return -1;
+                   }
+                   else {
+                       const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
+                       Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
+                                   "in package \"%.256s\"",
+                                  (GvCVGEN(gv) ? "Stub found while resolving"
+                                   : "Can't resolve"),
+                                  name, cp, hvname);
+                   }
                }
                cv = GvCV(gv = ngv);
            }
@@ -1780,7 +1802,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   AMT_AMAGIC_off(&amt);
   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
                                                (char*)&amt, sizeof(AMTS));
-  return FALSE;
+  return 0;
 }
 
 
@@ -1802,7 +1824,19 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
     if (!mg) {
       do_update:
-       Gv_AMupdate(stash);
+       /* If we're looking up a destructor to invoke, we must avoid
+        * that Gv_AMupdate croaks, because we might be dying already */
+       if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) {
+           /* and if it didn't found a destructor, we fall back
+            * to a simpler method that will only look for the
+            * destructor instead of the whole magic */
+           if (id == DESTROY_amg) {
+               GV * const gv = gv_fetchmethod(stash, "DESTROY");
+               if (gv)
+                   return GvCV(gv);
+           }
+           return NULL;
+       }
        mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
     }
     assert(mg);