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_sibling manipulation on the
-children. The op_sibling field of the last deleted node will be set to
-NULL.
+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;
*/
OP *
-Perl_op_parent(pTHX_ OP *o)
+Perl_op_parent(OP *o)
{
PERL_ARGS_ASSERT_OP_PARENT;
#ifdef PERL_OP_PARENT
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;
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)) {
+ 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 (!OP_HAS_SIBLING(kid)) {
+ if (has_last)
assert(kid == cLISTOPo->op_last);
- assert(kid->op_sibling == o);
- }
+ assert(kid->op_sibling == o);
+ }
# else
- if (OP_HAS_SIBLING(kid)) {
- assert(!kid->op_lastsib);
- }
- else {
- assert(kid->op_lastsib);
+ if (OP_HAS_SIBLING(kid)) {
+ assert(!kid->op_lastsib);
+ }
+ else {
+ assert(kid->op_lastsib);
+ if (has_last)
assert(kid == cLISTOPo->op_last);
- }
-# endif
}
+# endif
}
#endif
{
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++;
}
}
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, IS_PADGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
assert(sv);
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++;
{
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;
}
gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
has_name = FALSE;
}
-
if (!ec)
move_proto_attr(&proto, &attrs, gv);
}
}
- 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
+ process_special_blocks(floor, name, gv, cv);
+ }
}
done:
}
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"))) {
+ GvCV_set(gv, NULL);
+ SvREFCNT_dec_NN(MUTABLE_SV(cv));
+ }
+}
+
+STATIC void
S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
GV *const gv,
CV *const cv)
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;
if (kid->op_type == OP_CONST) {
int iscv;
+ const int noexpand = o->op_type == OP_RV2CV
+ && o->op_private & OPpMAY_RETURN_CONSTANT
+ ? GV_NOEXPAND
+ : 0;
GV *gv;
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;
iscv = (o->op_type == OP_RV2CV) * 2;
do {
gv = gv_fetchsv(kidsv,
- iscv | !(kid->op_private & OPpCONST_ENTERED),
+ noexpand
+ ? 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++);
+ } while (!noexpand && !gv && !(kid->op_private & OPpCONST_ENTERED)
+ && !iscv++);
if (gv) {
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);
+ 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);
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;
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 (flags & RV2CVOPCV_RETURN_STUB)
+ return (CV *)gv;
+ else return NULL;
+ }
cv = GvCVu(gv);
if (!cv) {
if (flags & RV2CVOPCV_MARK_EARLY)
}
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);
https://perl5.git.perl.org / perl5.git / blobdiff