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
Teach ss_dup about SAVEt_RE_STATE. (As correctly as it ever was before)
[perl5.git] / gv.c
diff --git a/gv.c b/gv.c
index 555260f..9834b7a 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -80,7 +80,8 @@ Perl_gv_IOadd(pTHX_ register GV *gv)
          * 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 ||
@@ -161,7 +162,8 @@ 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;
 
@@ -182,7 +184,12 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
        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);
@@ -192,6 +199,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
            Safefree(SvPVX_mutable(gv));
     }
     Newxz(gp, 1, GP);
+    SvSCREAM_on(gv);
     GvGP(gv) = gp_ref(gp);
 #ifdef PERL_DONT_CREATE_GVSV
     GvSV(gv) = NULL;
@@ -204,12 +212,10 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
     GvCVGEN(gv) = 0;
     GvEGV(gv) = gv;
-    sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, NULL, 0);
     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. */
@@ -351,7 +357,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
                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);
            }
        }
     }
@@ -508,7 +514,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 */
-           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);
@@ -569,7 +575,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     GV* vargv;
     SV* varsv;
     const char *packname = "";
-    STRLEN packname_len;
+    STRLEN packname_len = 0;
 
     if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
        return NULL;
@@ -600,7 +606,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);
 
-    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 '::',
@@ -890,7 +896,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                        *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)) ||
@@ -902,7 +908,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);
-                       stash = 0;
+                       stash = NULL;
                    }
                }
            }
@@ -1064,6 +1070,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                    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"))
@@ -1148,6 +1156,13 @@ 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;
 
+       case '\010':    /* $^H */
+           {
+               HV *const hv = GvHVn(gv);
+               hv_magic(hv, NULL, PERL_MAGIC_hints);
+           }
+           goto magicalize;
+
        case '+':
        {
            AV* const av = GvAVn(gv);
@@ -1186,7 +1201,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        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 */
@@ -1341,7 +1355,7 @@ Perl_newGVgen(pTHX_ const char *pack)
 {
     dVAR;
     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 */
@@ -1351,7 +1365,7 @@ Perl_gp_ref(pTHX_ GP *gp)
 {
     dVAR;
     if (!gp)
-       return (GP*)NULL;
+       return NULL;
     gp->gp_refcnt++;
     if (gp->gp_cv) {
        if (gp->gp_cvgen) {
@@ -1374,7 +1388,7 @@ Perl_gp_free(pTHX_ GV *gv)
     dVAR;
     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))
@@ -1390,11 +1404,12 @@ Perl_gp_free(pTHX_ GV *gv)
     if (--gp->gp_refcnt > 0) {
        if (gp->gp_egv == gv)
            gp->gp_egv = 0;
+       GvGP(gv) = 0;
         return;
     }
 
-    if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
-    if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
+    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) {
@@ -1404,9 +1419,9 @@ Perl_gp_free(pTHX_ GV *gv)
                      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;
@@ -1422,7 +1437,7 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
        int i;
        for (i = 1; i < NofAMmeth; i++) {
            CV * const cv = amtp->table[i];
-           if (cv != NULL) {
+           if (cv) {
                SvREFCNT_dec((SV *) cv);
                amtp->table[i] = NULL;
            }
@@ -1536,7 +1551,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
            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);
@@ -1615,7 +1630,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
-                       : (CV **) NULL))
+                       : NULL))
       && ((cv = cvp[off=method+assignshift])
          || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
                                                          * usual method */
@@ -1733,7 +1748,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
-                         : (CV **) NULL))
+                         : NULL))
               && (cv = cvp[off=method])) { /* Method for right
                                             * argument found */
       lr=1;
@@ -1868,7 +1883,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;
-    myop.op_next = Nullop;
+    myop.op_next = NULL;
     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
 
     PUSHSTACKi(PERLSI_OVERLOAD);
@@ -1977,6 +1992,7 @@ pointers returned by SvPV.
 bool
 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
 {
+    PERL_UNUSED_CONTEXT;
     PERL_UNUSED_ARG(flags);
 
     if (len > 1) {
@@ -2095,6 +2111,25 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
     return FALSE;
 }
 
+void
+Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
+{
+    dVAR;
+    U32 hash;
+
+    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) = name ? share_hek(name, len, hash) : 0;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
Unnamed repository; edit this file 'description' to name the repository.