This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
An implementation of change 29735 for blead (PL_curcop could be NULL)
[perl5.git] / gv.c
diff --git a/gv.c b/gv.c
index c36cef8..e4c59b5 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1,7 +1,7 @@
 /*    gv.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
 /*    gv.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -45,7 +45,7 @@ Perl_gv_SVadd(pTHX_ GV *gv)
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
        Perl_croak(aTHX_ "Bad symbol for scalar");
     if (!GvSV(gv))
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
        Perl_croak(aTHX_ "Bad symbol for scalar");
     if (!GvSV(gv))
-       GvSV(gv) = NEWSV(72,0);
+       GvSV(gv) = newSV(0);
     return gv;
 }
 #endif
     return gv;
 }
 #endif
@@ -73,13 +73,15 @@ Perl_gv_HVadd(pTHX_ register GV *gv)
 GV *
 Perl_gv_IOadd(pTHX_ register GV *gv)
 {
 GV *
 Perl_gv_IOadd(pTHX_ register GV *gv)
 {
+    dVAR;
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) {
 
         /*
          * if it walks like a dirhandle, then let's assume that
          * this is a dirhandle.
          */
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) {
 
         /*
          * if it walks like a dirhandle, then let's assume that
          * this is a dirhandle.
          */
-        const char *fh = PL_op->op_type == OP_READDIR ||
+       const char * const fh =
+                        PL_op->op_type ==  OP_READDIR ||
                          PL_op->op_type ==  OP_TELLDIR ||
                          PL_op->op_type ==  OP_SEEKDIR ||
                          PL_op->op_type ==  OP_REWINDDIR ||
                          PL_op->op_type ==  OP_TELLDIR ||
                          PL_op->op_type ==  OP_SEEKDIR ||
                          PL_op->op_type ==  OP_REWINDDIR ||
@@ -102,13 +104,14 @@ Perl_gv_IOadd(pTHX_ register GV *gv)
 GV *
 Perl_gv_fetchfile(pTHX_ const char *name)
 {
 GV *
 Perl_gv_fetchfile(pTHX_ const char *name)
 {
+    dVAR;
     char smallbuf[256];
     char *tmpbuf;
     STRLEN tmplen;
     GV *gv;
 
     if (!PL_defstash)
     char smallbuf[256];
     char *tmpbuf;
     STRLEN tmplen;
     GV *gv;
 
     if (!PL_defstash)
-       return Nullgv;
+       return NULL;
 
     tmplen = strlen(name) + 2;
     if (tmplen < sizeof smallbuf)
 
     tmplen = strlen(name) + 2;
     if (tmplen < sizeof smallbuf)
@@ -128,7 +131,7 @@ Perl_gv_fetchfile(pTHX_ const char *name)
        sv_setpvn(GvSV(gv), name, tmplen - 2);
 #endif
        if (PERLDB_LINE)
        sv_setpvn(GvSV(gv), name, tmplen - 2);
 #endif
        if (PERLDB_LINE)
-           hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
+           hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
     }
     if (tmpbuf != smallbuf)
        Safefree(tmpbuf);
     }
     if (tmpbuf != smallbuf)
        Safefree(tmpbuf);
@@ -154,14 +157,42 @@ Perl_gv_const_sv(pTHX_ GV *gv)
     return SvROK(gv) ? SvRV(gv) : NULL;
 }
 
     return SvROK(gv) ? SvRV(gv) : NULL;
 }
 
+GP *
+Perl_newGP(pTHX_ GV *const gv)
+{
+    GP *gp;
+    const char *const file
+       = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
+    STRLEN len = strlen(file);
+    U32 hash;
+
+    PERL_HASH(hash, file, len);
+
+    Newxz(gp, 1, GP);
+
+#ifndef PERL_DONT_CREATE_GVSV
+    gp->gv_sv = newSV(0);
+#endif
+
+    gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
+    /* XXX Ideally this cast would be replaced with a change to const char*
+       in the struct.  */
+    gp->gp_file_hek = share_hek(file, len, hash);
+    gp->gp_egv = gv;
+    gp->gp_refcnt = 1;
+
+    return gp;
+}
+
 void
 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 {
     dVAR;
 void
 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 {
     dVAR;
-    register GP *gp;
-    const bool doproto = SvTYPE(gv) > SVt_NULL;
+    const U32 old_type = SvTYPE(gv);
+    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 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));
 
 
     assert (!(proto && has_constant));
 
@@ -175,12 +206,18 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
        case SVt_PVIO:
             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
                       sv_reftype(has_constant, 0));
        case SVt_PVIO:
             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
                       sv_reftype(has_constant, 0));
+       default: NOOP;
        }
        SvRV_set(gv, NULL);
        SvROK_off(gv);
     }
 
        }
        SvRV_set(gv, NULL);
        SvROK_off(gv);
     }
 
-    sv_upgrade((SV*)gv, SVt_PVGV);
+
+    if (old_type < SVt_PVGV) {
+       if (old_type >= SVt_PV)
+           SvCUR_set(gv, 0);
+       sv_upgrade((SV*)gv, SVt_PVGV);
+    }
     if (SvLEN(gv)) {
        if (proto) {
            SvPV_set(gv, NULL);
     if (SvLEN(gv)) {
        if (proto) {
            SvPV_set(gv, NULL);
@@ -189,33 +226,26 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
        } else
            Safefree(SvPVX_mutable(gv));
     }
        } else
            Safefree(SvPVX_mutable(gv));
     }
