Add get_cvn_flags(), which is like get_cv() but takes a length. This

allows symbolic code references with embeded NULs to work.

p4raw-id: //depot/perl@29830

12 files changed, 65 insertions, 26 deletions

diff --git a/embed.fnc b/embed.fnc
index 2801844c4f..0847142660 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -639,7 +639,8 @@ Apd	|I32	|eval_sv	|NN SV* sv|I32 flags
 Apd	|SV*	|get_sv		|NN const char* name|I32 create
 Apd	|AV*	|get_av		|NN const char* name|I32 create
 Apd	|HV*	|get_hv		|NN const char* name|I32 create
-Apd	|CV*	|get_cv		|NN const char* name|I32 create
+Apd	|CV*	|get_cv		|NN const char* name|I32 flags
+Apd	|CV*	|get_cvn_flags	|NN const char* name|STRLEN len|I32 flags
 Ap	|int	|init_i18nl10n	|int printwarn
 Ap	|int	|init_i18nl14n	|int printwarn
 Ap	|void	|new_collate	|NULLOK const char* newcoll
diff --git a/embed.h b/embed.h
index bf4f169e79..eae6f3d392 100644
--- a/embed.h
+++ b/embed.h
@@ -647,6 +647,7 @@
 #define get_av			Perl_get_av
 #define get_hv			Perl_get_hv
 #define get_cv			Perl_get_cv
+#define get_cvn_flags		Perl_get_cvn_flags
 #define init_i18nl10n		Perl_init_i18nl10n
 #define init_i18nl14n		Perl_init_i18nl14n
 #define new_collate		Perl_new_collate
@@ -2858,6 +2859,7 @@
 #define get_av(a,b)		Perl_get_av(aTHX_ a,b)
 #define get_hv(a,b)		Perl_get_hv(aTHX_ a,b)
 #define get_cv(a,b)		Perl_get_cv(aTHX_ a,b)
+#define get_cvn_flags(a,b,c)	Perl_get_cvn_flags(aTHX_ a,b,c)
 #define init_i18nl10n(a)	Perl_init_i18nl10n(aTHX_ a)
 #define init_i18nl14n(a)	Perl_init_i18nl14n(aTHX_ a)
 #define new_collate(a)		Perl_new_collate(aTHX_ a)
diff --git a/global.sym b/global.sym
index d59dd24f65..21d7532522 100644
--- a/global.sym
+++ b/global.sym
@@ -368,6 +368,7 @@ Perl_get_sv
 Perl_get_av
 Perl_get_hv
 Perl_get_cv
+Perl_get_cvn_flags
 Perl_init_i18nl10n
 Perl_init_i18nl14n
 Perl_new_collate
diff --git a/gv.c b/gv.c
index e4c59b5a31..8630c1b059 100644
--- a/gv.c
+++ b/gv.c
@@ -806,8 +806,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     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 & ~GV_NOTQUAL;
+    const I32 add = flags & ~GV_NOADD_MASK;
     const char *const name_end = nambeg + full_len;
     const char *const name_em1 = name_end - 1;
 
diff --git a/gv.h b/gv.h
index 2463335766..cbc68403e9 100644
--- a/gv.h
+++ b/gv.h
@@ -207,6 +207,10 @@ Return the SV from the GV.
 /*      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_NOADD_MASK	(SVf_UTF8|GV_NOADD_NOINIT|GV_NOEXPAND|GV_NOTQUAL)
+/* The bit flags that don't cause gv_fetchpv() to add a symbol if not found */
+
 #define gv_fullname3(sv,gv,prefix) gv_fullname4(sv,gv,prefix,TRUE)
 #define gv_efullname3(sv,gv,prefix) gv_efullname4(sv,gv,prefix,TRUE)
 #define gv_fetchmethod(stash, name) gv_fetchmethod_autoload(stash, name, TRUE)
