#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
+/* Used to avoid recursion through the op tree in scalarvoid() and
+ op_free()
+*/
+
+#define DEFERRED_OP_STEP 100
+#define DEFER_OP(o) \
+ STMT_START { \
+ if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
+ defer_stack_alloc += DEFERRED_OP_STEP; \
+ assert(defer_stack_alloc > 0); \
+ Renew(defer_stack, defer_stack_alloc, OP *); \
+ } \
+ defer_stack[++defer_ix] = o; \
+ } STMT_END
+
+#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
+
/* remove any leading "empty" ops from the op_next chain whose first
* node's address is stored in op_p. Store the updated address of the
* first node in op_p.
{
dVAR;
OPCODE type;
+ SSize_t defer_ix = -1;
+ SSize_t defer_stack_alloc = 0;
+ OP **defer_stack = NULL;
- /* Though ops may be freed twice, freeing the op after its slab is a
- big no-no. */
- assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
- /* During the forced freeing of ops after compilation failure, kidops
- may be freed before their parents. */
- if (!o || o->op_type == OP_FREED)
- return;
+ do {
- type = o->op_type;
+ /* Though ops may be freed twice, freeing the op after its slab is a
+ big no-no. */
+ assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
+ /* During the forced freeing of ops after compilation failure, kidops
+ may be freed before their parents. */
+ if (!o || o->op_type == OP_FREED)
+ continue;
- /* 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 */
- if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
- assert(!(o->op_private & ~PL_op_private_valid[type]));
- }
+ type = o->op_type;
- if (o->op_private & OPpREFCOUNTED) {
- switch (type) {
- case OP_LEAVESUB:
- case OP_LEAVESUBLV:
- case OP_LEAVEEVAL:
- case OP_LEAVE:
- case OP_SCOPE:
- case OP_LEAVEWRITE:
- {
- PADOFFSET refcnt;
- OP_REFCNT_LOCK;
- refcnt = OpREFCNT_dec(o);
- OP_REFCNT_UNLOCK;
- if (refcnt) {
- /* Need to find and remove any pattern match ops from the list
- we maintain for reset(). */
- find_and_forget_pmops(o);
- return;
- }
- }
- break;
- default:
- break;
- }
- }
+ /* 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 */
+ if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+ }
- /* Call the op_free hook if it has been set. Do it now so that it's called
- * at the right time for refcounted ops, but still before all of the kids
- * are freed. */
- CALL_OPFREEHOOK(o);
+ if (o->op_private & OPpREFCOUNTED) {
+ switch (type) {
+ case OP_LEAVESUB:
+ case OP_LEAVESUBLV:
+ case OP_LEAVEEVAL:
+ case OP_LEAVE:
+ case OP_SCOPE:
+ case OP_LEAVEWRITE:
+ {
+ PADOFFSET refcnt;
+ OP_REFCNT_LOCK;
+ refcnt = OpREFCNT_dec(o);
+ OP_REFCNT_UNLOCK;
+ if (refcnt) {
+ /* Need to find and remove any pattern match ops from the list
+ we maintain for reset(). */
+ find_and_forget_pmops(o);
+ continue;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ }
- if (o->op_flags & OPf_KIDS) {
- OP *kid, *nextkid;
- for (kid = cUNOPo->op_first; kid; kid = nextkid) {
- nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
- op_free(kid);
- }
- }
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
+ /* Call the op_free hook if it has been set. Do it now so that it's called
+ * at the right time for refcounted ops, but still before all of the kids
+ * are freed. */
+ CALL_OPFREEHOOK(o);
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid, *nextkid;
+ for (kid = cUNOPo->op_first; kid; kid = nextkid) {
+ nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
+ if (!kid || kid->op_type == OP_FREED)
+ /* During the forced freeing of ops after
+ compilation failure, kidops may be freed before
+ their parents. */
+ continue;
+ if (!(kid->op_flags & OPf_KIDS))
+ /* If it has no kids, just free it now */
+ op_free(kid);
+ else
+ DEFER_OP(kid);
+ }
+ }
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
- if (o->op_slabbed)
- Slab_to_rw(OpSLAB(o));
+ if (o->op_slabbed)
+ Slab_to_rw(OpSLAB(o));
- /* COP* is not cleared by op_clear() so that we may track line
- * numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
- cop_free((COP*)o);
- }
+ /* COP* is not cleared by op_clear() so that we may track line
+ * numbers etc even after null() */
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
+ cop_free((COP*)o);
+ }
- op_clear(o);
- FreeOp(o);
+ op_clear(o);
+ FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
- if (PL_op == o)
- PL_op = NULL;
+ if (PL_op == o)
+ PL_op = NULL;
#endif
+ } while ( (o = POP_DEFERRED_OP()) );
+
+ Safefree(defer_stack);
}
void
}
OP *
-Perl_scalarvoid(pTHX_ OP *o)
+Perl_scalarvoid(pTHX_ OP *arg)
{
dVAR;
OP *kid;
- SV *useless_sv = NULL;
- const char* useless = NULL;
SV* sv;
U8 want;
+ SSize_t defer_stack_alloc = 0;
+ SSize_t defer_ix = -1;
+ OP **defer_stack = NULL;
+ OP *o = arg;
PERL_ARGS_ASSERT_SCALARVOID;
- if (o->op_type == OP_NEXTSTATE
- || o->op_type == OP_DBSTATE
- || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_DBSTATE)))
- PL_curcop = (COP*)o; /* for warning below */
+ do {
+ SV *useless_sv = NULL;
+ const char* useless = NULL;
+
+ if (o->op_type == OP_NEXTSTATE
+ || o->op_type == OP_DBSTATE
+ || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
+ || o->op_targ == OP_DBSTATE)))
+ PL_curcop = (COP*)o; /* for warning below */
+
+ /* assumes no premature commitment */
+ want = o->op_flags & OPf_WANT;
+ if ((want && want != OPf_WANT_SCALAR)
+ || (PL_parser && PL_parser->error_count)
+ || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
+ {
+ continue;
+ }
- /* assumes no premature commitment */
- want = o->op_flags & OPf_WANT;
- if ((want && want != OPf_WANT_SCALAR)
- || (PL_parser && PL_parser->error_count)
- || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
- {
- return o;
- }
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
+ {
+ /* newASSIGNOP has already applied scalar context, which we
+ leave, as if this op is inside SASSIGN. */
+ continue;
+ }
- if ((o->op_private & OPpTARGET_MY)
- && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
- {
- return scalar(o); /* As if inside SASSIGN */
- }
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ switch (o->op_type) {
+ default:
+ if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
+ break;
+ /* FALLTHROUGH */
+ case OP_REPEAT:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ goto func_ops;
+ case OP_SUBSTR:
+ if (o->op_private == 4)
+ break;
+ /* FALLTHROUGH */
+ case OP_WANTARRAY:
+ case OP_GV:
+ case OP_SMARTMATCH:
+ case OP_AV2ARYLEN:
+ case OP_REF:
+ case OP_REFGEN:
+ case OP_SREFGEN:
+ case OP_DEFINED:
+ case OP_HEX:
+ case OP_OCT:
+ case OP_LENGTH:
+ case OP_VEC:
+ case OP_INDEX:
+ case OP_RINDEX:
+ case OP_SPRINTF:
+ case OP_KVASLICE:
+ case OP_KVHSLICE:
+ case OP_UNPACK:
+ case OP_PACK:
+ case OP_JOIN:
+ case OP_LSLICE:
+ case OP_ANONLIST:
+ case OP_ANONHASH:
+ case OP_SORT:
+ case OP_REVERSE:
+ case OP_RANGE:
+ case OP_FLIP:
+ case OP_FLOP:
+ case OP_CALLER:
+ case OP_FILENO:
+ case OP_EOF:
+ case OP_TELL:
+ case OP_GETSOCKNAME:
+ case OP_GETPEERNAME:
+ case OP_READLINK:
+ case OP_TELLDIR:
+ case OP_GETPPID:
+ case OP_GETPGRP:
+ case OP_GETPRIORITY:
+ case OP_TIME:
+ case OP_TMS:
+ case OP_LOCALTIME:
+ case OP_GMTIME:
+ case OP_GHBYNAME:
+ case OP_GHBYADDR:
+ case OP_GHOSTENT:
+ case OP_GNBYNAME:
+ case OP_GNBYADDR:
+ case OP_GNETENT:
+ case OP_GPBYNAME:
+ case OP_GPBYNUMBER:
+ case OP_GPROTOENT:
+ case OP_GSBYNAME:
+ case OP_GSBYPORT:
+ case OP_GSERVENT:
+ case OP_GPWNAM:
+ case OP_GPWUID:
+ case OP_GGRNAM:
+ case OP_GGRGID:
+ case OP_GETLOGIN:
+ case OP_PROTOTYPE:
+ case OP_RUNCV:
+ func_ops:
+ useless = OP_DESC(o);
+ break;
- switch (o->op_type) {
- default:
- if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
- break;
- /* FALLTHROUGH */
- case OP_REPEAT:
- if (o->op_flags & OPf_STACKED)
- break;
- goto func_ops;
- case OP_SUBSTR:
- if (o->op_private == 4)
- break;
- /* FALLTHROUGH */
- case OP_GVSV:
- case OP_WANTARRAY:
- case OP_GV:
- case OP_SMARTMATCH:
- case OP_PADSV:
- case OP_PADAV:
- case OP_PADHV:
- case OP_PADANY:
- case OP_AV2ARYLEN:
- case OP_REF:
- case OP_REFGEN:
- case OP_SREFGEN:
- case OP_DEFINED:
- case OP_HEX:
- case OP_OCT:
- case OP_LENGTH:
- case OP_VEC:
- case OP_INDEX:
- case OP_RINDEX:
- case OP_SPRINTF:
- case OP_AELEM:
- case OP_AELEMFAST:
- case OP_AELEMFAST_LEX:
- case OP_ASLICE:
- case OP_KVASLICE:
- case OP_HELEM:
- case OP_HSLICE:
- case OP_KVHSLICE:
- case OP_UNPACK:
- case OP_PACK:
- case OP_JOIN:
- case OP_LSLICE:
- case OP_ANONLIST:
- case OP_ANONHASH:
- case OP_SORT:
- case OP_REVERSE:
- case OP_RANGE:
- case OP_FLIP:
- case OP_FLOP:
- case OP_CALLER:
- case OP_FILENO:
- case OP_EOF:
- case OP_TELL:
- case OP_GETSOCKNAME:
- case OP_GETPEERNAME:
- case OP_READLINK:
- case OP_TELLDIR:
- case OP_GETPPID:
- case OP_GETPGRP:
- case OP_GETPRIORITY:
- case OP_TIME:
- case OP_TMS:
- case OP_LOCALTIME:
- case OP_GMTIME:
- case OP_GHBYNAME:
- case OP_GHBYADDR:
- case OP_GHOSTENT:
- case OP_GNBYNAME:
- case OP_GNBYADDR:
- case OP_GNETENT:
- case OP_GPBYNAME:
- case OP_GPBYNUMBER:
- case OP_GPROTOENT:
- case OP_GSBYNAME:
- case OP_GSBYPORT:
- case OP_GSERVENT:
- case OP_GPWNAM:
- case OP_GPWUID:
- case OP_GGRNAM:
- case OP_GGRGID:
- case OP_GETLOGIN:
- case OP_PROTOTYPE:
- case OP_RUNCV:
- func_ops:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
- /* Otherwise it's "Useless use of grep iterator" */
- useless = OP_DESC(o);
- break;
+ case OP_GVSV:
+ case OP_PADSV:
+ case OP_PADAV:
+ case OP_PADHV:
+ case OP_PADANY:
+ case OP_AELEM:
+ case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
+ case OP_ASLICE:
+ case OP_HELEM:
+ case OP_HSLICE:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
+ /* Otherwise it's "Useless use of grep iterator" */
+ useless = OP_DESC(o);
+ break;
- case OP_SPLIT:
- kid = cLISTOPo->op_first;
- if (kid && kid->op_type == OP_PUSHRE
- && !kid->op_targ
- && !(o->op_flags & OPf_STACKED)
+ case OP_SPLIT:
+ kid = cLISTOPo->op_first;
+ if (kid && kid->op_type == OP_PUSHRE
+ && !kid->op_targ
+ && !(o->op_flags & OPf_STACKED)
#ifdef USE_ITHREADS
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
#else
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
#endif
- useless = OP_DESC(o);
- break;
+ )
+ useless = OP_DESC(o);
+ break;
- case OP_NOT:
- kid = cUNOPo->op_first;
- if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
- kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
- goto func_ops;
- }
- useless = "negative pattern binding (!~)";
- break;
+ case OP_NOT:
+ kid = cUNOPo->op_first;
+ if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
+ kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
+ goto func_ops;
+ }
+ useless = "negative pattern binding (!~)";
+ break;
- case OP_SUBST:
- if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
- useless = "non-destructive substitution (s///r)";
- break;
+ case OP_SUBST:
+ if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
+ useless = "non-destructive substitution (s///r)";
+ break;
- case OP_TRANSR:
- useless = "non-destructive transliteration (tr///r)";
- break;
+ case OP_TRANSR:
+ useless = "non-destructive transliteration (tr///r)";
+ break;
- case OP_RV2GV:
- case OP_RV2SV:
- case OP_RV2AV:
- case OP_RV2HV:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
- (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
- useless = "a variable";
- break;
+ case OP_RV2GV:
+ case OP_RV2SV:
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
+ (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
+ useless = "a variable";
+ break;
- case OP_CONST:
- sv = cSVOPo_sv;
- if (cSVOPo->op_private & OPpCONST_STRICT)
- no_bareword_allowed(o);
- else {
- if (ckWARN(WARN_VOID)) {
- NV nv;
- /* don't warn on optimised away booleans, eg
- * use constant Foo, 5; Foo || print; */
- if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
- useless = NULL;
- /* the constants 0 and 1 are permitted as they are
- conventionally used as dummies in constructs like
- 1 while some_condition_with_side_effects; */
- else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
- useless = NULL;
- else if (SvPOK(sv)) {
- SV * const dsv = newSVpvs("");
- useless_sv
- = Perl_newSVpvf(aTHX_
- "a constant (%s)",
- pv_pretty(dsv, SvPVX_const(sv),
- SvCUR(sv), 32, NULL, NULL,
- PERL_PV_PRETTY_DUMP
- | PERL_PV_ESCAPE_NOCLEAR
- | PERL_PV_ESCAPE_UNI_DETECT));
- SvREFCNT_dec_NN(dsv);
- }
- else if (SvOK(sv)) {
- useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
- }
- else
- useless = "a constant (undef)";
- }
- }
- op_null(o); /* don't execute or even remember it */
- break;
+ case OP_CONST:
+ sv = cSVOPo_sv;
+ if (cSVOPo->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(o);
+ else {
+ if (ckWARN(WARN_VOID)) {
+ NV nv;
+ /* don't warn on optimised away booleans, eg
+ * use constant Foo, 5; Foo || print; */
+ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
+ useless = NULL;
+ /* the constants 0 and 1 are permitted as they are
+ conventionally used as dummies in constructs like
+ 1 while some_condition_with_side_effects; */
+ else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
+ useless = NULL;
+ else if (SvPOK(sv)) {
+ SV * const dsv = newSVpvs("");
+ useless_sv
+ = Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, SvPVX_const(sv),
+ SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP
+ | PERL_PV_ESCAPE_NOCLEAR
+ | PERL_PV_ESCAPE_UNI_DETECT));
+ SvREFCNT_dec_NN(dsv);
+ }
+ else if (SvOK(sv)) {
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
+ }
+ else
+ useless = "a constant (undef)";
+ }
+ }
+ op_null(o); /* don't execute or even remember it */
+ break;
- case OP_POSTINC:
- CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
- break;
+ case OP_POSTINC:
+ CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
+ break;
- case OP_POSTDEC:
- CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
- break;
+ case OP_POSTDEC:
+ CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
+ break;
- case OP_I_POSTINC:
- CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
- break;
+ case OP_I_POSTINC:
+ CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
+ break;
- case OP_I_POSTDEC:
- CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
- break;
+ case OP_I_POSTDEC:
+ CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
+ break;
- case OP_SASSIGN: {
- OP *rv2gv;
- UNOP *refgen, *rv2cv;
- LISTOP *exlist;
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
- if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
- break;
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
- rv2gv = ((BINOP *)o)->op_last;
- if (!rv2gv || rv2gv->op_type != OP_RV2GV)
- break;
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
- refgen = (UNOP *)((BINOP *)o)->op_first;
+ refgen = (UNOP *)((BINOP *)o)->op_first;
- if (!refgen || (refgen->op_type != OP_REFGEN
- && refgen->op_type != OP_SREFGEN))
- break;
+ if (!refgen || (refgen->op_type != OP_REFGEN
+ && refgen->op_type != OP_SREFGEN))
+ break;
- exlist = (LISTOP *)refgen->op_first;
- if (!exlist || exlist->op_type != OP_NULL
- || exlist->op_targ != OP_LIST)
- break;
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
- if (exlist->op_first->op_type != OP_PUSHMARK
- && exlist->op_first != exlist->op_last)
- break;
+ if (exlist->op_first->op_type != OP_PUSHMARK
+ && exlist->op_first != exlist->op_last)
+ break;
- rv2cv = (UNOP*)exlist->op_last;
+ rv2cv = (UNOP*)exlist->op_last;
- if (rv2cv->op_type != OP_RV2CV)
- break;
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
- assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
- assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
- assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
- o->op_private |= OPpASSIGN_CV_TO_GV;
- rv2gv->op_private |= OPpDONT_INIT_GV;
- rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
- break;
- }
+ break;
+ }
- case OP_AASSIGN: {
- inplace_aassign(o);
- break;
- }
+ case OP_AASSIGN: {
+ inplace_aassign(o);
+ break;
+ }
- case OP_OR:
- case OP_AND:
- kid = cLOGOPo->op_first;
- if (kid->op_type == OP_NOT
- && (kid->op_flags & OPf_KIDS)) {
- if (o->op_type == OP_AND) {
- CHANGE_TYPE(o, OP_OR);
- } else {
- CHANGE_TYPE(o, OP_AND);
- }
- op_null(kid);
- }
- /* FALLTHROUGH */
+ case OP_OR:
+ case OP_AND:
+ kid = cLOGOPo->op_first;
+ if (kid->op_type == OP_NOT
+ && (kid->op_flags & OPf_KIDS)) {
+ if (o->op_type == OP_AND) {
+ CHANGE_TYPE(o, OP_OR);
+ } else {
+ CHANGE_TYPE(o, OP_AND);
+ }
+ op_null(kid);
+ }
+ /* FALLTHROUGH */
+
+ case OP_DOR:
+ case OP_COND_EXPR:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
+ if (!(kid->op_flags & OPf_KIDS))
+ scalarvoid(kid);
+ else
+ DEFER_OP(kid);
+ break;
- case OP_DOR:
- case OP_COND_EXPR:
- case OP_ENTERGIVEN:
- case OP_ENTERWHEN:
- for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
- scalarvoid(kid);
- break;
+ case OP_NULL:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ /* FALLTHROUGH */
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ case OP_ENTERTRY:
+ case OP_ENTER:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ /* FALLTHROUGH */
+ case OP_SCOPE:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ case OP_LEAVELOOP:
+ case OP_LINESEQ:
+ case OP_LEAVEGIVEN:
+ case OP_LEAVEWHEN:
+ kids:
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ if (!(kid->op_flags & OPf_KIDS))
+ scalarvoid(kid);
+ else
+ DEFER_OP(kid);
+ break;
+ case OP_LIST:
+ /* If the first kid after pushmark is something that the padrange
+ optimisation would reject, then null the list and the pushmark.
+ */
+ if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
+ && ( !(kid = OP_SIBLING(kid))
+ || ( kid->op_type != OP_PADSV
+ && kid->op_type != OP_PADAV
+ && kid->op_type != OP_PADHV)
+ || kid->op_private & ~OPpLVAL_INTRO
+ || !(kid = OP_SIBLING(kid))
+ || ( kid->op_type != OP_PADSV
+ && kid->op_type != OP_PADAV
+ && kid->op_type != OP_PADHV)
+ || kid->op_private & ~OPpLVAL_INTRO)
+ ) {
+ op_null(cUNOPo->op_first); /* NULL the pushmark */
+ op_null(o); /* NULL the list */
+ }
+ goto kids;
+ case OP_ENTEREVAL:
+ scalarkids(o);
+ break;
+ case OP_SCALAR:
+ scalar(o);
+ break;
+ }
- case OP_NULL:
- if (o->op_flags & OPf_STACKED)
- break;
- /* FALLTHROUGH */
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- case OP_ENTERTRY:
- case OP_ENTER:
- if (!(o->op_flags & OPf_KIDS))
- break;
- /* FALLTHROUGH */
- case OP_SCOPE:
- case OP_LEAVE:
- case OP_LEAVETRY:
- case OP_LEAVELOOP:
- case OP_LINESEQ:
- case OP_LEAVEGIVEN:
- case OP_LEAVEWHEN:
- kids:
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
- scalarvoid(kid);
- break;
- case OP_LIST:
- /* If the first kid after pushmark is something that the padrange
- optimisation would reject, then null the list and the pushmark.
- */
- if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
- && ( !(kid = OP_SIBLING(kid))
- || ( kid->op_type != OP_PADSV
- && kid->op_type != OP_PADAV
- && kid->op_type != OP_PADHV)
- || kid->op_private & ~OPpLVAL_INTRO
- || !(kid = OP_SIBLING(kid))
- || ( kid->op_type != OP_PADSV
- && kid->op_type != OP_PADAV
- && kid->op_type != OP_PADHV)
- || kid->op_private & ~OPpLVAL_INTRO)
- ) {
- op_null(cUNOPo->op_first); /* NULL the pushmark */
- op_null(o); /* NULL the list */
- }
- goto kids;
- case OP_ENTEREVAL:
- scalarkids(o);
- break;
- case OP_SCALAR:
- return scalar(o);
- }
+ if (useless_sv) {
+ /* mortalise it, in case warnings are fatal. */
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %"SVf" in void context",
+ SVfARG(sv_2mortal(useless_sv)));
+ }
+ else if (useless) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %s in void context",
+ useless);
+ }
+ } while ( (o = POP_DEFERRED_OP()) );
- if (useless_sv) {
- /* mortalise it, in case warnings are fatal. */
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %"SVf" in void context",
- SVfARG(sv_2mortal(useless_sv)));
- }
- else if (useless) {
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %s in void context",
- useless);
- }
- return o;
+ Safefree(defer_stack);
+
+ return arg;
}
static OP *
=cut
*/
+static void
+S_mark_padname_lvalue(pTHX_ PADNAME *pn)
+{
+ CV *cv = PL_compcv;
+ PadnameLVALUE_on(pn);
+ while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
+ cv = CvOUTSIDE(cv);
+ assert(cv);
+ assert(CvPADLIST(cv));
+ pn =
+ PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
+ assert(PadnameLEN(pn));
+ PadnameLVALUE_on(pn);
+ }
+}
+
static bool
S_vivifies(const OPCODE type)
{
if (!type) /* local() */
Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
PAD_COMPNAME_SV(o->op_targ));
+ if (!(o->op_private & OPpLVAL_INTRO)
+ || ( type != OP_SASSIGN && type != OP_AASSIGN
+ && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
+ S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
break;
case OP_PUSHMARK:
right->op_targ = 0;
right->op_private &= ~OPpTARGET_MY;
}
- if (!(right->op_flags & OPf_STACKED) && ismatchop) {
- OP *newleft;
-
- right->op_flags |= OPf_STACKED;
- if (rtype != OP_MATCH && rtype != OP_TRANSR &&
+ if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
+ if (left->op_type == OP_PADSV
+ && !(left->op_private & OPpLVAL_INTRO))
+ {
+ right->op_targ = left->op_targ;
+ op_free(left);
+ o = right;
+ }
+ else {
+ right->op_flags |= OPf_STACKED;
+ if (rtype != OP_MATCH && rtype != OP_TRANSR &&
! (rtype == OP_TRANS &&
right->op_private & OPpTRANS_IDENTICAL) &&
! (rtype == OP_SUBST &&
(cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
- newleft = op_lvalue(left, rtype);
- else
- newleft = left;
- if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
- o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
- else
- o = op_prepend_elem(rtype, scalar(newleft), right);
+ left = op_lvalue(left, rtype);
+ if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ else
+ o = op_prepend_elem(rtype, scalar(left), right);
+ }
if (type == OP_NOT)
return newUNOP(OP_NOT, 0, scalar(o));
return o;
{
const int retval = PL_savestack_ix;
+ PL_compiling.cop_seq = PL_cop_seqmax;
+ COP_SEQMAX_INC;
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+ SAVEI32(PL_compiling.cop_seq);
+ PL_compiling.cop_seq = 0;
CALL_BLOCK_HOOKS(bhk_start, full);
StructCopy(&PL_compiling, ¬_compiling, COP);
PL_curcop = ¬_compiling;
/* The above ensures that we run with all the correct hints of the
- currently compiling COP, but that IN_PERL_RUNTIME is not true. */
+ currently compiling COP, but that IN_PERL_RUNTIME is true. */
assert(IN_PERL_RUNTIME);
PL_warnhook = PERL_WARNHOOK_FATAL;
PL_diehook = NULL;
UV tfirst = 1;
UV tlast = 0;
IV tdiff;
+ STRLEN tcount = 0;
UV rfirst = 1;
UV rlast = 0;
IV rdiff;
+ STRLEN rcount = 0;
IV diff;
I32 none = 0;
U32 max = 0;
/* now see which range will peter our first, if either. */
tdiff = tlast - tfirst;
rdiff = rlast - rfirst;
+ tcount += tdiff + 1;
+ rcount += rdiff + 1;
if (tdiff <= rdiff)
diff = tdiff;
(void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
newSVuv((UV)final), 0);
- if (grows)
- o->op_private |= OPpTRANS_GROWS;
-
Safefree(tsave);
Safefree(rsave);
- op_free(expr);
- op_free(repl);
- return o;
+ tlen = tcount;
+ rlen = rcount;
+ if (r < rend)
+ rlen++;
+ else if (rlast == 0xffffffff)
+ rlen = 0;
+
+ goto warnins;
}
tbl = (short*)PerlMemShared_calloc(
}
}
+ warnins:
if(del && rlen == tlen) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
} else if(rlen > tlen && !complement) {
return CHECKOP(type, pmop);
}
+static void
+S_set_haseval(pTHX)
+{
+ PADOFFSET i = 1;
+ PL_cv_has_eval = 1;
+ /* Any pad names in scope are potentially lvalues. */
+ for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
+ PADNAME *pn = PAD_COMPNAME_SV(i);
+ if (!pn || !PadnameLEN(pn))
+ continue;
+ if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
+ S_mark_padname_lvalue(aTHX_ pn);
+ }
+}
+
/* Given some sort of match op o, and an expression expr containing a
* pattern, either compile expr into a regex and attach it to o (if it's
* constant), or convert expr into a runtime regcomp op sequence (if it's
rcop->op_targ = cv_targ;
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
- if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
+ if (PL_hints & HINT_RE_EVAL)
+ S_set_haseval(aTHX);
/* establish postfix order */
if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_cop_seqmax++; /* Purely for B::*'s benefit */
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
-
+ COP_SEQMAX_INC; /* Purely for B::*'s benefit */
}
/*
}
/*
- Helper function for newASSIGNOP to detection commonality between the
+ Helper function for newASSIGNOP to detect commonality between the
lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
flags the op and the peephole optimizer calls this helper function
if the flag is set.) Marks all variables with PL_generation. If it
}
cop->op_flags = (U8)flags;
CopHINTS_set(cop, PL_hints);
-#ifdef NATIVE_HINTS
- cop->op_private |= NATIVE_HINTS;
-#endif
#ifdef VMS
if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
#endif
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
- * Can be called in 3 ways:
+ * Can be called in 2 ways:
*
- * !cv
+ * !allow_lex
* look for a single OP_CONST with attached value: return the value
*
- * cv && CvCLONE(cv) && !CvCONST(cv)
+ * allow_lex && !CvCONST(cv);
*
* examine the clone prototype, and if contains only a single
- * OP_CONST referencing a pad const, or a single PADSV referencing
- * an outer lexical, return a non-zero value to indicate the CV is
- * a candidate for "constizing" at clone time
- *
- * cv && CvCONST(cv)
- *
- * We have just cloned an anon prototype that was marked as a const
- * candidate. Try to grab the current value, and in the case of
- * PADSV, ignore it if it has multiple references. In this case we
- * return a newly created *copy* of the value.
+ * OP_CONST, return the value; or if it contains a single PADSV ref-
+ * erencing an outer lexical, turn on CvCONST to indicate the CV is
+ * a candidate for "constizing" at clone time, and return NULL.
*/
-SV *
-Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
+static SV *
+S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
{
SV *sv = NULL;
+ bool padsv = FALSE;
- if (!o)
- return NULL;
-
- if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
- o = OP_SIBLING(cLISTOPo->op_first);
+ assert(o);
+ assert(cv);
for (; o; o = o->op_next) {
const OPCODE type = o->op_type;
- if (sv && o->op_next == o)
- return sv;
- if (o->op_next != o) {
- if (type == OP_NEXTSTATE
- || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
+ if (type == OP_NEXTSTATE || type == OP_LINESEQ
+ || type == OP_NULL
|| type == OP_PUSHMARK)
continue;
- if (type == OP_DBSTATE)
+ if (type == OP_DBSTATE)
continue;
- }
- if (type == OP_LEAVESUB || type == OP_RETURN)
+ if (type == OP_LEAVESUB)
break;
if (sv)
return NULL;
sv = newSV(0);
SAVEFREESV(sv);
}
- else if (cv && type == OP_CONST) {
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- if (!sv)
- return NULL;
- }
- else if (cv && type == OP_PADSV) {
- if (CvCONST(cv)) { /* newly cloned anon */
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- /* the candidate should have 1 ref from this pad and 1 ref
- * from the parent */
- if (!sv || SvREFCNT(sv) != 2)
- return NULL;
- sv = newSVsv(sv);
- SvREADONLY_on(sv);
- return sv;
- }
- else {
+ else if (allow_lex && type == OP_PADSV) {
if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ {
sv = &PL_sv_undef; /* an arbitrary non-null value */
- }
+ padsv = TRUE;
+ }
+ else
+ return NULL;
}
else {
return NULL;
}
}
+ if (padsv) {
+ CvCONST_on(cv);
+ return NULL;
+ }
return sv;
}
CV *clonee = NULL;
HEK *hek = NULL;
bool reusable = FALSE;
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
#endif
spot = (CV **)(svspot = &mg->mg_obj);
}
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
+
if (!block || !ps || *ps || attrs
- || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
CvCONST_on(cv);
CvISXSUB_on(cv);
PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(compcv);
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
bool special = FALSE;
? (CV *)SvRV(gv)
: NULL;
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(PL_compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
+ && (!isGV(gv) || !GvASSUMECV(gv)))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
if (!block || !ps || *ps || attrs
- || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(PL_compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv =
+ S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
assert (block);
CvCONST_on(cv);
CvISXSUB_on(cv);
PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
- if (isGV(gv)) {
- if (name) GvCV_set(gv, NULL);
+ if (isGV(gv) || CvMETHOD(PL_compcv)) {
+ if (name && isGV(gv))
+ GvCV_set(gv, NULL);
cv = newCONSTSUB_flags(
NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
const_sv
);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
if (!SvROK(gv)) {
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
return cv;
}
+/*
+=for apidoc U||newXS
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
+
+=cut
+*/
+
+CV *
+Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
+{
+ PERL_ARGS_ASSERT_NEWXS;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+ );
+}
+
CV *
Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
const char *const filename, const char *const proto,
}
CV *
+Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
+{
+ PERL_ARGS_ASSERT_NEWXS_DEFFILE;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+ );
+}
+
+CV *
Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
XSUBADDR_t subaddr, const char *const filename,
const char *const proto, SV **const_svp,
bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
-
+ if (!subaddr)
+ Perl_croak_nocontext("panic: no address for '%s' in '%s'",
+ name, filename ? filename : PL_xsubfilename);
{
GV * const gv = gv_fetchpvn(
name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
name ? len : PL_curstash ? sizeof("__ANON__") - 1:
sizeof("__ANON__::__ANON__") - 1,
GV_ADDMULTI | flags, SVt_PVCV);
-
- if (!subaddr)
- Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-
+
if ((cv = (name ? GvCV(gv) : NULL))) {
if (GvCVGEN(gv)) {
/* just a cached method */
gv_method_changed(gv); /* newXS */
}
}
- if (!name)
- CvANON_on(cv);
+
CvGV_set(cv, gv);
- (void)gv_fetchfile(filename);
- CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
- an external constant string */
- assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if(filename) {
+ (void)gv_fetchfile(filename);
+ assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if (flags & XS_DYNAMIC_FILENAME) {
+ CvDYNFILE_on(cv);
+ CvFILE(cv) = savepv(filename);
+ } else {
+ /* NOTE: not copied, as it is expected to be an external constant string */
+ CvFILE(cv) = (char *)filename;
+ }
+ } else {
+ assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
+ CvFILE(cv) = (char*)PL_xsubfilename;
+ }
CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
+#ifndef PERL_IMPLICIT_CONTEXT
+ CvHSCXT(cv) = &PL_stack_sp;
+#else
PoisonPADLIST(cv);
-
+#endif
+
if (name)
process_special_blocks(0, name, gv, cv);
- }
+ else
+ CvANON_on(cv);
+ } /* <- not a conditional branch */
+
- if (flags & XS_DYNAMIC_FILENAME) {
- CvFILE(cv) = savepv(filename);
- CvDYNFILE_on(cv);
- }
sv_setpv(MUTABLE_SV(cv), proto);
if (interleave) LEAVE;
return cv;
return cv;
}
-/*
-=for apidoc U||newXS
-
-Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
-static storage, as it is used directly as CvFILE(), without a copy being made.
-
-=cut
-*/
-
-CV *
-Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
-{
- PERL_ARGS_ASSERT_NEWXS;
- return newXS_len_flags(
- name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
- );
-}
-
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
}
else {
scalar((OP*)kid);
- PL_cv_has_eval = 1;
+ S_set_haseval(aTHX);
}
}
else {
}
-OP *
-Perl_ck_sassign(pTHX_ OP *o)
+static OP *
+S_maybe_targlex(pTHX_ OP *o)
{
dVAR;
OP * const kid = cLISTOPo->op_first;
-
- PERL_ARGS_ASSERT_CK_SASSIGN;
-
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
/* Can just relocate the target. */
if (kkid && kkid->op_type == OP_PADSV
- && !(kkid->op_private & OPpLVAL_INTRO))
+ && (!(kkid->op_private & OPpLVAL_INTRO)
+ || kkid->op_private & OPpPAD_STATE))
{
kid->op_targ = kkid->op_targ;
kkid->op_targ = 0;
/* Now we do not need PADSV and SASSIGN.
- * first replace the PADSV with OP_SIBLING(o), then
- * detach kid and OP_SIBLING(o) from o */
- op_sibling_splice(o, kid, 1, OP_SIBLING(o));
- op_sibling_splice(o, NULL, -1, NULL);
+ * Detach kid and free the rest. */
+ op_sibling_splice(o, NULL, 1, NULL);
op_free(o);
- op_free(kkid);
kid->op_private |= OPpTARGET_MY; /* Used for context settings */
return kid;
}
}
+ return o;
+}
+
+OP *
+Perl_ck_sassign(pTHX_ OP *o)
+{
+ dVAR;
+ OP * const kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_SASSIGN;
+
if (OP_HAS_SIBLING(kid)) {
OP *kkid = OP_SIBLING(kid);
- /* For state variable assignment, kkid is a list op whose op_last
- is a padsv. */
+ /* For state variable assignment with attributes, kkid is a list op
+ whose op_last is a padsv. */
if ((kkid->op_type == OP_PADSV ||
(OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
(kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
)
)
- && (kkid->op_private & OPpLVAL_INTRO)
- && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
+ && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
+ == (OPpLVAL_INTRO|OPpPAD_STATE)) {
const PADOFFSET target = kkid->op_targ;
OP *const other = newOP(OP_PADSV,
kkid->op_flags
| ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
OP *const first = newOP(OP_NULL, 0);
- OP *const nullop = newCONDOP(0, first, o, other);
+ OP *const nullop =
+ newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
OP *const condop = first->op_next;
CHANGE_TYPE(condop, OP_ONCE);
return nullop;
}
}
- return o;
+ return S_maybe_targlex(aTHX_ o);
}
OP *
{
OP * const kid = OP_SIBLING(cUNOPo->op_first);
PERL_ARGS_ASSERT_CK_STRINGIFY;
- if (kid->op_type == OP_JOIN) {
+ if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
+ || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
+ || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ {
assert(!OP_HAS_SIBLING(kid));
op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
op_free(o);
if ( OP_TYPE_IS(next, OP_PUSHMARK)
&& OP_TYPE_IS(sibling, OP_RETURN)
&& OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
- && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
+ && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
+ ||OP_TYPE_IS(sibling->op_next->op_next,
+ OP_LEAVESUBLV))
&& cUNOPx(sibling)->op_first == next
&& OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
&& next->op_next
break;
case OP_RUNCV:
- if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
+ && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
+ {
SV *sv;
if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
else {
/* We do the common-vars check here, rather than in newASSIGNOP
(as formerly), so that all lexical vars that get aliased are
marked as such before we do the check. */
+ /* There can’t be common vars if the lhs is a stub. */
+ if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
+ == cLISTOPx(cBINOPo->op_last)->op_last
+ && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
+ {
+ o->op_private &=~ OPpASSIGN_COMMON;
+ break;
+ }
if (o->op_private & OPpASSIGN_COMMON) {
/* See the comment before S_aassign_common_vars concerning
PL_generation sorcery. */
https://perl5.git.perl.org / perl5.git / blobdiff