-    Newxz(gp, 1, GP);
-    GvGP(gv) = gp_ref(gp);
-#ifdef PERL_DONT_CREATE_GVSV
-    GvSV(gv) = NULL;
-#else
-    GvSV(gv) = NEWSV(72,0);
-#endif
-    GvLINE(gv) = CopLINE(PL_curcop);
-    /* XXX Ideally this cast would be replaced with a change to const char*
-       in the struct.  */
-    GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
-    GvCVGEN(gv) = 0;
-    GvEGV(gv) = gv;
-    sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
+    SvIOK_off(gv);
+    isGV_with_GP_on(gv);
+
+    GvGP(gv) = Perl_newGP(aTHX_ gv);
     GvSTASH(gv) = stash;
     if (stash)
        Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
     GvSTASH(gv) = stash;
     if (stash)
        Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
-    GvNAME(gv) = savepvn(name, len);
-    GvNAMELEN(gv) = len;
+    gv_name_set(gv, name, len, GV_ADD);
     if (multi || doproto)              /* doproto means it _was_ mentioned */
        GvMULTI_on(gv);
     if (doproto) {                     /* Replicate part of newSUB here. */
     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);
        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. */
        } else {
            /* XXX unsafe for threads if eval_owner isn't held */
            (void) start_subparse(0,0); /* Create empty CV in compcv. */
@@ -251,6 +281,7 @@ S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
     case SVt_NULL:
     case SVt_PVCV:
     case SVt_PVFM:
     case SVt_NULL:
     case SVt_PVCV:
     case SVt_PVFM:
+    case SVt_PVGV:
        break;
     default:
        (void)GvSVn(gv);
        break;
     default:
        (void)GvSVn(gv);
@@ -282,12 +313,14 @@ obtained from the GV with the C<GvCV> macro.
 GV *
 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 {
 GV *
 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 {
+    dVAR;
     AV* av;
     GV* topgv;
     GV* gv;
     GV** gvp;
     CV* cv;
     const char *hvname;
     AV* av;
     GV* topgv;
     GV* gv;
     GV** gvp;
     CV* cv;
     const char *hvname;
+    HV* lastchance = NULL;
 
     /* UNIVERSAL methods should be callable without a stash */
     if (!stash) {
 
     /* UNIVERSAL methods should be callable without a stash */
     if (!stash) {
@@ -309,7 +342,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 
     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
     if (!gvp)
 
     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
     if (!gvp)
-       topgv = Nullgv;
+       topgv = NULL;
     else {
        topgv = *gvp;
        if (SvTYPE(topgv) != SVt_PVGV)
     else {
        topgv = *gvp;
        if (SvTYPE(topgv) != SVt_PVGV)
@@ -320,14 +353,14 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
                return topgv;
            /* Stale cached entry: junk it */
            SvREFCNT_dec(cv);
                return topgv;
            /* Stale cached entry: junk it */
            SvREFCNT_dec(cv);
-           GvCV(topgv) = cv = Nullcv;
+           GvCV(topgv) = cv = NULL;
            GvCVGEN(topgv) = 0;
        }
        else if (GvCVGEN(topgv) == PL_sub_generation)
            return 0;  /* cache indicates sub doesn't exist */
     }
 
            GvCVGEN(topgv) = 0;
        }
        else if (GvCVGEN(topgv) == PL_sub_generation)
            return 0;  /* cache indicates sub doesn't exist */
     }
 
-    gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
+    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
 
     /* create and re-create @.*::SUPER::ISA on demand */
     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
 
     /* create and re-create @.*::SUPER::ISA on demand */
@@ -339,15 +372,15 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 
            packlen -= 7;
            basestash = gv_stashpvn(hvname, packlen, TRUE);
 
            packlen -= 7;
            basestash = gv_stashpvn(hvname, packlen, TRUE);
-           gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
+           gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
            if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
            if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
-               gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
+               gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
                if (!gvp || !(gv = *gvp))
                    Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
                if (SvTYPE(gv) != SVt_PVGV)
                    gv_init(gv, stash, "ISA", 3, TRUE);
                SvREFCNT_dec(GvAV(gv));
                if (!gvp || !(gv = *gvp))
                    Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
                if (SvTYPE(gv) != SVt_PVGV)
                    gv_init(gv, stash, "ISA", 3, TRUE);
                SvREFCNT_dec(GvAV(gv));
-               GvAV(gv) = (AV*)SvREFCNT_inc(av);
+               GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
            }
        }
     }
            }
        }
     }
@@ -362,7 +395,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
            if (!basestash) {
                if (ckWARN(WARN_MISC))
                    Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
            if (!basestash) {
                if (ckWARN(WARN_MISC))
                    Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
-                       sv, hvname);
+                       SVfARG(sv), hvname);
                continue;
            }
            gv = gv_fetchmeth(basestash, name, len,
                continue;
            }
            gv = gv_fetchmeth(basestash, name, len,
@@ -375,7 +408,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) {
     /* 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,
 
        if (lastchance) {
            if ((gv = gv_fetchmeth(lastchance, name, len,
@@ -432,20 +465,20 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le
        GV **gvp;
 
        if (!stash)
        GV **gvp;
 
        if (!stash)
-           return Nullgv;      /* UNIVERSAL::AUTOLOAD could cause trouble */
+           return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
        if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
        if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
-           return Nullgv;
+           return NULL;
        if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
        if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
-           return Nullgv;
+           return NULL;
        cv = GvCV(gv);
        if (!(CvROOT(cv) || CvXSUB(cv)))
        cv = GvCV(gv);
        if (!(CvROOT(cv) || CvXSUB(cv)))
-           return Nullgv;
+           return NULL;
        /* 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)
        /* 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 NULL;
        return *gvp;
     }
     return gv;
        return *gvp;
     }
     return gv;
@@ -482,6 +515,7 @@ C<call_sv> apply equally to these functions.
 GV *
 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 {
 GV *
 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 {
+    dVAR;
     register const char *nend;
     const char *nsplit = NULL;
     GV* gv;
     register const char *nend;
     const char *nsplit = NULL;
     GV* gv;
@@ -503,7 +537,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
            --nsplit;
        if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
            /* ->SUPER::method should really be looked up in original stash */
            --nsplit;
        if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
            /* ->SUPER::method should really be looked up in original stash */
-           SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
+           SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
                                                  CopSTASHPV(PL_curcop)));
            /* __PACKAGE__::SUPER stash should be autovivified */
            stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
                                                  CopSTASHPV(PL_curcop)));
            /* __PACKAGE__::SUPER stash should be autovivified */
            stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
