autoloaded DESTROY bugfix

   Message-Id: <20020226195431.A9625@math.ohio-state.edu>
p4raw-link: @14577 on //depot/perl: 0ad5258ff3f3328f321188cbb4fcd6a74b365431

p4raw-id: //depot/perl@14920

diff --git a/embed.fnc b/embed.fnc
index a16b325..a94654f 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -249,6 +249,8 @@ Ap  |void   |gv_efullname4  |SV* sv|GV* gv|const char* prefix|bool keepmain
 Ap     |GV*    |gv_fetchfile   |const char* name
 Apd    |GV*    |gv_fetchmeth   |HV* stash|const char* name|STRLEN len \
                                |I32 level
+Apd    |GV*    |gv_fetchmeth_autoload  |HV* stash|const char* name|STRLEN len \
+                               |I32 level
 Apd    |GV*    |gv_fetchmethod |HV* stash|const char* name
 Apd    |GV*    |gv_fetchmethod_autoload|HV* stash|const char* name \
                                |I32 autoload

diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index c8f0eb9..ec84a50 100644 (file)
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -968,6 +968,8 @@ sub AUTOLOAD {
     }
 }
 
+sub DESTROY {} #       Do not AUTOLOAD
+
 # $root should be the op which represents the root of whatever
 # we're sequencing here. If it's undefined, then we don't append
 # any subroutine declarations to the deparsed ops, otherwise we

diff --git a/gv.c b/gv.c
index 08a103c..aaf505c 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -310,6 +310,50 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 }
 
 /*
+=for apidoc gv_fetchmeth_autoload
+
+Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
+Returns a glob for the subroutine.
+
+For an autoloaded subroutine without a GV, will create a GV even
+if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
+of the result may be zero.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
+{
+    GV *gv = gv_fetchmeth(stash, name, len, level);
+
+    if (!gv) {
+       char autoload[] = "AUTOLOAD";
+       STRLEN autolen = sizeof(autoload)-1;
+       CV *cv;
+       GV **gvp;
+
+       if (!stash)
+           return Nullgv;      /* UNIVERSAL::AUTOLOAD could cause trouble */
+       if (len == autolen && strnEQ(name, autoload, autolen))
+           return Nullgv;
+       if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
+           return Nullgv;
+       cv = GvCV(gv);
+       if (!(CvROOT(cv) || CvXSUB(cv)))
+           return Nullgv;
+       /* Have an autoload */
+       if (level < 0)  /* Cannot do without a stub */
+           gv_fetchmeth(stash, name, len, 0);
+       gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
+       if (!gvp)
+           return Nullgv;
+       return *gvp;
+    }
+    return gv;
+}
+
+/*
 =for apidoc gv_fetchmethod
 
 See L<gv_fetchmethod_autoload>.
@@ -1295,12 +1339,23 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 
        DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
                     cp, HvNAME(stash)) );
-       /* don't fill the cache while looking up! */
-       gv = gv_fetchmeth(stash, cooky, l, -1);
+       /* don't fill the cache while looking up!
+          Creation of inheritance stubs in intermediate packages may
+          conflict with the logic of runtime method substitution.
+          Indeed, for inheritance A -> B -> C, if C overloads "+0",
+          then we could have created stubs for "(+0" in A and C too.
+          But if B overloads "bool", we may want to use it for
+          numifying instead of C's "+0". */
+       if (i >= DESTROY_amg)
+           gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
+       else                            /* Autoload taken care of below */
+           gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
         cv = 0;
         if (gv && (cv = GvCV(gv))) {
            if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
                && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
+               /* This is a hack to support autoloading..., while
+                  knowing *which* methods were declared as overloaded. */
                /* GvSV contains the name of the method. */
                GV *ngv = Nullgv;
                
@@ -1328,6 +1383,9 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
            filled = 1;
            if (i < DESTROY_amg)
                have_ovl = 1;
+       } else if (gv) {                /* Autoloaded... */
+           cv = (CV*)gv;
+           filled = 1;
        }
        amt.table[i]=(CV*)SvREFCNT_inc(cv);
     }