Add a parameter "destructing" to Gv_AMupdate()

This boolean parameter indicates if the function has been called
to update the overload magic table while looking up the DESTROY
method. In this case, it's probably best to avoid croaking if
those tables could not be updated (for example due to a method
that could not be loaded.)

diff --git a/embed.fnc b/embed.fnc
index 3ff1b89..8689af0 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -99,7 +99,7 @@ END_EXTERN_C
 START_EXTERN_C
 #  include "pp_proto.h"
 Ap     |SV*    |amagic_call    |NN SV* left|NN SV* right|int method|int dir
-Ap     |bool   |Gv_AMupdate    |NN HV* stash
+Ap     |bool   |Gv_AMupdate    |NN HV* stash|bool destructing
 ApR    |CV*    |gv_handler     |NULLOK HV* stash|I32 id
 : Used in perly.y
 p      |OP*    |append_elem    |I32 optype|NULLOK OP* first|NULLOK OP* last

diff --git a/embed.h b/embed.h
index 6f6877f..e702d32 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -2391,7 +2391,7 @@
 #define get_context            Perl_get_context
 #define set_context            Perl_set_context
 #define amagic_call(a,b,c,d)   Perl_amagic_call(aTHX_ a,b,c,d)
-#define Gv_AMupdate(a)         Perl_Gv_AMupdate(aTHX_ a)
+#define Gv_AMupdate(a,b)       Perl_Gv_AMupdate(aTHX_ a,b)
 #define gv_handler(a,b)                Perl_gv_handler(aTHX_ a,b)
 #ifdef PERL_CORE
 #define append_elem(a,b,c)     Perl_append_elem(aTHX_ a,b,c)

diff --git a/gv.c b/gv.c
index 24e11c1..ca8e7a7 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1666,7 +1666,7 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
 /* Updates and caches the CV's */
 
 bool
-Perl_Gv_AMupdate(pTHX_ HV *stash)
+Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
 {
   dVAR;
   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
@@ -1757,12 +1757,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 FALSE;
+                   }
+                   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);
            }
@@ -1814,7 +1819,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)) {
+           /* 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);

diff --git a/proto.h b/proto.h
index 427600e..f853470 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -131,7 +131,7 @@ PERL_CALLCONV SV*   Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int di
 #define PERL_ARGS_ASSERT_AMAGIC_CALL   \
        assert(left); assert(right)
 
-PERL_CALLCONV bool     Perl_Gv_AMupdate(pTHX_ HV* stash)
+PERL_CALLCONV bool     Perl_Gv_AMupdate(pTHX_ HV* stash, bool destructing)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GV_AMUPDATE   \
        assert(stash)

diff --git a/sv.h b/sv.h
index 8c83e9a..b10843e 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -915,7 +915,7 @@ the scalar's value cannot change unless written to.
 
 #define SvGAMAGIC(sv)           (SvGMAGICAL(sv) || SvAMAGIC(sv))
 
-#define Gv_AMG(stash)           (PL_amagic_generation && Gv_AMupdate(stash))
+#define Gv_AMG(stash)           (PL_amagic_generation && Gv_AMupdate(stash, FALSE))
 
 #define SvWEAKREF(sv)          ((SvFLAGS(sv) & (SVf_ROK|SVprv_WEAKREF)) \
                                  == (SVf_ROK|SVprv_WEAKREF))