Stage 1 of utf8 support for soft references.

Change gv_fetchpv to take a UTF8 flag, as gv_fetchpvn_flags
Add gv_fetchsv to look up a GV by SV rather than a char * pointer
Provide a backwards compatability gv_fetchpv
Migrate from gv_fetchpv to gv_fetchsv where the caller was grabbing
the pointer from an SV
All tests still pass.

p4raw-id: //depot/perl@23766

Author: nwc10

embed.fnc

@@ -1486,4 +1486,8 @@ np	|long	|my_betohl	|long n
 
 np	|void	|my_swabn	|void* ptr|int n
 
+Ap	|GV*	|gv_fetchpvn_flags|const char* name|STRLEN len|I32 flags|I32 sv_type
+Ap	|GV*	|gv_fetchsv|SV *name|I32 flags|I32 sv_type
+dp	|bool	|is_gv_magical_sv|SV *name|U32 flags
+
 END_EXTERN_C

embed.h

@@ -2278,6 +2278,11 @@
 #ifdef PERL_CORE
 #define my_swabn		Perl_my_swabn
 #endif
+#define gv_fetchpvn_flags	Perl_gv_fetchpvn_flags
+#define gv_fetchsv		Perl_gv_fetchsv
+#ifdef PERL_CORE
+#define is_gv_magical_sv	Perl_is_gv_magical_sv
+#endif
 #define ck_anoncode		Perl_ck_anoncode
 #define ck_bitop		Perl_ck_bitop
 #define ck_concat		Perl_ck_concat
@@ -4893,6 +4898,11 @@
 #ifdef PERL_CORE
 #define my_swabn		Perl_my_swabn
 #endif
+#define gv_fetchpvn_flags(a,b,c,d)	Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d)
+#define gv_fetchsv(a,b,c)	Perl_gv_fetchsv(aTHX_ a,b,c)
+#ifdef PERL_CORE
+#define is_gv_magical_sv(a,b)	Perl_is_gv_magical_sv(aTHX_ a,b)
+#endif
 #define ck_anoncode(a)		Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)		Perl_ck_bitop(aTHX_ a)
 #define ck_concat(a)		Perl_ck_concat(aTHX_ a)

global.sym

@@ -673,3 +673,5 @@ Perl_save_set_svflags
 Perl_hv_assert
 Perl_hv_clear_placeholders
 Perl_hv_scalar
+Perl_gv_fetchpvn_flags
+Perl_gv_fetchsv

gv.c

@@ -650,14 +650,30 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 
 
 GV *
-Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
+Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
+    STRLEN len = strlen (nambeg);
+    return gv_fetchpvn_flags(nambeg, len, add, sv_type);
+}
+
+GV *
+Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
+    STRLEN len;
+    const char *nambeg = SvPV(name, len);
+    return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
+}
+
+GV *
+Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
+		       I32 sv_type)
 {
     register const char *name = nambeg;
     register GV *gv = 0;
     GV**gvp;
     I32 len;
     register const char *namend;
     HV *stash = 0;
+    I32 add = flags & ~SVf_UTF8;
+    I32 utf8 = flags & SVf_UTF8;
 
     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 	name++;
@@ -1819,6 +1835,22 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 /*
 =for apidoc is_gv_magical
 
+Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
+
+=cut
+*/
+
+bool
+Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
+{
+    STRLEN len;
+    char *temp = SvPV(name, len);
+    return is_gv_magical(temp, len, flags);
+}
+
+/*
+=for apidoc is_gv_magical
+
 Returns C<TRUE> if given the name of a magical GV.
 
 Currently only useful internally when determining if a GV should be

gv.h

@@ -153,6 +153,8 @@ Return the SV from the GV.
 #define GV_ADDWARN	0x04	/* add, but warn if symbol wasn't already there */
 #define GV_ADDINEVAL	0x08	/* add, as though we're doing so within an eval */
 #define GV_NOINIT	0x10	/* add, but don't init symbol, if type != PVGV */
-
+/*      SVf_UTF8 (more accurately the return value from SvUTF8) is also valid
+	as a flag to gv_fetch_pvn_flags, so ensure it lies outside this range.
+*/
 #define gv_fullname3(sv,gv,prefix) gv_fullname4(sv,gv,prefix,TRUE)
 #define gv_efullname3(sv,gv,prefix) gv_efullname4(sv,gv,prefix,TRUE)

mg.c

@@ -1764,16 +1764,11 @@ Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
 {
-    register char *s;
     GV* gv;
-    STRLEN n_a;
-
+ 
     if (!SvOK(sv))
 	return 0;
-    s = SvPV(sv, n_a);
-    if (*s == '*' && s[1])
-	s++;
-    gv = gv_fetchpv(s,TRUE, SVt_PVGV);
+    gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
     if (sv == (SV*)gv)
 	return 0;
     if (GvGP(sv))
@@ -2212,12 +2207,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
     case '^':
 	Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
 	IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
-	IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
+	IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
 	break;
     case '~':
 	Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
 	IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
-	IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
+	IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
 	break;
     case '=':
 	IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));

