don't use a slab, but allocate the OP directly from the heap. */
if (!PL_compcv || CvROOT(PL_compcv)
|| (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
- return PerlMemShared_calloc(1, sz);
+ {
+ o = (OP*)PerlMemShared_calloc(1, sz);
+ goto gotit;
+ }
/* While the subroutine is under construction, the slabs are accessed via
CvSTART(), to avoid needing to expand PVCV by one pointer for something
*too = o->op_next;
Zero(o, opsz, I32 *);
o->op_slabbed = 1;
- return (void *)o;
+ goto gotit;
}
}
slot = &slab2->opslab_slots;
INIT_OPSLOT;
DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
+
+ gotit:
+ /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
+ o->op_lastsib = 1;
+ assert(!o->op_sibling);
+
return (void *)o;
}
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)",
return;
type = o->op_type;
+
+ /* an op should only ever acquire op_private flags that we know about.
+ * If this fails, you may need to fix something in regen/op_private */
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+
if (o->op_private & OPpREFCOUNTED) {
switch (type) {
case OP_LEAVESUB:
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
op_sibling nodes. By analogy with the perl-level splice() function, allows
you to delete zero or more sequential nodes, replacing them with zero or
more different nodes. Performs the necessary op_first/op_last
-housekeeping on the parent node and op_silbing manipulation on the
-children. The op_silbing field of the last deleted node will be set to
-NULL.
+housekeeping on the parent node and op_sibling manipulation on the
+children. The last deleted node will be marked as as the last node by
+updating the op_sibling or op_lastsib field as appropriate.
Note that op_next is not manipulated, and nodes are not freed; that is the
-responsibility of the caller. It also won't create new a list op for an empty
-list etc; use higher-level functions like op_append_elem() for that.
+responsibility of the caller. It also won't create a new list op for an
+empty list etc; use higher-level functions like op_append_elem() for that.
parent is the parent node of the sibling chain.
insert is the first of a chain of nodes to be inserted in place of the nodes.
If NULL, no nodes are inserted.
-The head of the chain of deleted op is returned, or NULL uif no ops were
+The head of the chain of deleted ops is returned, or NULL if no ops were
deleted.
For example:
------ ----- ----- -------
P P
- splice(P, A, 2, X-Y) | | B-C
- A-B-C-D A-X-Y-D
+ splice(P, A, 2, X-Y-Z) | | B-C
+ A-B-C-D A-X-Y-Z-D
P P
splice(P, NULL, 1, X-Y) | | A
A-B-C-D X-Y-B-C-D
P P
- splice(P, NULL, 1, NULL) | | A
- A-B-C-D B-C-D
+ splice(P, NULL, 3, NULL) | | A-B-C
+ A-B-C-D D
P P
splice(P, B, 0, X-Y) | | NULL
*/
OP *
-Perl_op_sibling_splice(pTHX_ OP *parent, OP *start, int del_count, OP* insert)
+Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
{
- dVAR;
OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
OP *rest;
OP *last_del = NULL;
last_del = OP_SIBLING(last_del);
rest = OP_SIBLING(last_del);
OP_SIBLING_set(last_del, NULL);
+ last_del->op_lastsib = 1;
}
else
rest = first;
while (OP_HAS_SIBLING(last_ins))
last_ins = OP_SIBLING(last_ins);
OP_SIBLING_set(last_ins, rest);
+ last_ins->op_lastsib = rest ? 0 : 1;
}
else
insert = rest;
- if (start)
+ if (start) {
OP_SIBLING_set(start, insert);
+ start->op_lastsib = insert ? 0 : 1;
+ }
else
cLISTOPx(parent)->op_first = insert;
if (!rest) {
- /* update op_last */
+ /* update op_last etc */
U32 type = parent->op_type;
+ OP *lastop;
if (type == OP_NULL)
type = parent->op_targ;
type = PL_opargs[type] & OA_CLASS_MASK;
+ lastop = last_ins ? last_ins : start ? start : NULL;
if ( type == OA_BINOP
|| type == OA_LISTOP
|| type == OA_PMOP
|| type == OA_LOOP
)
- cLISTOPx(parent)->op_last =
- (last_ins ? last_ins : start ? start : NULL);
+ cLISTOPx(parent)->op_last = lastop;
+
+ if (lastop) {
+ lastop->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ lastop->op_sibling = parent;
+#endif
+ }
}
return last_del ? first : NULL;
}
+/*
+=for apidoc op_parent
+
+returns the parent OP of o, if it has a parent. Returns NULL otherwise.
+(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
+work.
+
+=cut
+*/
+
+OP *
+Perl_op_parent(OP *o)
+{
+ PERL_ARGS_ASSERT_OP_PARENT;
+#ifdef PERL_OP_PARENT
+ while (OP_HAS_SIBLING(o))
+ o = OP_SIBLING(o);
+ return o->op_sibling;
+#else
+ PERL_UNUSED_ARG(o);
+ return NULL;
+#endif
+}
+
/* replace the sibling following start with a new UNOP, which becomes
* the parent of the original sibling; e.g.
S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
LOGOP *logop;
+ OP *kid = first;
NewOp(1101, logop, 1, LOGOP);
- logop->op_type = type;
+ logop->op_type = (OPCODE)type;
logop->op_first = first;
logop->op_other = other;
logop->op_flags = OPf_KIDS;
+ while (kid && OP_HAS_SIBLING(kid))
+ kid = OP_SIBLING(kid);
+ if (kid) {
+ kid->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ kid->op_sibling = (OP*)logop;
+#endif
+ }
return logop;
}
o->op_next = LINKLIST(first);
kid = first;
for (;;) {
- if (OP_HAS_SIBLING(kid)) {
- kid->op_next = LINKLIST(OP_SIBLING(kid));
- kid = OP_SIBLING(kid);
+ OP *sibl = OP_SIBLING(kid);
+ if (sibl) {
+ kid->op_next = LINKLIST(sibl);
+ kid = sibl;
} else {
kid->op_next = o;
break;
OP *kid;
#ifdef DEBUGGING
- /* check that op_last points to the last sibling */
+ /* check that op_last points to the last sibling, and that
+ * the last op_sibling field points back to the parent, and
+ * that the only ops with KIDS are those which are entitled to
+ * them */
U32 type = o->op_type;
U32 family;
+ bool has_last;
if (type == OP_NULL) {
type = o->op_targ;
}
family = PL_opargs[type] & OA_CLASS_MASK;
- if (
- /* XXX list form of 'x' is has a null op_last. This is wrong,
- * but requires too much hacking (e.g. in Deparse) to fix for
- * now */
- !(type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST))
- && (
- family == OA_BINOP
- || family == OA_LISTOP
- || family == OA_PMOP
- || family == OA_LOOP
- )
- )
- {
- OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
- if (!OP_HAS_SIBLING(kid)) {
- if (kid != cLISTOPo->op_last)
- {
- assert(kid == cLISTOPo->op_last);
- }
- }
+ has_last = ( family == OA_BINOP
+ || family == OA_LISTOP
+ || family == OA_PMOP
+ || family == OA_LOOP
+ );
+ assert( has_last /* has op_first and op_last, or ...
+ ... has (or may have) op_first: */
+ || family == OA_UNOP
+ || family == OA_LOGOP
+ || family == OA_BASEOP_OR_UNOP
+ || family == OA_FILESTATOP
+ || family == OA_LOOPEXOP
+ /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
+ || type == OP_SASSIGN
+ || type == OP_CUSTOM
+ || type == OP_NULL /* new_logop does this */
+ );
+ /* XXX list form of 'x' is has a null op_last. This is wrong,
+ * but requires too much hacking (e.g. in Deparse) to fix for
+ * now */
+ if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
+ assert(has_last);
+ has_last = 0;
+ }
+
+ for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
+# ifdef PERL_OP_PARENT
+ if (!OP_HAS_SIBLING(kid)) {
+ if (has_last)
+ assert(kid == cLISTOPo->op_last);
+ assert(kid->op_sibling == o);
+ }
+# else
+ if (OP_HAS_SIBLING(kid)) {
+ assert(!kid->op_lastsib);
}
+ else {
+ assert(kid->op_lastsib);
+ if (has_last)
+ assert(kid == cLISTOPo->op_last);
+ }
+# endif
}
#endif
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
- /* Both ENTERSUB and RV2CV use this bit, but for different pur-
- poses, so we need it clear. */
- o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
else { /* Compile-time error message: */
OP *kid = cUNOPo->op_first;
CV *cv;
+ GV *gv;
if (kid->op_type != OP_PUSHMARK) {
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
break;
}
- cv = GvCV(kGVOP_gv);
+ gv = kGVOP_gv;
+ cv = isGV(gv)
+ ? GvCV(gv)
+ : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? MUTABLE_CV(SvRV(gv))
+ : NULL;
if (!cv)
break;
if (CvLVALUE(cv))
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
- o->op_private &= ~1;
}
else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
COP not_compiling;
+ U8 oldwarn = PL_dowarn;
dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
{
const char *s = SvPVX_const(sv);
while (s < SvEND(sv)) {
- if (*s == 'p' || *s == 'P') goto nope;
+ if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
s++;
}
}
PL_diehook = NULL;
JMPENV_PUSH(ret);
+ /* Effective $^W=1. */
+ if ( ! (PL_dowarn & G_WARN_ALL_MASK))
+ PL_dowarn |= G_WARN_ON;
+
switch (ret) {
case 0:
CALLRUNOPS(aTHX);
Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
JMPENV_POP;
+ PL_dowarn = oldwarn;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
PL_curcop = &PL_compiling;
return list(o);
}
+/* convert o (and any siblings) into a list if not already, then
+ * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
+ */
+
OP *
Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
{
dVAR;
if (type < 0) type = -type, flags |= OPf_SPECIAL;
- if (!o || o->op_type != OP_LIST) {
- OP* last = o;
- o = newLISTOP(OP_LIST, 0, o, NULL);
- if (last) {
- while (OP_HAS_SIBLING(last))
- last = OP_SIBLING(last);
- cLISTOPo->op_last = last;
- }
- }
+ if (!o || o->op_type != OP_LIST)
+ o = force_list(o, 0);
else
o->op_flags &= ~OPf_WANT;
if (last->op_type != (unsigned)type)
return op_append_elem(type, first, last);
+ ((LISTOP*)first)->op_last->op_lastsib = 0;
OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
+ ((LISTOP*)first)->op_last->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ ((LISTOP*)first)->op_last->op_sibling = first;
+#endif
first->op_flags |= (last->op_flags & OPf_KIDS);
return newOP(OP_STUB, 0);
}
+/* promote o and any siblings to be a list if its not already; i.e.
+ *
+ * o - A - B
+ *
+ * becomes
+ *
+ * list
+ * |
+ * pushmark - o - A - B
+ *
+ * If nullit it true, the list op is nulled.
+ */
+
static OP *
-S_force_list(pTHX_ OP *o)
+S_force_list(pTHX_ OP *o, bool nullit)
{
if (!o || o->op_type != OP_LIST) {
- OP* last = o;
- o = newLISTOP(OP_LIST, 0, o, NULL);
- if (last) {
- while (OP_HAS_SIBLING(last))
- last = OP_SIBLING(last);
- cLISTOPo->op_last = last;
+ OP *rest = NULL;
+ if (o) {
+ /* manually detach any siblings then add them back later */
+ rest = OP_SIBLING(o);
+ OP_SIBLING_set(o, NULL);
+ o->op_lastsib = 1;
}
+ o = newLISTOP(OP_LIST, 0, o, NULL);
+ if (rest)
+ op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
}
- op_null(o);
+ if (nullit)
+ op_null(o);
return o;
}
listop->op_last = last;
if (type == OP_LIST) {
OP* const pushop = newOP(OP_PUSHMARK, 0);
+ pushop->op_lastsib = 0;
OP_SIBLING_set(pushop, first);
listop->op_first = pushop;
listop->op_flags |= OPf_KIDS;
if (!last)
listop->op_last = pushop;
}
+ if (first)
+ first->op_lastsib = 0;
+ if (listop->op_last) {
+ listop->op_last->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ listop->op_last->op_sibling = (OP*)listop;
+#endif
+ }
return CHECKOP(type, listop);
}
o->op_next = o;
o->op_private = (U8)(0 | (flags >> 8));
-
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
if (PL_opargs[type] & OA_TARGET)
if (!first)
first = newOP(OP_STUB, 0);
if (PL_opargs[type] & OA_MARK)
- first = force_list(first);
+ first = force_list(first, 1);
NewOp(1101, unop, 1, UNOP);
unop->op_type = (OPCODE)type;
unop->op_first = first;
unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
+
+#ifdef PERL_OP_PARENT
+ if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
+ first->op_sibling = (OP*)unop;
+#endif
+
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
return (OP*)unop;
else {
binop->op_private = (U8)(2 | (flags >> 8));
OP_SIBLING_set(first, last);
+ first->op_lastsib = 0;
}
+#ifdef PERL_OP_PARENT
+ if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
+ last->op_sibling = (OP*)binop;
+#endif
+
binop = (BINOP*)CHECKOP(type, binop);
if (binop->op_next || binop->op_type != (OPCODE)type)
return (OP*)binop;
binop->op_last = OP_SIBLING(binop->op_first);
+#ifdef PERL_OP_PARENT
+ if (binop->op_last)
+ binop->op_last->op_sibling = (OP*)binop;
+#endif
return fold_constants(op_integerize(op_std_init((OP *)binop)));
}
cv_targ = expr->op_targ;
expr = newUNOP(OP_REFGEN, 0, expr);
- expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
+ expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
}
rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
- padop->op_padix = pad_alloc(type, SVs_PADTMP);
+ padop->op_padix =
+ 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));
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_parser->expect = XSTATE;
op_free(o);
}
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_parser->expect = XSTATE;
PL_cop_seqmax++; /* Purely for B::*'s benefit */
if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
PL_cop_seqmax++;
Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
{
return newBINOP(OP_LSLICE, flags,
- list(force_list(subscript)),
- list(force_list(listval)) );
+ list(force_list(subscript, 1)),
+ list(force_list(listval, 1)) );
}
STATIC I32
PL_modcount = 0;
left = op_lvalue(left, OP_AASSIGN);
- curop = list(force_list(left));
- o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
+ curop = list(force_list(left, 1));
+ o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
o->op_private = (U8)(0 | (flags >> 8));
if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
start = LINKLIST(first);
first->op_next = (OP*)logop;
- /* make first, trueop, falseop silbings */
+ /* make first, trueop, falseop siblings */
op_sibling_splice((OP*)logop, first, 0, trueop);
op_sibling_splice((OP*)logop, trueop, 0, falseop);
}
if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
- expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
+ expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
iterflags |= OPf_STACKED;
}
else if (expr->op_type == OP_NULL &&
iterflags |= OPf_STACKED;
}
else {
- expr = op_lvalue(force_list(expr), OP_GREPSTART);
+ expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
}
loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
+#ifdef PERL_OP_PARENT
+ assert(loop->op_last->op_sibling == (OP*)loop);
+ loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
+#endif
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
return looks_like_bool(cLOGOPo->op_first);
case OP_AND:
+ {
+ OP* sibl = OP_SIBLING(cLOGOPo->op_first);
+ ASSUME(sibl);
return (
looks_like_bool(cLOGOPo->op_first)
- && looks_like_bool(OP_SIBLING(cLOGOPo->op_first)));
+ && looks_like_bool(sibl));
+ }
case OP_NULL:
case OP_SCALAR:
return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
+/* must not conflict with SVf_UTF8 */
+#define CV_CKPROTO_CURSTASH 0x1
+
void
Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len, const U32 flags)
{
SV *name = NULL, *msg;
- const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
+ const char * cvp = SvROK(cv)
+ ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
+ ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
+ : ""
+ : CvPROTO(cv);
STRLEN clen = CvPROTOLEN(cv), plen = len;
PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
gv_efullname3(name = sv_newmortal(), gv, NULL);
else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
+ else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
+ name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
+ sv_catpvs(name, "::");
+ if (SvROK(gv)) {
+ assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
+ assert (CvNAMED(SvRV_const(gv)));
+ sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
+ }
+ else sv_catsv(name, (SV *)gv);
+ }
else name = (SV *)gv;
}
sv_setpvs(msg, "Prototype mismatch:");
{
if (!cv)
return NULL;
+ if (SvROK(cv)) return SvRV((SV *)cv);
assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
}
return NULL;
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
+ else if (type == OP_UNDEF && !o->op_private) {
+ sv = newSV(0);
+ SAVEFREESV(sv);
+ }
else if (cv && type == OP_CONST) {
sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
if (!sv)
if (CvNAMED(*spot))
hek = CvNAME_HEK(*spot);
else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
CvNAME_HEK_set(*spot, hek =
share_hek(
PadnamePV(name)+1,
- PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
)
);
+ CvLEXICAL_on(*spot);
}
if (mg) {
assert(mg->mg_obj);
*spot = cv;
}
setname:
+ CvLEXICAL_on(cv);
if (!CvNAME_HEK(cv)) {
- CvNAME_HEK_set(cv,
- hek
- ? share_hek_hek(hek)
- : share_hek(PadnamePV(name)+1,
+ if (hek) (void)share_hek_hek(hek);
+ else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
+ hek = share_hek(PadnamePV(name)+1,
PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
- 0)
- );
+ hash);
+ }
+ CvNAME_HEK_set(cv, hek);
}
if (const_sv) goto clone;
/* If the subroutine has no body, no attributes, and no builtin attributes
then it's just a sub declaration, and we may be able to get away with
storing with a placeholder scalar in the symbol table, rather than a
- full GV and CV. If anything is present then it will take a full CV to
+ full CV. If anything is present then it will take a full CV to
store it. */
const I32 gv_fetch_flags
= ec ? GV_NOADD_NOINIT :
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
+ bool special = FALSE;
#endif
if (o_is_gv) {
o = NULL;
has_name = TRUE;
} else if (name) {
- gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
+ /* Try to optimise and avoid creating a GV. Instead, the CV’s name
+ hek and CvSTASH pointer together can imply the GV. If the name
+ contains a package name, then GvSTASH(CvGV(cv)) may differ from
+ CvSTASH, so forego the optimisation if we find any.
+ Also, we may be called from load_module at run time, so
+ PL_curstash (which sets CvSTASH) may not point to the stash the
+ sub is stored in. */
+ const I32 flags =
+ ec ? GV_NOADD_NOINIT
+ : PL_curstash != CopSTASH(PL_curcop)
+ || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
+ ? gv_fetch_flags
+ : GV_ADDMULTI | GV_NOINIT;
+ gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
has_name = TRUE;
} else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV * const sv = sv_newmortal();
gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
has_name = FALSE;
}
-
if (!ec)
- move_proto_attr(&proto, &attrs, gv);
+ move_proto_attr(&proto, &attrs,
+ isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
if (proto) {
assert(proto->op_type == OP_CONST);
goto done;
}
- if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
- maximum a prototype before. */
+ if (!block && SvTYPE(gv) != SVt_PVGV) {
+ /* If we are not defining a new sub and the existing one is not a
+ full GV + CV... */
+ if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
+ /* We are applying attributes to an existing sub, so we need it
+ upgraded if it is a constant. */
+ if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
+ gv_init_pvn(gv, PL_curstash, name, namlen,
+ SVf_UTF8 * name_is_utf8);
+ }
+ else { /* Maybe prototype now, and had at maximum
+ a prototype or const/sub ref before. */
if (SvTYPE(gv) > SVt_NULL) {
cv_ckproto_len_flags((const CV *)gv,
o ? (const GV *)cSVOPo->op_sv : NULL, ps,
ps_len, ps_utf8);
}
- if (ps) {
+ if (!SvROK(gv)) {
+ if (ps) {
sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
- }
- else
+ }
+ else
sv_setiv(MUTABLE_SV(gv), -1);
+ }
SvREFCNT_dec(PL_compcv);
cv = PL_compcv = NULL;
goto done;
+ }
}
- cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
+ cv = (!name || (isGV(gv) && GvCVGEN(gv)))
+ ? NULL
+ : isGV(gv)
+ ? GvCV(gv)
+ : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? (CV *)SvRV(gv)
+ : NULL;
+
if (!block || !ps || *ps || attrs
|| (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
else
const_sv = op_const_sv(block, NULL);
+ if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
+ assert (block);
+ cv_ckproto_len_flags((const CV *)gv,
+ o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+ ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
+ if (SvROK(gv)) {
+ /* All the other code for sub redefinition warnings expects the
+ clobbered sub to be a CV. Instead of making all those code
+ paths more complex, just inline the RV version here. */
+ const line_t oldline = CopLINE(PL_curcop);
+ assert(IN_PERL_COMPILETIME);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ /* This ensures that warnings are reported at the first
+ line of a redefinition, not the last. */
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ /* protect against fatal warnings leaking compcv */
+ SAVEFREESV(PL_compcv);
+
+ if (ckWARN(WARN_REDEFINE)
+ || ( ckWARN_d(WARN_REDEFINE)
+ && ( !const_sv || SvRV(gv) == const_sv
+ || sv_cmp(SvRV(gv), const_sv) )))
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ "Constant subroutine %"SVf" redefined",
+ SVfARG(cSVOPo->op_sv));
+
+ SvREFCNT_inc_simple_void_NN(PL_compcv);
+ CopLINE_set(PL_curcop, oldline);
+ SvREFCNT_dec(SvRV(gv));
+ }
+ }
+
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
if (exists || SvPOK(cv))
cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
- if (exists || GvASSUMECV(gv)) {
+ if (exists || (isGV(gv) && GvASSUMECV(gv))) {
if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
cv = NULL;
else {
CvISXSUB_on(cv);
}
else {
- GvCV_set(gv, NULL);
- cv = newCONSTSUB_flags(
- NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
- const_sv
- );
+ if (isGV(gv)) {
+ if (name) GvCV_set(gv, NULL);
+ cv = newCONSTSUB_flags(
+ NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
+ const_sv
+ );
+ }
+ else {
+ if (!SvROK(gv)) {
+ SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
+ prepare_SV_for_RV((SV *)gv);
+ SvOK_off((SV *)gv);
+ SvROK_on(gv);
+ }
+ SvRV_set(gv, const_sv);
+ }
}
op_free(block);
SvREFCNT_dec(PL_compcv);
CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
OP * const cvstart = CvSTART(cv);
- CvGV_set(cv,gv);
- assert(!CvCVGV_RC(cv));
- assert(CvGV(cv) == gv);
+ if (isGV(gv)) {
+ CvGV_set(cv,gv);
+ assert(!CvCVGV_RC(cv));
+ assert(CvGV(cv) == gv);
+ }
+ else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, name, namlen);
+ CvNAME_HEK_set(cv,
+ share_hek(name,
+ name_is_utf8
+ ? -(SSize_t)namlen
+ : (SSize_t)namlen,
+ hash));
+ }
SvPOK_off(cv);
- CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
+ CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
+ | CvNAMED(cv);
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
CvPADLIST(cv) = CvPADLIST(PL_compcv);
}
else {
cv = PL_compcv;
- if (name) {
+ if (name && isGV(gv)) {
GvCV_set(gv, cv);
GvCVGEN(gv) = 0;
if (HvENAME_HEK(GvSTASH(gv)))
/* sub Foo::bar { (shift)+1 } */
gv_method_changed(gv);
}
+ else if (name) {
+ if (!SvROK(gv)) {
+ SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
+ prepare_SV_for_RV((SV *)gv);
+ SvOK_off((SV *)gv);
+ SvROK_on(gv);
+ }
+ SvRV_set(gv, (SV *)cv);
+ }
}
- if (!CvGV(cv)) {
- CvGV_set(cv, gv);
+ 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
+ ? -(SSize_t)namlen
+ : (SSize_t)namlen,
+ hash));
+ }
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
- HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
+ ? GvSTASH(CvGV(cv))
+ : PL_curstash;
if (!name) SAVEFREESV(cv);
apply_attrs(stash, MUTABLE_SV(cv), attrs);
if (!name) SvREFCNT_inc_simple_void_NN(cv);
if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
- SV * const tmpstr = sv_newmortal();
+ SV * const tmpstr = cv_name(cv,NULL);
GV * const db_postponed = gv_fetchpvs("DB::postponed",
GV_ADDMULTI, SVt_PVHV);
HV *hv;
CopFILE(PL_curcop),
(long)PL_subline,
(long)CopLINE(PL_curcop));
- gv_efullname3(tmpstr, gv, NULL);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
}
}
- if (name && ! (PL_parser && PL_parser->error_count))
- process_special_blocks(floor, name, gv, cv);
+ if (name) {
+ if (PL_parser && PL_parser->error_count)
+ clear_special_blocks(name, gv, cv);
+ else
+#ifdef PERL_DEBUG_READONLY_OPS
+ special =
+#endif
+ process_special_blocks(floor, name, gv, cv);
+ }
}
done:
LEAVE_SCOPE(floor);
#ifdef PERL_DEBUG_READONLY_OPS
/* Watch out for BEGIN blocks */
- if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
+ if (!special) Slab_to_ro(slab);
#endif
return cv;
}
STATIC void
+S_clear_special_blocks(pTHX_ const char *const fullname,
+ GV *const gv, CV *const cv) {
+ const char *colon;
+ const char *name;
+
+ PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
+
+ colon = strrchr(fullname,':');
+ name = colon ? colon + 1 : fullname;
+
+ if ((*name == 'B' && strEQ(name, "BEGIN"))
+ || (*name == 'E' && strEQ(name, "END"))
+ || (*name == 'U' && strEQ(name, "UNITCHECK"))
+ || (*name == 'C' && strEQ(name, "CHECK"))
+ || (*name == 'I' && strEQ(name, "INIT"))) {
+ if (!isGV(gv)) {
+ (void)CvGV(cv);
+ assert(isGV(gv));
+ }
+ GvCV_set(gv, NULL);
+ SvREFCNT_dec_NN(MUTABLE_SV(cv));
+ }
+}
+
+STATIC bool
S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
GV *const gv,
CV *const cv)
if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
dSP;
+ (void)CvGV(cv);
if (floor) LEAVE_SCOPE(floor);
ENTER;
PUSHSTACKi(PERLSI_REQUIRE);
POPSTACK;
LEAVE;
+ return TRUE;
}
else
- return;
+ return FALSE;
} else {
if (*name == 'E') {
if strEQ(name, "END") {
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
} else
- return;
+ return FALSE;
} else if (*name == 'U') {
if (strEQ(name, "UNITCHECK")) {
/* It's never too late to run a unitcheck block */
Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
}
else
- return;
+ return FALSE;
} else if (*name == 'C') {
if (strEQ(name, "CHECK")) {
if (PL_main_start)
Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
}
else
- return;
+ return FALSE;
} else if (*name == 'I') {
if (strEQ(name, "INIT")) {
if (PL_main_start)
Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
}
else
- return;
+ return FALSE;
} else
- return;
+ return FALSE;
DEBUG_x( dump_sub(gv) );
+ (void)CvGV(cv);
GvCV_set(gv,0); /* cv has been hijacked */
+ return TRUE;
}
}
if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
&& (gv = gv_override("readpipe",8)))
{
- /* detach rest of silbings from o and its first child */
+ /* detach rest of siblings from o and its first child */
op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
newop = S_new_entersubop(aTHX_ gv, sibl);
}
else {
const U8 priv = o->op_private;
op_free(o);
- o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
+ /* the newUNOP will recursively call ck_eval(), which will handle
+ * all the stuff at the end of this function, like adding
+ * OP_HINTSEVAL
+ */
+ return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
}
o->op_targ = (PADOFFSET)PL_hints;
if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
PERL_ARGS_ASSERT_CK_RVCONST;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
- if (o->op_type == OP_RV2CV)
- o->op_private &= ~1;
if (kid->op_type == OP_CONST) {
int iscv;
SV * const kidsv = kid->op_sv;
/* Is it a constant from cv_const_sv()? */
- if (SvROK(kidsv) && SvREADONLY(kidsv)) {
- SV * const rsv = SvRV(kidsv);
- const svtype type = SvTYPE(rsv);
- const char *badtype = NULL;
-
- switch (o->op_type) {
- case OP_RV2SV:
- if (type > SVt_PVMG)
- badtype = "a SCALAR";
- break;
- case OP_RV2AV:
- if (type != SVt_PVAV)
- badtype = "an ARRAY";
- break;
- case OP_RV2HV:
- if (type != SVt_PVHV)
- badtype = "a HASH";
- break;
- case OP_RV2CV:
- if (type != SVt_PVCV)
- badtype = "a CODE";
- break;
- }
- if (badtype)
- Perl_croak(aTHX_ "Constant is not %s reference", badtype);
+ if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
return o;
}
if (SvTYPE(kidsv) == SVt_PVAV) return o;
* or we get possible typo warnings. OPpCONST_ENTERED says
* whether the lexer already added THIS instance of this symbol.
*/
- iscv = (o->op_type == OP_RV2CV) * 2;
- do {
- gv = gv_fetchsv(kidsv,
- iscv | !(kid->op_private & OPpCONST_ENTERED),
+ iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
+ gv = gv_fetchsv(kidsv,
+ o->op_type == OP_RV2CV
+ && o->op_private & OPpMAY_RETURN_CONSTANT
+ ? GV_NOEXPAND
+ : iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
: o->op_type == OP_RV2SV
: o->op_type == OP_RV2HV
? SVt_PVHV
: SVt_PVGV);
- } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
if (gv) {
+ if (!isGV(gv)) {
+ assert(iscv);
+ assert(SvROK(gv));
+ if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
+ && SvTYPE(SvRV(gv)) != SVt_PVCV)
+ gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
+ }
kid->op_type = OP_GV;
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
assert (sizeof(PADOP) <= sizeof(SVOP));
- kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
+ kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
- 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);
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
case OP_PADAV:
- case OP_AASSIGN: /* Is this a good idea? */
Perl_croak(aTHX_ "Can't use 'defined(@array)'"
" (Maybe you should just omit the defined()?)");
break;
kid = cLISTOPo->op_first;
if (!kid) {
- o = force_list(o);
+ o = force_list(o, 1);
kid = cLISTOPo->op_first;
}
if (kid->op_type == OP_PUSHMARK)
assignment binop->op_last = OP_SIBLING(binop->op_first); at the
end of Perl_newBINOP(). So need to do it here. */
cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first);
-
+ cBINOPo->op_first->op_lastsib = 0;
+ cBINOPo->op_last ->op_lastsib = 1;
+#ifdef PERL_OP_PARENT
+ cBINOPo->op_last->op_sibling = o;
+#endif
return nullop;
}
}
PERL_ARGS_ASSERT_CK_REPEAT;
if (cBINOPo->op_first->op_flags & OPf_PARENS) {
+ OP* kids;
o->op_private |= OPpREPEAT_DOLIST;
- /* promote the siblings to a list if they're not already */
- op_sibling_splice(o, NULL, -1, force_list(cBINOPo->op_first));
+ kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
+ kids = force_list(kids, 1); /* promote them to a list */
+ op_sibling_splice(o, NULL, 0, kids); /* and add back */
}
else
scalar(o);
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
-
- if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
- SV * const sv = kid->op_sv;
- U32 was_readonly = SvREADONLY(sv);
- char *s;
- STRLEN len;
+ HEK *hek;
+ U32 hash;
+ char *s;
+ STRLEN len;
+ if (kid->op_type == OP_CONST) {
+ SV * const sv = kid->op_sv;
+ U32 const was_readonly = SvREADONLY(sv);
+ if (kid->op_private & OPpCONST_BARE) {
+ dVAR;
const char *end;
if (was_readonly) {
}
SvEND_set(sv, end);
sv_catpvs(sv, ".pm");
+ PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
+ hek = share_hek(SvPVX(sv),
+ (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
+ hash);
+ sv_sethek(sv, hek);
+ unshare_hek(hek);
SvFLAGS(sv) |= was_readonly;
+ }
+ else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
+ s = SvPV(sv, len);
+ if (SvREFCNT(sv) > 1) {
+ kid->op_sv = newSVpvn_share(
+ s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
+ SvREFCNT_dec_NN(sv);
+ }
+ else {
+ dVAR;
+ if (was_readonly) SvREADONLY_off(sv);
+ PERL_HASH(hash, s, len);
+ hek = share_hek(s,
+ SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
+ hash);
+ sv_sethek(sv, hek);
+ unshare_hek(hek);
+ SvFLAGS(sv) |= was_readonly;
+ }
+ }
}
}
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);
}
CV *cv;
GV *gv;
PERL_ARGS_ASSERT_RV2CV_OP_CV;
- if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
+ if (flags & ~RV2CVOPCV_FLAG_MASK)
Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
if (cvop->op_type != OP_RV2CV)
return NULL;
switch (rvop->op_type) {
case OP_GV: {
gv = cGVOPx_gv(rvop);
+ if (!isGV(gv)) {
+ if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
+ cv = MUTABLE_CV(SvRV(gv));
+ gv = NULL;
+ break;
+ }
+ if (flags & RV2CVOPCV_RETURN_STUB)
+ return (CV *)gv;
+ else return NULL;
+ }
cv = GvCVu(gv);
if (!cv) {
if (flags & RV2CVOPCV_MARK_EARLY)
}
if (SvTYPE((SV*)cv) != SVt_PVCV)
return NULL;
- if (flags & RV2CVOPCV_RETURN_NAME_GV) {
- if (!CvANON(cv) || !gv)
+ 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 ';':
goto wrapref; /* autoconvert GLOB -> GLOBref */
else if (o3->op_type == OP_CONST)
o3->op_private &= ~OPpCONST_STRICT;
- else if (o3->op_type == OP_ENTERSUB) {
- /* accidental subroutine, revert to bareword */
- OP *gvop = ((UNOP*)o3)->op_first;
- if (gvop && gvop->op_type == OP_NULL) {
- gvop = ((UNOP*)gvop)->op_first;
- if (gvop) {
- for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop))
- ;
- if (gvop &&
- (gvop->op_private & OPpENTERSUB_NOPAREN) &&
- (gvop = ((UNOP*)gvop)->op_first) &&
- gvop->op_type == OP_GV)
- {
- OP * newop;
- GV * const gv = cGVOPx_gv(gvop);
- SV * const n = newSVpvs("");
- gv_fullname4(n, gv, "", FALSE);
- /* replace the aop subtree with a const op */
- newop = newSVOP(OP_CONST, 0, n);
- op_sibling_splice(parent, prev, 1, newop);
- op_free(aop);
- aop = newop;
- }
- }
- }
- }
scalar(aop);
break;
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;
}
}
else {
OP *prev, *cvop, *first, *parent;
- U32 flags;
+ U32 flags = 0;
parent = entersubop;
if (!OP_HAS_SIBLING(aop)) {
OP_HAS_SIBLING(cvop);
prev = cvop, cvop = OP_SIBLING(cvop))
;
- flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
+ if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
+ /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
+ * parens, but these have their own meaning for that flag: */
+ && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
+ && opnum != OP_DELETE && opnum != OP_EXISTS)
+ flags |= OPf_SPECIAL;
/* excise cvop from end of sibling chain */
op_sibling_splice(parent, prev, 1, NULL);
op_free(cvop);
if (aop == cvop) aop = NULL;
- /* detach remaining silbings from the first silbing, then
+ /* detach remaining siblings from the first sibling, then
* dispose of original optree */
if (aop)
=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);
}
ns3 = pad2->op_next;
/* we assume here that the op_next chain is the same as
- * the op_silbing chain */
+ * the op_sibling chain */
assert(OP_SIBLING(o) == pad1);
assert(OP_SIBLING(pad1) == ns2);
assert(OP_SIBLING(ns2) == pad2);
OP_SIBLING_set(o, newop);
OP_SIBLING_set(newop, ns3);
+ newop->op_lastsib = 0;
newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
OP *rv2av, *q;
p = o->op_next;
if ( p->op_type == OP_GV
- && (gv = cGVOPx_gv(p))
+ && (gv = cGVOPx_gv(p)) && isGV(gv)
&& GvNAMELEN_get(gv) == 1
&& *GvNAME_get(gv) == '_'
&& GvSTASH(gv) == PL_defstash
https://perl5.git.perl.org / perl5.git / blobdiff