@@ -564,10 +598,10 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     GV* vargv;
     SV* varsv;
     const char *packname = "";
     GV* vargv;
     SV* varsv;
     const char *packname = "";
-    STRLEN packname_len;
+    STRLEN packname_len = 0;
 
     if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
 
     if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
-       return Nullgv;
+       return NULL;
     if (stash) {
        if (SvTYPE(stash) < SVt_PVHV) {
            packname = SvPV_const((SV*)stash, packname_len);
     if (stash) {
        if (SvTYPE(stash) < SVt_PVHV) {
            packname = SvPV_const((SV*)stash, packname_len);
@@ -579,11 +613,11 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
        }
     }
     if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
        }
     }
     if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
-       return Nullgv;
+       return NULL;
     cv = GvCV(gv);
 
     if (!(CvROOT(cv) || CvXSUB(cv)))
     cv = GvCV(gv);
 
     if (!(CvROOT(cv) || CvXSUB(cv)))
-       return Nullgv;
+       return NULL;
 
     /*
      * Inheriting AUTOLOAD for non-methods works ... for now.
 
     /*
      * Inheriting AUTOLOAD for non-methods works ... for now.
@@ -595,7 +629,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
          "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
             packname, (int)len, name);
 
          "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
             packname, (int)len, name);
 
-    if (CvXSUB(cv)) {
+    if (CvISXSUB(cv)) {
         /* rather than lookup/init $AUTOLOAD here
          * only to have the XSUB do another lookup for $AUTOLOAD
          * and split that value on the last '::',
         /* rather than lookup/init $AUTOLOAD here
          * only to have the XSUB do another lookup for $AUTOLOAD
          * and split that value on the last '::',
@@ -620,7 +654,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     if (!isGV(vargv)) {
        gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
 #ifdef PERL_DONT_CREATE_GVSV
     if (!isGV(vargv)) {
        gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
 #ifdef PERL_DONT_CREATE_GVSV
-       GvSV(vargv) = NEWSV(72,0);
+       GvSV(vargv) = newSV(0);
 #endif
     }
     LEAVE;
 #endif
     }
     LEAVE;
@@ -628,32 +662,47 @@ 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);
     sv_setpvn(varsv, packname, packname_len);
     sv_catpvs(varsv, "::");
     sv_catpvn(varsv, name, len);
-    SvTAINTED_off(varsv);
     return gv;
 }
 
     return gv;
 }
 
-/* The "gv" parameter should be the glob known to Perl code as *!
- * The scalar must already have been magicalized.
+
+/* require_tie_mod() internal routine for requiring a module
+ * that implements the logic of automatical ties like %! and %-
+ *
+ * The "gv" parameter should be the glob.
+ * "varpv" holds the name of the var, used for error messages
+ * "namesv" holds the module name
+ * "methpv" holds the method name to test for to check that things
+ *   are working reasonably close to as expected
+ * "flags" if flag & 1 then save the scalar before loading.
+ * For the protection of $! to work (it is set by this routine)
+ * the sv slot must already be magicalized.
  */
  */
-STATIC void
-S_require_errno(pTHX_ GV *gv)
+STATIC HV*
+S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
 {
     dVAR;
 {
     dVAR;
-    HV* stash = gv_stashpvs("Errno", FALSE);
-
-    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
+    HV* stash = gv_stashsv(namesv, FALSE);
+    
+    if (!stash || !(gv_fetchmethod(stash, methpv))) {
+        SV *module = newSVsv(namesv);
        dSP;
        PUTBACK;
        ENTER;
        dSP;
        PUTBACK;
        ENTER;
-       save_scalar(gv); /* keep the value of $! */
-        Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
-                         newSVpvs("Errno"), Nullsv);
+       if ( flags & 1 )
+           save_scalar(gv); 
+        Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
        LEAVE;
        SPAGAIN;
        LEAVE;
        SPAGAIN;
-       stash = gv_stashpvs("Errno", FALSE);
-       if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
-           Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
+       stash = gv_stashsv(namesv, FALSE);
+       if (!stash)
+           Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" is not available", 
+               varpv, module);
+       else if (!gv_fetchmethod(stash, methpv))    
+           Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" does not support method %s", 
+               varpv, module, methpv);
     }
     }