op.c

@@ -4204,10 +4204,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     }
     else
 	aname = Nullch;
-    gv = gv_fetchpv(name ? name : (aname ? aname : 
-		    (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
-		    GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
-		    SVt_PVCV);
+    gv = name ? gv_fetchsv(cSVOPo->op_sv,
+			   GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+			   SVt_PVCV)
+	: gv_fetchpv(aname ? aname
+		     : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
+		     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+		     SVt_PVCV);
 
     if (o)
 	SAVEFREEOP(o);
@@ -4675,15 +4678,13 @@ void
 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
 {
     register CV *cv;
-    char *name;
     GV *gv;
-    STRLEN n_a;
 
     if (o)
-	name = SvPVx(cSVOPo->op_sv, n_a);
+	gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
     else
-	name = "STDOUT";
-    gv = gv_fetchpv(name,TRUE, SVt_PVFM);
+	gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
+    
 #ifdef GV_UNIQUE_CHECK
     if (GvUNIQUE(gv)) {
         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
@@ -4695,7 +4696,9 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
 	    line_t oldline = CopLINE(PL_curcop);
 	    if (PL_copline != NOLINE)
 		CopLINE_set(PL_curcop, PL_copline);
-	    Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
+	    Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+			o ? "Format %"SVf" redefined"
+			: "Format STDOUT redefined" ,cSVOPo->op_sv);
 	    CopLINE_set(PL_curcop, oldline);
 	}
 	SvREFCNT_dec(cv);
@@ -5109,11 +5112,9 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 
     o->op_private |= (PL_hints & HINT_STRICT_REFS);
     if (kid->op_type == OP_CONST) {
-	char *name;
 	int iscv;
 	GV *gv;
 	SV *kidsv = kid->op_sv;
-	STRLEN n_a;
 
 	/* Is it a constant from cv_const_sv()? */
 	if (SvROK(kidsv) && SvREADONLY(kidsv)) {
@@ -5143,7 +5144,6 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 		Perl_croak(aTHX_ "Constant is not %s reference", badtype);
 	    return o;
 	}
-	name = SvPV(kidsv, n_a);
 	if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
 	    char *badthing = Nullch;
 	    switch (o->op_type) {
@@ -5159,8 +5159,8 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 	    }
 	    if (badthing)
 		Perl_croak(aTHX_
-	  "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
-		      name, badthing);
+	  "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
+		      kidsv, badthing);
 	}
 	/*
 	 * This is a little tricky.  We only want to add the symbol if we
@@ -5172,7 +5172,7 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 	 */
 	iscv = (o->op_type == OP_RV2CV) * 2;
 	do {
-	    gv = gv_fetchpv(name,
+	    gv = gv_fetchsv(kidsv,
 		iscv | !(kid->op_private & OPpCONST_ENTERED),
 		iscv
 		    ? SVt_PVCV
@@ -5215,9 +5215,8 @@ Perl_ck_ftst(pTHX_ OP *o)
 	SVOP *kid = (SVOP*)cUNOPo->op_first;
 
 	if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
-	    STRLEN n_a;
 	    OP *newop = newGVOP(type, OPf_REF,
-		gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
+		gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
 	    op_free(o);
 	    o = newop;
 	    return o;
@@ -5259,7 +5258,6 @@ Perl_ck_fun(pTHX_ OP *o)
     }
 
     if (o->op_flags & OPf_KIDS) {
-	STRLEN n_a;
 	tokid = &cLISTOPo->op_first;
 	kid = cLISTOPo->op_first;
 	if (kid->op_type == OP_PUSHMARK ||
@@ -5302,13 +5300,12 @@ Perl_ck_fun(pTHX_ OP *o)
 		if (kid->op_type == OP_CONST &&
 		    (kid->op_private & OPpCONST_BARE))
 		{
-		    char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
 		    OP *newop = newAVREF(newGVOP(OP_GV, 0,
-			gv_fetchpv(name, TRUE, SVt_PVAV) ));
+			gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
 		    if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 			Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-			    "Array @%s missing the @ in argument %"IVdf" of %s()",
-			    name, (IV)numargs, PL_op_desc[type]);
+			    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
+			    ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
 		    op_free(kid);
 		    kid = newop;
 		    kid->op_sibling = sibl;
@@ -5322,13 +5319,12 @@ Perl_ck_fun(pTHX_ OP *o)
 		if (kid->op_type == OP_CONST &&
 		    (kid->op_private & OPpCONST_BARE))
 		{
-		    char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
 		    OP *newop = newHVREF(newGVOP(OP_GV, 0,
-			gv_fetchpv(name, TRUE, SVt_PVHV) ));
+			gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
 		    if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 			Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-			    "Hash %%%s missing the %% in argument %"IVdf" of %s()",
-			    name, (IV)numargs, PL_op_desc[type]);
+			    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
+			    ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
 		    op_free(kid);
 		    kid = newop;
 		    kid->op_sibling = sibl;
@@ -5355,8 +5351,7 @@ Perl_ck_fun(pTHX_ OP *o)
 			(kid->op_private & OPpCONST_BARE))
 		    {
 			OP *newop = newGVOP(OP_GV, 0,
-			    gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
-					SVt_PVIO) );
+			    gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
 			if (!(o->op_private & 1) && /* if not unop */
 			    kid == cLISTOPo->op_last)
 			    cLISTOPo->op_last = newop;

perl.h

@@ -3239,6 +3239,8 @@ EXTCONST char PL_no_wrongref[]
   INIT("Can't use %s ref as %s ref");
 EXTCONST char PL_no_symref[]
   INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use");
+EXTCONST char PL_no_symref_sv[]
+  INIT("Can't use string (\"%.32" SVf "\") as %s ref while \"strict refs\" in use");
 EXTCONST char PL_no_usym[]
   INIT("Can't use an undefined value as %s reference");
 EXTCONST char PL_no_aelem[]

pp.c

@@ -147,9 +147,6 @@ PP(pp_rv2gv)
     }
     else {
 	if (SvTYPE(sv) != SVt_PVGV) {
-	    char *sym;
-	    STRLEN len;
-
 	    if (SvGMAGICAL(sv)) {
 		mg_get(sv);
 		if (SvROK(sv))
@@ -195,22 +192,21 @@ PP(pp_rv2gv)
 		    report_uninit(sv);
 		RETSETUNDEF;
 	    }
-	    sym = SvPV(sv,len);
 	    if ((PL_op->op_flags & OPf_SPECIAL) &&
 		!(PL_op->op_flags & OPf_MOD))
 	    {
-		sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
-		if (!sv
-		    && (!is_gv_magical(sym,len,0)
-			|| !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
-		{
+		SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
+		if (!temp
+		    && (!is_gv_magical_sv(sv,0)
+			|| !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
 		    RETSETUNDEF;
 		}
+		sv = temp;
 	    }
 	    else {
 		if (PL_op->op_private & HINT_STRICT_REFS)
-		    DIE(aTHX_ PL_no_symref, sym, "a symbol");
-		sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
+		    DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
+		sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
 	    }
 	}
     }
@@ -238,8 +234,6 @@ PP(pp_rv2sv)
 	}
     }
     else {
-	char *sym;
-	STRLEN len;
 	gv = (GV*)sv;
 
 	if (SvTYPE(gv) != SVt_PVGV) {
@@ -256,22 +250,21 @@ PP(pp_rv2sv)
 		    report_uninit(sv);
 		RETSETUNDEF;
 	    }
-	    sym = SvPV(sv, len);
 	    if ((PL_op->op_flags & OPf_SPECIAL) &&
 		!(PL_op->op_flags & OPf_MOD))
 	    {
-		gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
+		gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
 		if (!gv
-		    && (!is_gv_magical(sym,len,0)
-			|| !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
+		    && (!is_gv_magical_sv(sv, 0)
+			|| !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
 		{
 		    RETSETUNDEF;
 		}
 	    }
 	    else {
 		if (PL_op->op_private & HINT_STRICT_REFS)
-		    DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
-		gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+		    DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
+		gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
 	    }
 	}
 	sv = GvSV(gv);