From: Nicholas Clark <nick@ccl4.org>
Date: Mon, 15 Jan 2007 14:38:58 +0000 (+0000)
Subject: Add get_cvn_flags(), which is like get_cv() but takes a length. This
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=780a5241a93925d81e932db73df46ee749b203b9;p=p5sagit%2Fp5-mst-13.2.git
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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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 = '@';