+    return stash;
 }
 
 /*
 }
 
 /*
@@ -748,36 +797,47 @@ GV *
 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                       I32 sv_type)
 {
 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                       I32 sv_type)
 {
+    dVAR;
     register const char *name = nambeg;
     register GV *gv = NULL;
     GV**gvp;
     I32 len;
     register const char *name = nambeg;
     register GV *gv = NULL;
     GV**gvp;
     I32 len;
-    register const char *namend;
+    register const char *name_cursor;
     HV *stash = NULL;
     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
     const I32 no_expand = flags & GV_NOEXPAND;
     HV *stash = NULL;
     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
     const I32 no_expand = flags & GV_NOEXPAND;
-    const I32 add = flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND;
-
-    PERL_UNUSED_ARG(full_len);
+    const I32 add =
+       flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND & ~GV_NOTQUAL;
+    const char *const name_end = nambeg + full_len;
+    const char *const name_em1 = name_end - 1;
+
+    if (flags & GV_NOTQUAL) {
+       /* Caller promised that there is no stash, so we can skip the check. */
+       len = full_len;
+       goto no_stash;
+    }
 
 
-    if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
+    if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
+       /* accidental stringify on a GV? */
        name++;
        name++;
+    }
 
 
-    for (namend = name; *namend; namend++) {
-       if ((*namend == ':' && namend[1] == ':')
-           || (*namend == '\'' && namend[1]))
+    for (name_cursor = name; name_cursor < name_end; name_cursor++) {
+       if ((*name_cursor == ':' && name_cursor < name_em1
+            && name_cursor[1] == ':')
+           || (*name_cursor == '\'' && name_cursor[1]))
        {
            if (!stash)
                stash = PL_defstash;
            if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
        {
            if (!stash)
                stash = PL_defstash;
            if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
-               return Nullgv;
+               return NULL;
 
 
-           len = namend - name;
+           len = name_cursor - name;
            if (len > 0) {
                char smallbuf[128];
                char *tmpbuf;
 
            if (len > 0) {
                char smallbuf[128];
                char *tmpbuf;
 
-               if (len + 3 < sizeof (smallbuf))
+               if (len + 3 < (I32)sizeof (smallbuf))
                    tmpbuf = smallbuf;
                else
                    Newx(tmpbuf, len+3, char);
                    tmpbuf = smallbuf;
                else
                    Newx(tmpbuf, len+3, char);
@@ -786,7 +846,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                tmpbuf[len++] = ':';
                tmpbuf[len] = '\0';
                gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
                tmpbuf[len++] = ':';
                tmpbuf[len] = '\0';
                gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
-               gv = gvp ? *gvp : Nullgv;
+               gv = gvp ? *gvp : NULL;
                if (gv && gv != (GV*)&PL_sv_undef) {
                    if (SvTYPE(gv) != SVt_PVGV)
                        gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
                if (gv && gv != (GV*)&PL_sv_undef) {
                    if (SvTYPE(gv) != SVt_PVGV)
                        gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
@@ -796,53 +856,63 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                if (tmpbuf != smallbuf)
                    Safefree(tmpbuf);
                if (!gv || gv == (GV*)&PL_sv_undef)
                if (tmpbuf != smallbuf)
                    Safefree(tmpbuf);
                if (!gv || gv == (GV*)&PL_sv_undef)
-                   return Nullgv;
+                   return NULL;
 
                if (!(stash = GvHV(gv)))
                    stash = GvHV(gv) = newHV();
 
                if (!HvNAME_get(stash))
 
                if (!(stash = GvHV(gv)))
                    stash = GvHV(gv) = newHV();
 
                if (!HvNAME_get(stash))
-                   hv_name_set(stash, nambeg, namend - nambeg, 0);
+                   hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
            }
 
            }
 
-           if (*namend == ':')
-               namend++;
-           namend++;
-           name = namend;
-           if (!*name)
-               return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
+           if (*name_cursor == ':')
+               name_cursor++;
+           name_cursor++;
+           name = name_cursor;
+           if (name == name_end)
+               return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
        }
     }
        }
     }
-    len = namend - name;
+    len = name_cursor - name;
 
     /* No stash in name, so see how we can default */
 
     if (!stash) {
 
     /* No stash in name, so see how we can default */
 
     if (!stash) {
-       if (isIDFIRST_lazy(name)) {
+    no_stash:
+       if (len && isIDFIRST_lazy(name)) {
            bool global = FALSE;
 
            bool global = FALSE;
 
-           /* name is always \0 terminated, and initial \0 wouldn't return
-              true from isIDFIRST_lazy, so we know that name[1] is defined  */
-           switch (name[1]) {
-           case '\0':
+           switch (len) {
+           case 1:
                if (*name == '_')
                    global = TRUE;
                break;
                if (*name == '_')
                    global = TRUE;
                break;
-           case 'N':
-               if (strEQ(name, "INC") || strEQ(name, "ENV"))
+           case 3:
+               if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
+                   || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
+                   || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
                    global = TRUE;
                break;
                    global = TRUE;
                break;
-           case 'I':
-               if (strEQ(name, "SIG"))
+           case 4:
+               if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
+                   && name[3] == 'V')
+                   global = TRUE;
+               break;
+           case 5:
+               if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
+                   && name[3] == 'I' && name[4] == 'N')
                    global = TRUE;
                break;
                    global = TRUE;
                break;
-           case 'T':
-               if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
-                   strEQ(name, "STDERR"))
+           case 6:
+               if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
+                   &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
+                      ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
                    global = TRUE;
                break;
                    global = TRUE;
                break;
-           case 'R':
-               if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
+           case 7:
+               if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
+                   && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
+                   && name[6] == 'T')
                    global = TRUE;
                break;
            }
                    global = TRUE;
                break;
            }
@@ -864,7 +934,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                        *gvp == (GV*)&PL_sv_undef ||
                        SvTYPE(*gvp) != SVt_PVGV)
                    {
                        *gvp == (GV*)&PL_sv_undef ||
                        SvTYPE(*gvp) != SVt_PVGV)
                    {
-                       stash = 0;
+                       stash = NULL;
                    }
                    else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
                             (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
                    }
                    else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
                             (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
@@ -876,7 +946,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                            name);
                        if (GvCVu(*gvp))
                            Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
                            name);
                        if (GvCVu(*gvp))
                            Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
