Welcome to 2007! Time to update copyrights from changes earlier

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

diff --git a/gv.c b/gv.c
index 4187c18..4878d80 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -191,6 +191,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     const bool doproto = old_type > SVt_NULL;
     const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
+    const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 
     assert (!(proto && has_constant));
 
@@ -224,7 +225,8 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
        } else
            Safefree(SvPVX_mutable(gv));
     }
-    SvSCREAM_on(gv);
+    SvIOK_off(gv);
+    isGV_with_GP_on(gv);
 
     GvGP(gv) = Perl_newGP(aTHX_ gv);
     GvSTASH(gv) = stash;
@@ -234,11 +236,15 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     if (multi || doproto)              /* doproto means it _was_ mentioned */
        GvMULTI_on(gv);
     if (doproto) {                     /* Replicate part of newSUB here. */
-       SvIOK_off(gv);
        ENTER;
        if (has_constant) {
            /* newCONSTSUB takes ownership of the reference from us.  */
            GvCV(gv) = newCONSTSUB(stash, name, has_constant);
+           /* If this reference was a copy of another, then the subroutine
+              must have been "imported", by a Perl space assignment to a GV
+              from a reference to CV.  */
+           if (exported_constant)
+               GvIMPORTED_CV_on(gv);
        } else {
            /* XXX unsafe for threads if eval_owner isn't held */
            (void) start_subparse(0,0); /* Create empty CV in compcv. */
@@ -313,6 +319,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
     GV** gvp;
     CV* cv;
     const char *hvname;
+    HV* lastchance = NULL;
 
     /* UNIVERSAL methods should be callable without a stash */
     if (!stash) {
@@ -400,7 +407,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
     /* if at top level, try UNIVERSAL */
 
     if (level == 0 || level == -1) {
-       HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE);
+       lastchance = gv_stashpvs("UNIVERSAL", FALSE);
 
        if (lastchance) {
            if ((gv = gv_fetchmeth(lastchance, name, len,
@@ -654,7 +661,6 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     sv_setpvn(varsv, packname, packname_len);
     sv_catpvs(varsv, "::");
     sv_catpvn(varsv, name, len);
-    SvTAINTED_off(varsv);
     return gv;
 }
 
@@ -1188,10 +1194,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            goto magicalize;
 
        case '+':
+       GvMULTI_on(gv);
        {
            AV* const av = GvAVn(gv);
+           HV* const hv = GvHVn(gv);
             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
            SvREADONLY_on(av);
+           hv_magic(hv, NULL, PERL_MAGIC_regdata_names);
+           SvREADONLY_on(hv);
            /* FALL THROUGH */
        }
        case '\023':    /* $^S */
@@ -1432,7 +1442,8 @@ Perl_gp_free(pTHX_ GV *gv)
         return;
     }
 
-    unshare_hek(gp->gp_file_hek);
+    if (gp->gp_file_hek)
+       unshare_hek(gp->gp_file_hek);
     SvREFCNT_dec(gp->gp_sv);
     SvREFCNT_dec(gp->gp_av);
     /* FIXME - another reference loop GV -> symtab -> GV ?
@@ -1719,6 +1730,12 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
                 */
                SV* const newref = newSVsv(tmpRef);
                SvOBJECT_on(newref);
+               /* As a bit of a source compatibility hack, SvAMAGIC() and
+                  friends dereference an RV, to behave the same was as when
+                  overloading was stored on the reference, not the referant.
+                  Hence we can't use SvAMAGIC_on()
+               */
+               SvFLAGS(newref) |= SVf_AMAGIC;
                SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
                return newref;
             }
@@ -1829,6 +1846,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
        notfound = 1; lr = -1;
       } else if (cvp && (cv=cvp[nomethod_amg])) {
        notfound = 1; lr = 1;
+      } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
+       /* Skip generating the "no method found" message.  */
+       return NULL;
       } else {
        SV *msg;
        if (off==-1) off=method;