diff --git a/op.c b/op.c
index 40275ab472..9e565fe5f9 100644
--- a/op.c
+++ b/op.c
@@ -2063,7 +2063,8 @@ Perl_newPROG(pTHX_ OP *o)
 
 	/* Register with debugger */
 	if (PERLDB_INTER) {
-	    CV * const cv = get_cv("DB::postponed", FALSE);
+	    CV * const cv
+		= Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
 	    if (cv) {
 		dSP;
 		PUSHMARK(SP);
diff --git a/perl.c b/perl.c
index fdcbcbdaaf..88bbcbbd80 100644
--- a/perl.c
+++ b/perl.c
@@ -2476,33 +2476,47 @@ Perl_get_hv(pTHX_ const char *name, I32 create)
 /*
 =head1 CV Manipulation Functions
 
+=for apidoc p||get_cvn_flags
+
+Returns the CV of the specified Perl subroutine.  C<flags> are passed to
+C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
+exist then it will be declared (which has the same effect as saying
+C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
+then NULL is returned.
+
 =for apidoc p||get_cv
 
-Returns the CV of the specified Perl subroutine.  If C<create> is set and
-the Perl subroutine does not exist then it will be declared (which has the
-same effect as saying C<sub name;>).  If C<create> is not set and the
-subroutine does not exist then NULL is returned.
+Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
 
 =cut
 */
 
 CV*
-Perl_get_cv(pTHX_ const char *name, I32 create)
+Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
 {
-    GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
+    GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
     /* XXX unsafe for threads if eval_owner isn't held */
     /* XXX this is probably not what they think they're getting.
      * It has the same effect as "sub name;", i.e. just a forward
      * declaration! */
-    if (create && !GvCVu(gv))
+    if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
+	SV *const sv = newSVpvn(name,len);
+	SvFLAGS(sv) |= flags & SVf_UTF8;
     	return newSUB(start_subparse(FALSE, 0),
-		      newSVOP(OP_CONST, 0, newSVpv(name,0)),
+		      newSVOP(OP_CONST, 0, sv),
 		      NULL, NULL);
+    }
     if (gv)
 	return GvCVu(gv);
     return NULL;
 }
 
+CV*
+Perl_get_cv(pTHX_ const char *name, I32 flags)
+{
+    return get_cvn_flags(name, strlen(name), flags);
+}
+
 /* Be sure to refetch the stack pointer after calling these routines. */
 
 /*
diff --git a/perlio.c b/perlio.c
index 54aab1b1ab..6e2d9e1570 100644
--- a/perlio.c
+++ b/perlio.c
@@ -796,7 +796,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 	} else {
 	    SV * const pkgsv = newSVpvs("PerlIO");
 	    SV * const layer = newSVpvn(name, len);
-	    CV * const cv    = get_cv("PerlIO::Layer::NoWarnings", FALSE);
+	    CV * const cv    = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
 	    ENTER;
 	    SAVEINT(PL_in_load_module);
 	    if (cv) {
diff --git a/pp_hot.c b/pp_hot.c
index 476fd805d0..f1ad3edee5 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2710,6 +2710,7 @@ PP(pp_entersub)
     default:
 	if (!SvROK(sv)) {
 	    const char *sym;
+	    STRLEN len;
 	    if (sv == &PL_sv_yes) {		/* unfound import, ignore */
 		if (hasargs)
 		    SP = PL_stack_base + POPMARK;
@@ -2719,16 +2720,22 @@ PP(pp_entersub)
 		mg_get(sv);
 		if (SvROK(sv))
 		    goto got_rv;
-		sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
+		if (SvPOKp(sv)) {
+		    sym = SvPVX_const(sv);
+		    len = SvCUR(sv);
+		} else {
+		    sym = NULL;
+		    len = 0;
+		}
 	    }
 	    else {
-		sym = SvPV_nolen_const(sv);
+		sym = SvPV_const(sv, len);
             }
 	    if (!sym)
 		DIE(aTHX_ PL_no_usym, "a subroutine");
 	    if (PL_op->op_private & HINT_STRICT_REFS)
 		DIE(aTHX_ PL_no_symref, sym, "a subroutine");