-                       stash = 0;
+                       stash = NULL;
                    }
                }
            }
                    }
                }
            }
@@ -897,28 +967,40 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                  : sv_type == SVt_PVAV ? "@"
                  : sv_type == SVt_PVHV ? "%"
                  : ""), name);
                  : sv_type == SVt_PVAV ? "@"
                  : sv_type == SVt_PVHV ? "%"
                  : ""), name);
+           GV *gv;
            if (USE_UTF8_IN_NAMES)
                SvUTF8_on(err);
            qerror(err);
            if (USE_UTF8_IN_NAMES)
                SvUTF8_on(err);
            qerror(err);
-           stash = GvHV(gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV));
+           gv = gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV);
+           if(!gv) {
+               /* symbol table under destruction */
+               return NULL;
+           }   
+           stash = GvHV(gv);
        }
        else
        }
        else
-           return Nullgv;
+           return NULL;
     }
 
     if (!SvREFCNT(stash))      /* symbol table under destruction */
     }
 
     if (!SvREFCNT(stash))      /* symbol table under destruction */
-       return Nullgv;
+       return NULL;
 
     gvp = (GV**)hv_fetch(stash,name,len,add);
     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 
     gvp = (GV**)hv_fetch(stash,name,len,add);
     if (!gvp || *gvp == (GV*)&PL_sv_undef)
