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

diff --git a/embed.fnc b/embed.fnc
index 2801844..0847142 100644 (file)
--- 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 bf4f169..eae6f3d 100644 (file)
--- 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 d59dd24..21d7532 100644 (file)
--- 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 e4c59b5..8630c1b 100644 (file)
--- 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 2463335..cbc6840 100644 (file)
--- 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 40275ab..9e565fe 100644 (file)
--- 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 fdcbcbd..88bbcbb 100644 (file)
--- 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 54aab1b..6e2d9e1 100644 (file)
--- 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 476fd80..f1ad3ed 100644 (file)
--- 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 5d0f551..662f09c 100644 (file)
--- 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 1c713a9..9d88182 100755 (executable)
--- 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 755f22c..f9f0627 100644 (file)
--- 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 = '@';