-	    cv = get_cv(sym, TRUE);
+	    cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
 	    break;
 	}
   got_rv:
diff --git a/proto.h b/proto.h
index 5d0f5517d9..662f09c114 100644
--- a/proto.h
+++ b/proto.h
@@ -1769,7 +1769,10 @@ PERL_CALLCONV AV*	Perl_get_av(pTHX_ const char* name, I32 create)
 PERL_CALLCONV HV*	Perl_get_hv(pTHX_ const char* name, I32 create)
 			__attribute__nonnull__(pTHX_1);
 
-PERL_CALLCONV CV*	Perl_get_cv(pTHX_ const char* name, I32 create)
+PERL_CALLCONV CV*	Perl_get_cv(pTHX_ const char* name, I32 flags)
+			__attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV CV*	Perl_get_cvn_flags(pTHX_ const char* name, STRLEN len, I32 flags)
 			__attribute__nonnull__(pTHX_1);
 
 PERL_CALLCONV int	Perl_init_i18nl10n(pTHX_ int printwarn);
@@ -2603,10 +2606,6 @@ PERL_CALLCONV int	Perl_yyparse(pTHX);
 PERL_CALLCONV void	Perl_parser_free(pTHX_ const yy_parser *)
 			__attribute__nonnull__(pTHX_1);
 
-PERL_CALLCONV yy_parser*	Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
-			__attribute__nonnull__(pTHX_1)
-			__attribute__nonnull__(pTHX_2);
-
 PERL_CALLCONV int	Perl_yywarn(pTHX_ const char* s)
 			__attribute__nonnull__(pTHX_1);
 
@@ -2864,6 +2863,10 @@ PERL_CALLCONV void	Perl_rvpv_dup(pTHX_ SV* dstr, const SV *sstr, CLONE_PARAMS* p
 			__attribute__nonnull__(pTHX_2)
 			__attribute__nonnull__(pTHX_3);
 
+PERL_CALLCONV yy_parser*	Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+
 #endif
 PERL_CALLCONV PTR_TBL_t*	Perl_ptr_table_new(pTHX)
 			__attribute__malloc__
diff --git a/t/op/ref.t b/t/op/ref.t
index 1c713a977e..9d8818259e 100755
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -8,7 +8,7 @@ BEGIN {
 require 'test.pl';
 use strict qw(refs subs);
 
-plan(119);
+plan(121);
 
 # Test glob operations.
 
@@ -468,6 +468,12 @@ TODO: {
     my $glob2 = *{$name2};
 
     isnt ($glob1, $glob2, "We get different typeglobs");
+
+    *{$name1} = sub {"One"};
+    *{$name2} = sub {"Two"};
+
+    is (&{$name1}, "One");
+    is (&{$name2}, "Two");
 }
 
 # test derefs after list slice
diff --git a/toke.c b/toke.c
index 755f22c4d6..f9f0627121 100644
--- a/toke.c
+++ b/toke.c
@@ -4795,12 +4795,12 @@ Perl_yylex(pTHX)
 				t++;
 			    } while (isSPACE(*t));
 			    if (isIDFIRST_lazy_if(t,UTF)) {
-				STRLEN dummylen;
+				STRLEN len;
 				t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
-					      &dummylen);
+					      &len);
 				while (isSPACE(*t))
 				    t++;
-				if (*t == ';' && get_cv(tmpbuf, FALSE))
+				if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
 				    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 						"You need to quote \"%s\"",
 						tmpbuf);
@@ -10738,7 +10738,8 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL
 	    }
 	    if (PL_lex_state == LEX_NORMAL) {
 		if (ckWARN(WARN_AMBIGUOUS) &&
-		    (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
+		    (keyword(dest, d - dest, 0)
+		     || get_cvn_flags(dest, d - dest, 0)))
 		{
 		    if (funny == '#')
 			funny = '@';