-       return Nullgv;
+       return NULL;
     gv = *gvp;
     if (SvTYPE(gv) == SVt_PVGV) {
        if (add) {
            GvMULTI_on(gv);
            gv_init_sv(gv, sv_type);
     gv = *gvp;
     if (SvTYPE(gv) == SVt_PVGV) {
        if (add) {
            GvMULTI_on(gv);
            gv_init_sv(gv, sv_type);
-           if (*name=='!' && sv_type == SVt_PVHV && len==1)
-               require_errno(gv);
+           if (sv_type == SVt_PVHV && len == 1 ) {
+               if (*name == '!')
+                   require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+               else
+               if (*name == '-' || *name == '+') 
+                    require_tie_mod(gv, name, newSVpvs("re::Tie::Hash::NamedCapture"), "FETCH", 0);
+               
+            }              
        }
        return gv;
     } else if (no_init) {
        }
        return gv;
     } else if (no_init) {
@@ -942,6 +1024,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     if (len > 1) {
 #ifndef EBCDIC
        if (*name > 'V' ) {
     if (len > 1) {
 #ifndef EBCDIC
        if (*name > 'V' ) {
+           NOOP;
            /* Nothing else to do.
               The compiler will probably turn the switch statement into a
               branch table. Make sure we avoid even that small overhead for
            /* Nothing else to do.
               The compiler will probably turn the switch statement into a
               branch table. Make sure we avoid even that small overhead for
@@ -955,6 +1038,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                if (strEQ(name2, "RGV")) {
                    IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
                }
                if (strEQ(name2, "RGV")) {
                    IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
                }
+               else if (strEQ(name2, "RGVOUT")) {
+                   GvMULTI_on(gv);
+               }
                break;
            case 'E':
                if (strnEQ(name2, "XPORT", 5))
                break;
            case 'E':
                if (strnEQ(name2, "XPORT", 5))
@@ -964,7 +1050,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                if (strEQ(name2, "SA")) {
                    AV* const av = GvAVn(gv);
                    GvMULTI_on(gv);
                if (strEQ(name2, "SA")) {
                    AV* const av = GvAVn(gv);
                    GvMULTI_on(gv);
-                   sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
+                   sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
                    /* NOTE: No support for tied ISA */
                    if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
                        && AvFILLp(av) == -1)
                    /* NOTE: No support for tied ISA */
                    if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
                        && AvFILLp(av) == -1)
@@ -987,7 +1073,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                if (strEQ(name2, "VERLOAD")) {
                    HV* const hv = GvHVn(gv);
                    GvMULTI_on(gv);
                if (strEQ(name2, "VERLOAD")) {
                    HV* const hv = GvHVn(gv);
                    GvMULTI_on(gv);
-                   hv_magic(hv, Nullgv, PERL_MAGIC_overload);
+                   hv_magic(hv, NULL, PERL_MAGIC_overload);
                }
                break;
            case 'S':
                }
                break;
            case 'S':
@@ -1001,7 +1087,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                    }
                    GvMULTI_on(gv);
                    hv = GvHVn(gv);
                    }
                    GvMULTI_on(gv);
                    hv = GvHVn(gv);
-                   hv_magic(hv, Nullgv, PERL_MAGIC_sig);
+                   hv_magic(hv, NULL, PERL_MAGIC_sig);
                    for (i = 1; i < SIG_SIZE; i++) {
                        SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
                        if (init)
                    for (i = 1; i < SIG_SIZE; i++) {
                        SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
                        if (init)
@@ -1037,6 +1123,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                    goto ro_magicalize;
                if (strEQ(name2, "TF8LOCALE"))
                    goto ro_magicalize;
                    goto ro_magicalize;
                if (strEQ(name2, "TF8LOCALE"))
                    goto ro_magicalize;
+               if (strEQ(name2, "TF8CACHE"))
+                   goto magicalize;
                break;
            case '\027':        /* $^WARNING_BITS */
                if (strEQ(name2, "ARNING_BITS"))
                break;
            case '\027':        /* $^WARNING_BITS */
                if (strEQ(name2, "ARNING_BITS"))
@@ -1091,25 +1179,45 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            goto magicalize;
 
        case '!':
            goto magicalize;
 
        case '!':
-
-           /* If %! has been used, automatically load Errno.pm.
-              The require will itself set errno, so in order to
-              preserve its value we have to set up the magic
-              now (rather than going to magicalize)
-           */
+       GvMULTI_on(gv);    
+           /* If %! has been used, automatically load Errno.pm. */
 
            sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 
 
            sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 
+            /* magicalization must be done before require_tie_mod is called */
            if (sv_type == SVt_PVHV)
            if (sv_type == SVt_PVHV)
-               require_errno(gv);
+               require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
 
            break;
        case '-':
 
            break;
        case '-':
-       {
-           AV* const av = GvAVn(gv);
-            sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
-           SvREADONLY_on(av);
-           goto magicalize;
+       case '+':
+       GvMULTI_on(gv); /* no used once warnings here */
+        {
+            bool plus = (*name == '+');
+            SV *stashname = newSVpvs("re::Tie::Hash::NamedCapture");
+            AV* const av = GvAVn(gv);
+           HV *const hv = GvHVn(gv);
+           HV *const hv_tie = newHV();
+            SV *tie = newRV_noinc((SV*)hv_tie);
+
+            sv_bless(tie, gv_stashsv(stashname,1));
+            hv_magic(hv, (GV*)tie, PERL_MAGIC_tied);    
+            sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0);
+            sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+
+            if (plus)
+                SvREADONLY_on(GvSVn(gv));
+            else
+                Perl_hv_store(aTHX_ hv_tie, STR_WITH_LEN("all"), newSViv(1), 0);
+            
+            SvREADONLY_on(hv);
+            SvREADONLY_on(tie);
+            SvREADONLY_on(av);
+                
+            if (sv_type == SVt_PVHV) 
+                require_tie_mod(gv, name, stashname, "FETCH", 0);
+
+           break;
        }
        case '*':
        case '#':
        }
        case '*':
        case '#':
@@ -1121,13 +1229,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
            goto magicalize;
 
            sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
            goto magicalize;
 
-       case '+':
-       {
-           AV* const av = GvAVn(gv);
-            sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
-           SvREADONLY_on(av);
-           /* FALL THROUGH */
-       }
+       case '\010':    /* $^H */
+           {
+               HV *const hv = GvHVn(gv);
+               hv_magic(hv, NULL, PERL_MAGIC_hints);
+           }
+           goto magicalize;
        case '\023':    /* $^S */
        case '1':
        case '2':
        case '\023':    /* $^S */
        case '1':
        case '2':
@@ -1159,7 +1266,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        case '\004':    /* $^D */
        case '\005':    /* $^E */
        case '\006':    /* $^F */
        case '\004':    /* $^D */
        case '\005':    /* $^E */
        case '\006':    /* $^F */
-       case '\010':    /* $^H */
        case '\011':    /* $^I, NOT \t in EBCDIC */
        case '\016':    /* $^N */
        case '\017':    /* $^O */
        case '\011':    /* $^I, NOT \t in EBCDIC */
        case '\016':    /* $^N */
        case '\017':    /* $^O */
@@ -1237,8 +1343,9 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain
 IO *
 Perl_newIO(pTHX)
 {
 IO *
 Perl_newIO(pTHX)
 {
+    dVAR;
     GV *iogv;
     GV *iogv;
-    IO * const io = (IO*)NEWSV(0,0);
+    IO * const io = (IO*)newSV(0);
 
     sv_upgrade((SV *)io,SVt_PVIO);
     /* This used to read SvREFCNT(io) = 1;
 
     sv_upgrade((SV *)io,SVt_PVIO);
     /* This used to read SvREFCNT(io) = 1;
@@ -1248,17 +1355,18 @@ Perl_newIO(pTHX)
     SvOBJECT_on(io);
     /* Clear the stashcache because a new IO could overrule a package name */
     hv_clear(PL_stashcache);
     SvOBJECT_on(io);
     /* Clear the stashcache because a new IO could overrule a package name */
     hv_clear(PL_stashcache);
-    iogv = gv_fetchpvn_flags("FileHandle::", 12, 0, SVt_PVHV);
+    iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
-      iogv = gv_fetchpvn_flags("IO::Handle::", 12, TRUE, SVt_PVHV);
+      iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
     return io;
 }
 
 void
     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
     return io;
 }
 
 void
-Perl_gv_check(pTHX_ HV *stash)
+Perl_gv_check(pTHX_ const HV *stash)
 {
 {
+    dVAR;
     register I32 i;
 
     if (!HvARRAY(stash))
     register I32 i;
 
     if (!HvARRAY(stash))
@@ -1310,8 +1418,9 @@ Perl_gv_check(pTHX_ HV *stash)
 GV *
 Perl_newGVgen(pTHX_ const char *pack)
 {
 GV *
 Perl_newGVgen(pTHX_ const char *pack)
 {
+    dVAR;
     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
-                     TRUE, SVt_PVGV);
+                     GV_ADD, SVt_PVGV);
 }
 
 /* hopefully this is only called on local symbol table entries */
 }
 
 /* hopefully this is only called on local symbol table entries */
@@ -1319,14 +1428,15 @@ Perl_newGVgen(pTHX_ const char *pack)
 GP*
 Perl_gp_ref(pTHX_ GP *gp)
 {
 GP*
 Perl_gp_ref(pTHX_ GP *gp)
 {
+    dVAR;
     if (!gp)
     if (!gp)
-       return (GP*)NULL;
+       return NULL;
     gp->gp_refcnt++;
     if (gp->gp_cv) {
        if (gp->gp_cvgen) {
            /* multi-named GPs cannot be used for method cache */
            SvREFCNT_dec(gp->gp_cv);
     gp->gp_refcnt++;
     if (gp->gp_cv) {
        if (gp->gp_cvgen) {
            /* multi-named GPs cannot be used for method cache */
            SvREFCNT_dec(gp->gp_cv);
-           gp->gp_cv = Nullcv;
+           gp->gp_cv = NULL;
            gp->gp_cvgen = 0;
        }
        else {
            gp->gp_cvgen = 0;
        }
        else {
@@ -1340,9 +1450,10 @@ Perl_gp_ref(pTHX_ GP *gp)
 void
 Perl_gp_free(pTHX_ GV *gv)
 {
 void
 Perl_gp_free(pTHX_ GV *gv)
 {
+    dVAR;
     GP* gp;
 
     GP* gp;
 
-    if (!gv || !(gp = GvGP(gv)))
+    if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
        return;
     if (gp->gp_refcnt == 0) {
        if (ckWARN_d(WARN_INTERNAL))
        return;
     if (gp->gp_refcnt == 0) {
        if (ckWARN_d(WARN_INTERNAL))
@@ -1358,11 +1469,14 @@ Perl_gp_free(pTHX_ GV *gv)
     if (--gp->gp_refcnt > 0) {
        if (gp->gp_egv == gv)
            gp->gp_egv = 0;
     if (--gp->gp_refcnt > 0) {
        if (gp->gp_egv == gv)
            gp->gp_egv = 0;
+       GvGP(gv) = 0;
         return;
     }
 
         return;
     }
 
-    if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
-    if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
+    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 ?
        Somehow gp->gp_hv can end up pointing at freed garbage.  */
     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
     /* FIXME - another reference loop GV -> symtab -> GV ?
        Somehow gp->gp_hv can end up pointing at freed garbage.  */
     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
@@ -1372,9 +1486,9 @@ Perl_gp_free(pTHX_ GV *gv)
                      G_DISCARD);
        SvREFCNT_dec(gp->gp_hv);
     }
                      G_DISCARD);
        SvREFCNT_dec(gp->gp_hv);
     }
-    if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
-    if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
-    if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
+    SvREFCNT_dec(gp->gp_io);
+    SvREFCNT_dec(gp->gp_cv);
+    SvREFCNT_dec(gp->gp_form);
 
     Safefree(gp);
     GvGP(gv) = 0;
 
     Safefree(gp);
     GvGP(gv) = 0;
@@ -1390,9 +1504,9 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
        int i;
        for (i = 1; i < NofAMmeth; i++) {
            CV * const cv = amtp->table[i];
        int i;
        for (i = 1; i < NofAMmeth; i++) {
            CV * const cv = amtp->table[i];
-           if (cv != Nullcv) {
+           if (cv) {
                SvREFCNT_dec((SV *) cv);
                SvREFCNT_dec((SV *) cv);
-               amtp->table[i] = Nullcv;
+               amtp->table[i] = NULL;
            }
        }
     }
            }
        }
     }
@@ -1404,14 +1518,18 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
 bool
 Perl_Gv_AMupdate(pTHX_ HV *stash)
 {
 bool
 Perl_Gv_AMupdate(pTHX_ HV *stash)
 {
+  dVAR;
   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
-  AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
   AMT amt;
 
   AMT amt;
 
-  if (mg && amtp->was_ok_am == PL_amagic_generation
-      && amtp->was_ok_sub == PL_sub_generation)
-      return (bool)AMT_OVERLOADED(amtp);
-  sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
+  if (mg) {
+      const AMT * const amtp = (AMT*)mg->mg_ptr;
+      if (amtp->was_ok_am == PL_amagic_generation
+         && amtp->was_ok_sub == PL_sub_generation) {
+         return (bool)AMT_OVERLOADED(amtp);
+      }
+      sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
+  }
 
   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
 
 
   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
 
@@ -1436,7 +1554,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
        lim = DESTROY_amg;              /* Skip overloading entries. */
 #ifdef PERL_DONT_CREATE_GVSV
     else if (!sv) {
        lim = DESTROY_amg;              /* Skip overloading entries. */
 #ifdef PERL_DONT_CREATE_GVSV
     else if (!sv) {
-       /* Equivalent to !SvTRUE and !SvOK  */
+       NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
     }
 #endif
     else if (SvTRUE(sv))
     }
 #endif
     else if (SvTRUE(sv))
@@ -1445,11 +1563,11 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
        amt.fallback=AMGfallNEVER;
 
     for (i = 1; i < lim; i++)
        amt.fallback=AMGfallNEVER;
 
     for (i = 1; i < lim; i++)
-       amt.table[i] = Nullcv;
+       amt.table[i] = NULL;
     for (; i < NofAMmeth; i++) {
     for (; i < NofAMmeth; i++) {
-       const char *cooky = PL_AMG_names[i];
+       const char * const cooky = PL_AMG_names[i];
        /* Human-readable form, for debugging: */
        /* Human-readable form, for debugging: */
-       const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
+       const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
        const STRLEN l = strlen(cooky);
 
        DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
        const STRLEN l = strlen(cooky);
 
        DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
@@ -1473,12 +1591,12 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
                /* This is a hack to support autoloading..., while
                   knowing *which* methods were declared as overloaded. */
                /* GvSV contains the name of the method. */
                /* 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;
+               GV *ngv = NULL;
                SV *gvsv = GvSV(gv);
 
                DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
                        "\" for overloaded \"%s\" in package \"%.256s\"\n",
                SV *gvsv = GvSV(gv);
 
                DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
                        "\" for overloaded \"%s\" in package \"%.256s\"\n",
-                            GvSV(gv), cp, hvname) );
+                            (void*)GvSV(gv), cp, hvname) );
                if (!gvsv || !SvPOK(gvsv)
                    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
                                                       FALSE)))
                if (!gvsv || !SvPOK(gvsv)
                    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
                                                       FALSE)))
@@ -1503,7 +1621,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
            cv = (CV*)gv;
            filled = 1;
        }
            cv = (CV*)gv;
            filled = 1;
        }
-       amt.table[i]=(CV*)SvREFCNT_inc(cv);
+       amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
     }
     if (filled) {
       AMT_AMAGIC_on(&amt);
     }
     if (filled) {
       AMT_AMAGIC_on(&amt);
@@ -1526,17 +1644,19 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 CV*
 Perl_gv_handler(pTHX_ HV *stash, I32 id)
 {
 CV*
 Perl_gv_handler(pTHX_ HV *stash, I32 id)
 {
+    dVAR;
     MAGIC *mg;
     AMT *amtp;
 
     if (!stash || !HvNAME_get(stash))
     MAGIC *mg;
     AMT *amtp;
 
     if (!stash || !HvNAME_get(stash))
-        return Nullcv;
+        return NULL;
     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
     if (!mg) {
       do_update:
        Gv_AMupdate(stash);
        mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
     }
     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
     if (!mg) {
       do_update:
        Gv_AMupdate(stash);
        mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
     }
+    assert(mg);
     amtp = (AMT*)mg->mg_ptr;
     if ( amtp->was_ok_am != PL_amagic_generation
         || amtp->was_ok_sub != PL_sub_generation )
     amtp = (AMT*)mg->mg_ptr;
     if ( amtp->was_ok_am != PL_amagic_generation
         || amtp->was_ok_sub != PL_sub_generation )
@@ -1556,7 +1676,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
        return ret;
     }
 
        return ret;
     }
 
-    return Nullcv;
+    return NULL;
 }
 
 
 }
 
 
@@ -1581,7 +1701,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
                        ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
                        ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
-                       : (CV **) NULL))
+                       : NULL))
       && ((cv = cvp[off=method+assignshift])
          || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
                                                          * usual method */
       && ((cv = cvp[off=method+assignshift])
          || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
                                                          * usual method */
@@ -1641,6 +1761,12 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
                 */
                SV* const newref = newSVsv(tmpRef);
                SvOBJECT_on(newref);
                 */
                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;
             }
                SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
                return newref;
             }
@@ -1699,7 +1825,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
               && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
               && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
                          ? (amtp = (AMT*)mg->mg_ptr)->table
               && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
               && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
                          ? (amtp = (AMT*)mg->mg_ptr)->table
-                         : (CV **) NULL))
+                         : NULL))
               && (cv = cvp[off=method])) { /* Method for right
                                             * argument found */
       lr=1;
               && (cv = cvp[off=method])) { /* Method for right
                                             * argument found */
       lr=1;
@@ -1751,6 +1877,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;
        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;
       } else {
        SV *msg;
        if (off==-1) off=method;
@@ -1775,7 +1904,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
        if (amtp && amtp->fallback >= AMGfallYES) {
          DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
        } else {
        if (amtp && amtp->fallback >= AMGfallYES) {
          DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
        } else {
-         Perl_croak(aTHX_ "%"SVf, msg);
+         Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
        }
        return NULL;
       }
        }
        return NULL;
       }
@@ -1834,7 +1963,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
     CATCH_SET(TRUE);
     Zero(&myop, 1, BINOP);
     myop.op_last = (OP *) &myop;
     CATCH_SET(TRUE);
     Zero(&myop, 1, BINOP);
     myop.op_last = (OP *) &myop;
-    myop.op_next = Nullop;
+    myop.op_next = NULL;
     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
 
     PUSHSTACKi(PERLSI_OVERLOAD);
     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
 
     PUSHSTACKi(PERLSI_OVERLOAD);
@@ -1943,6 +2072,7 @@ pointers returned by SvPV.
 bool
 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
 {
 bool
 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
 {
+    PERL_UNUSED_CONTEXT;
     PERL_UNUSED_ARG(flags);
 
     if (len > 1) {
     PERL_UNUSED_ARG(flags);
 
     if (len > 1) {
@@ -2061,6 +2191,26 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
     return FALSE;
 }
 
     return FALSE;
 }
 
+void
+Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
+{
+    dVAR;
+    U32 hash;
+
+    assert(name);
+    PERL_UNUSED_ARG(flags);
+
+    if (len > I32_MAX)
+       Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
+
+    if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
+       unshare_hek(GvNAME_HEK(gv));
+    }
+
+    PERL_HASH(hash, name, len);
+    GvNAME_HEK(gv) = share_hek(name, len, hash);
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
 /*
  * Local variables:
  * c-indentation-style: bsd
Unnamed repository; edit this file 'description' to name the repository.