o->op_ppaddr = PL_ppaddr[type]; \
} STMT_END
-STATIC SV*
-S_gv_ename(pTHX_ GV *gv)
-{
- SV* const tmpsv = sv_newmortal();
-
- PERL_ARGS_ASSERT_GV_ENAME;
-
- gv_efullname3(tmpsv, gv, NULL);
- return tmpsv;
-}
-
STATIC OP *
S_no_fh_allowed(pTHX_ OP *o)
{
}
STATIC OP *
-S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
-{
- PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
- yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)),
- SvUTF8(namesv) | flags);
- return o;
-}
-
-STATIC OP *
S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
{
PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
return o;
}
-STATIC OP *
-S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
-{
- PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
-
- yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
- SvUTF8(namesv) | flags);
- return o;
-}
-
STATIC void
S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
{
STATIC void
S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
{
- SV * const namesv = gv_ename(gv);
+ SV * const namesv = cv_name((CV *)gv, NULL);
PERL_ARGS_ASSERT_BAD_TYPE_GV;
yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
SvREFCNT_inc_simple_void(gv);
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
- /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
- * may still exist on the pad */
pad_swipe(cPADOPo->op_padix, TRUE);
cPADOPo->op_padix = 0;
}
case OP_PUSHRE:
#ifdef USE_ITHREADS
if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
- /* No GvIN_PAD_off here, because other references may still
- * exist on the pad */
pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
}
#else
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
padop->op_padix =
- pad_alloc(type, IS_PADGV(sv) ? SVf_READONLY : SVs_PADTMP);
+ pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
assert(sv);
PERL_ARGS_ASSERT_NEWGVOP;
#ifdef USE_ITHREADS
- GvIN_PAD_on(gv);
return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
#else
return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
-#endif
bool special = FALSE;
+#endif
if (o_is_gv) {
gv = (GV*)o;
assert(CvGV(cv) == gv);
}
else {
+ dVAR;
U32 hash;
PERL_HASH(hash, name, namlen);
CvNAME_HEK_set(cv,
share_hek(name,
- name_is_utf8 ? -namlen : namlen,
+ name_is_utf8
+ ? -(SSize_t)namlen
+ : (SSize_t)namlen,
hash));
}
if (!CvHASGV(cv)) {
if (isGV(gv)) CvGV_set(cv, gv);
else {
+ dVAR;
U32 hash;
PERL_HASH(hash, name, namlen);
CvNAME_HEK_set(cv, share_hek(name,
- name_is_utf8 ? -namlen : namlen,
+ name_is_utf8
+ ? -(SSize_t)namlen
+ : (SSize_t)namlen,
hash));
}
CvFILE_set_from_cop(cv, PL_curcop);
if (PL_parser && PL_parser->error_count)
clear_special_blocks(name, gv, cv);
else
- special = process_special_blocks(floor, name, gv, cv);
+#ifdef PERL_DEBUG_READONLY_OPS
+ special =
+#endif
+ process_special_blocks(floor, name, gv, cv);
}
}
assert (sizeof(PADOP) <= sizeof(SVOP));
kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
- if (isGV(gv)) GvIN_PAD_on(gv);
PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
#else
kid->op_sv = SvREFCNT_inc_simple_NN(gv);
kid->op_next = kid;
o->op_flags |= OPf_SPECIAL;
}
+ else if (kid->op_type == OP_CONST
+ && kid->op_private & OPpCONST_BARE) {
+ char tmpbuf[256];
+ STRLEN len;
+ PADOFFSET off;
+ const char * const name = SvPV(kSVOP_sv, len);
+ *tmpbuf = '&';
+ assert (len < 256);
+ Copy(name, tmpbuf+1, len, char);
+ off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
+ if (off != NOT_IN_PAD) {
+ if (PAD_COMPNAME_FLAGS_isOUR(off)) {
+ SV * const fq =
+ newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
+ sv_catpvs(fq, "::");
+ sv_catsv(fq, kSVOP_sv);
+ SvREFCNT_dec_NN(kSVOP_sv);
+ kSVOP->op_sv = fq;
+ }
+ else {
+ OP * const padop = newOP(OP_PADCV, 0);
+ padop->op_targ = off;
+ cUNOPx(firstkid)->op_first = padop;
+ op_free(kid);
+ }
+ }
+ }
firstkid = OP_SIBLING(firstkid);
}
}
if (SvTYPE((SV*)cv) != SVt_PVCV)
return NULL;
- if (flags & RV2CVOPCV_RETURN_NAME_GV) {
- if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv))
+ if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
+ if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
+ && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
gv = CvGV(cv);
return (CV*)gv;
} else {
OP* o3 = aop;
if (proto >= proto_end)
- return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
+ {
+ SV * const namesv = cv_name((CV *)namegv, NULL);
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
+ SVfARG(namesv)), SvUTF8(namesv));
+ return entersubop;
+ }
switch (*proto) {
case ';':
continue;
default:
oops: {
- SV* const tmpsv = sv_newmortal();
- gv_efullname3(tmpsv, namegv, NULL);
Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
- SVfARG(tmpsv), SVfARG(protosv));
+ SVfARG(cv_name((CV *)namegv, NULL)),
+ SVfARG(protosv));
}
}
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
- return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
+ {
+ SV * const namesv = cv_name((CV *)namegv, NULL);
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
+ SVfARG(namesv)), SvUTF8(namesv));
+ }
return entersubop;
}
=cut
*/
-void
-Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
+static void
+S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
+ U8 *flagsp)
{
MAGIC *callmg;
- PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
- PERL_UNUSED_CONTEXT;
callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
if (callmg) {
*ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
*ckobj_p = callmg->mg_obj;
+ if (flagsp) *flagsp = callmg->mg_flags;
} else {
*ckfun_p = Perl_ck_entersub_args_proto_or_list;
*ckobj_p = (SV*)cv;
+ if (flagsp) *flagsp = 0;
}
}
+void
+Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
+{
+ PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
+ PERL_UNUSED_CONTEXT;
+ S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
+}
+
/*
-=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
Sets the function that will be used to fix up a call to I<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
In this call, I<entersubop> is a pointer to the C<entersub> op,
-which may be replaced by the check function, and I<namegv> is a GV
-supplying the name that should be used by the check function to refer
+which may be replaced by the check function, and I<namegv> supplies
+the name that should be used by the check function to refer
to the callee of the C<entersub> op if it needs to emit any diagnostics.
It is permitted to apply the check function in non-standard situations,
such as to a call to a different subroutine or to a method call.
+I<namegv> may not actually be a GV. For efficiency, perl may pass a
+CV or other SV instead. Whatever is passed can be used as the first
+argument to L</cv_name>. You can force perl to pass a GV by including
+C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
+
The current setting for a particular CV can be retrieved by
L</cv_get_call_checker>.
+=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+
+The original form of L</cv_set_call_checker_flags>, which passes it the
+C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
+
=cut
*/
Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
{
PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
+ cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
+}
+
+void
+Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
+ SV *ckobj, U32 flags)
+{
+ PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
if (SvMAGICAL((SV*)cv))
mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
SvREFCNT_inc_simple_void_NN(ckobj);
callmg->mg_flags |= MGf_REFCOUNTED;
}
- callmg->mg_flags |= MGf_COPY;
+ callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
+ | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
}
}
aop = OP_SIBLING(aop);
for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
- namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
+ namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
o->op_private &= ~1;
o->op_private |= OPpENTERSUB_HASTARG;
} else {
Perl_call_checker ckfun;
SV *ckobj;
- cv_get_call_checker(cv, &ckfun, &ckobj);
- if (!namegv) { /* expletive! */
- /* XXX The call checker API is public. And it guarantees that
- a GV will be provided with the right name. So we have
- to create a GV. But it is still not correct, as its
- stringification will include the package. What we
- really need is a new call checker API that accepts a
- GV or string (or GV or CV). */
- HEK * const hek = CvNAME_HEK(cv);
+ U8 flags;
+ S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
+ if (!namegv) {
+ /* The original call checker API guarantees that a GV will be
+ be provided with the right name. So, if the old API was
+ used (or the REQUIRE_GV flag was passed), we have to reify
+ the CV’s GV, unless this is an anonymous sub. This is not
+ ideal for lexical subs, as its stringification will include
+ the package. But it is the best we can do. */
+ if (flags & MGf_REQUIRE_GV) {
+ if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
+ namegv = CvGV(cv);
+ }
+ else namegv = MUTABLE_GV(cv);
/* After a syntax error in a lexical sub, the cv that
rv2cv_op_cv returns may be a nameless stub. */
- if (!hek) return ck_entersub_args_list(o);;
- namegv = (GV *)sv_newmortal();
- gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
- SVf_UTF8 * !!HEK_UTF8(hek));
+ if (!namegv) return ck_entersub_args_list(o);
+
}
return ckfun(aTHX_ o, namegv, ckobj);
}