APItest: Test native code points, instead of Unicode

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index 0d383ff..d3527aa 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -154,7 +154,7 @@ Perl_gv_const_sv(pTHX_ GV *gv)
 
     if (SvTYPE(gv) == SVt_PVGV)
        return cv_const_sv(GvCVu(gv));
-    return SvROK(gv) ? SvRV(gv) : NULL;
+    return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
 }
 
 GP *
@@ -165,7 +165,7 @@ Perl_newGP(pTHX_ GV *const gv)
     const char *file;
     STRLEN len;
 #ifndef USE_ITHREADS
-    SV * temp_sv;
+    GV *filegv;
 #endif
     dVAR;
 
@@ -176,13 +176,23 @@ Perl_newGP(pTHX_ GV *const gv)
     gp->gp_sv = newSV(0);
 #endif
 
-#ifdef USE_ITHREADS
+    /* PL_curcop should never be null here. */
+    assert(PL_curcop);
+    /* But for non-debugging builds play it safe */
     if (PL_curcop) {
        gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
+#ifdef USE_ITHREADS
        if (CopFILE(PL_curcop)) {
            file = CopFILE(PL_curcop);
            len = strlen(file);
        }
+#else
+       filegv = CopFILEGV(PL_curcop);
+       if (filegv) {
+           file = GvNAME(filegv)+2;
+           len = GvNAMELEN(filegv)-2;
+       }
+#endif
        else goto no_file;
     }
     else {
@@ -190,18 +200,6 @@ Perl_newGP(pTHX_ GV *const gv)
        file = "";
        len = 0;
     }
-#else
-    if(PL_curcop)
-       gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
-    temp_sv = CopFILESV(PL_curcop);
-    if (temp_sv) {
-       file = SvPVX(temp_sv);
-       len = SvCUR(temp_sv);
-    } else {
-       file = "";
-       len = 0;
-    }
-#endif
 
     PERL_HASH(hash, file, len);
     gp->gp_file_hek = share_hek(file, len, hash);
@@ -346,7 +344,6 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
     if (has_constant) {
        /* The constant has to be a simple scalar type.  */
        switch (SvTYPE(has_constant)) {
-       case SVt_PVAV:
        case SVt_PVHV:
        case SVt_PVCV:
        case SVt_PVFM:
@@ -684,8 +681,9 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
 
     if (flags & GV_SUPER) {
-       if (!HvAUX(stash)->xhv_super) HvAUX(stash)->xhv_super = newHV();
-       cachestash = HvAUX(stash)->xhv_super;
+       if (!HvAUX(stash)->xhv_mro_meta->super)
+           HvAUX(stash)->xhv_mro_meta->super = newHV();
+       cachestash = HvAUX(stash)->xhv_mro_meta->super;
     }
     else cachestash = stash;
 
@@ -1028,7 +1026,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
                Perl_croak(aTHX_
                           "Can't locate object method \"%"UTF8f
                           "\" via package \"%"HEKf"\"",
-                                   is_utf8, nend - name, name,
+                                   UTF8fARG(is_utf8, nend - name, name),
                                     HEKfARG(HvNAME_HEK(stash)));
            }
            else {
@@ -1038,14 +1036,14 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
                    packnamesv = newSVpvn_flags(origname, nsplit - origname,
                                                     SVs_TEMP | is_utf8);
                } else {
-                   packnamesv = sv_2mortal(newSVsv(error_report));
+                   packnamesv = error_report;
                }
 
                Perl_croak(aTHX_
                           "Can't locate object method \"%"UTF8f
                           "\" via package \"%"SVf"\""
                           " (perhaps you forgot to load \"%"SVf"\"?)",
-                          is_utf8, nend - name, name,
+                          UTF8fARG(is_utf8, nend - name, name),
                            SVfARG(packnamesv), SVfARG(packnamesv));
            }
        }
@@ -1140,7 +1138,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
                         "Use of inherited AUTOLOAD for non-method %"SVf
                         "::%"UTF8f"() is deprecated",
                         SVfARG(packname),
-                         is_utf8, len, name);
+                         UTF8fARG(is_utf8, len, name));
 
     if (CvISXSUB(cv)) {
         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
@@ -1575,12 +1573,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                            "Variable \"%c%"UTF8f"\" is not imported",
                            sv_type == SVt_PVAV ? '@' :
                            sv_type == SVt_PVHV ? '%' : '$',
-                           is_utf8, len, name);
+                           UTF8fARG(is_utf8, len, name));
                        if (GvCVu(*gvp))
                            Perl_ck_warner_d(
                                aTHX_ packWARN(WARN_MISC),
                                "\t(Did you mean &%"UTF8f" instead?)\n",
-                               is_utf8, len, name
+                               UTF8fARG(is_utf8, len, name)
                            );
                        stash = NULL;
                    }
@@ -1603,7 +1601,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                 (sv_type == SVt_PV ? "$"
                  : sv_type == SVt_PVAV ? "@"
                  : sv_type == SVt_PVHV ? "%"
-                 : ""), is_utf8, len, name);
+                 : ""), UTF8fARG(is_utf8, len, name));
            GV *gv;
            if (is_utf8)
                SvUTF8_on(err);
@@ -1701,7 +1699,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     if (add & GV_ADDWARN)
        Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
                "Had to create %"UTF8f" unexpectedly",
-                is_utf8, name_end-nambeg, nambeg);
+                UTF8fARG(is_utf8, name_end-nambeg, nambeg));
     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
 
     if ( isIDFIRST_lazy_if(name, is_utf8)
@@ -1825,6 +1823,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
             case '\015':        /* $^MATCH */
                 if (strEQ(name2, "ATCH"))
                    goto magicalize;
+                break;
            case '\017':        /* $^OPEN */
                if (strEQ(name2, "PEN"))
                    goto magicalize;
@@ -2075,7 +2074,7 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain
 }
 
 void
-Perl_gv_check(pTHX_ const HV *stash)
+Perl_gv_check(pTHX_ HV *stash)
 {
     dVAR;
     I32 i;
@@ -2086,13 +2085,16 @@ Perl_gv_check(pTHX_ const HV *stash)
        return;
     for (i = 0; i <= (I32) HvMAX(stash); i++) {
         const HE *entry;
+       /* SvIsCOW is unused on HVs, so we can use it to mark stashes we
+          are currently searching through recursively.  */
+       SvIsCOW_on(stash);
        for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
             GV *gv;
             HV *hv;
            if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
                (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
            {
-               if (hv != PL_defstash && hv != stash)
+               if (hv != PL_defstash && hv != stash && !SvIsCOW(hv))
                     gv_check(hv);              /* nested package */
            }
             else if ( *HeKEY(entry) != '_'
@@ -2116,6 +2118,7 @@ Perl_gv_check(pTHX_ const HV *stash)
                             HEKfARG(GvNAME_HEK(gv)));
            }
        }
+       SvIsCOW_off(stash);
     }
 }
 
@@ -2127,7 +2130,7 @@ Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
     assert(!(flags & ~SVf_UTF8));
 
     return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
-                                    flags, strlen(pack), pack,
+                                UTF8fARG(flags, strlen(pack), pack),
                                 (long)PL_gensym++),
                       GV_ADD, SVt_PVGV);
 }