2 * This code was copied from perl/pad.c and perl/op.c and subsequently
3 * butchered by Lukas Mai (2012).
5 /* vi: set ft=c inde=: */
7 #define COP_SEQ_RANGE_LOW_set(SV, VAL) \
8 do { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } while (0)
9 #define COP_SEQ_RANGE_HIGH_set(SV, VAL) \
10 do { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } while (0)
12 static void S_pad_block_start(pTHX_ int full) {
14 ASSERT_CURPAD_ACTIVE("pad_block_start");
15 SAVEI32(PL_comppad_name_floor);
16 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
18 PL_comppad_name_fill = PL_comppad_name_floor;
19 if (PL_comppad_name_floor < 0)
20 PL_comppad_name_floor = 0;
21 SAVEI32(PL_min_intro_pending);
22 SAVEI32(PL_max_intro_pending);
23 PL_min_intro_pending = 0;
24 SAVEI32(PL_comppad_name_fill);
25 SAVEI32(PL_padix_floor);
26 PL_padix_floor = PL_padix;
27 PL_pad_reset_pending = FALSE;
30 static int S_block_start(pTHX_ int full) {
32 const int retval = PL_savestack_ix;
34 S_pad_block_start(aTHX_ full);
36 PL_hints &= ~HINT_BLOCK_SCOPE;
37 SAVECOMPILEWARNINGS();
38 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
40 CALL_BLOCK_HOOKS(bhk_start, full);
45 /* Check for in place reverse and sort assignments like "@a = reverse @a"
46 and modify the optree to make them work inplace */
48 static void S_inplace_aassign(pTHX_ OP *o) {
49 OP *modop, *modop_pushmark;
51 OP *oleft, *oleft_pushmark;
53 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
55 assert(cUNOPo->op_first->op_type == OP_NULL);
56 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
57 assert(modop_pushmark->op_type == OP_PUSHMARK);
58 modop = modop_pushmark->op_sibling;
60 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
63 /* no other operation except sort/reverse */
64 if (modop->op_sibling)
67 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
68 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
70 if (modop->op_flags & OPf_STACKED) {
71 /* skip sort subroutine/block */
72 assert(oright->op_type == OP_NULL);
73 oright = oright->op_sibling;
76 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
77 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
78 assert(oleft_pushmark->op_type == OP_PUSHMARK);
79 oleft = oleft_pushmark->op_sibling;
81 /* Check the lhs is an array */
83 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
85 || (oleft->op_private & OPpLVAL_INTRO)
89 /* Only one thing on the rhs */
90 if (oright->op_sibling)
93 /* check the array is the same on both sides */
94 if (oleft->op_type == OP_RV2AV) {
95 if (oright->op_type != OP_RV2AV
96 || !cUNOPx(oright)->op_first
97 || cUNOPx(oright)->op_first->op_type != OP_GV
98 || cUNOPx(oleft )->op_first->op_type != OP_GV
99 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
100 cGVOPx_gv(cUNOPx(oright)->op_first)
104 else if (oright->op_type != OP_PADAV
105 || oright->op_targ != oleft->op_targ
109 /* This actually is an inplace assignment */
111 modop->op_private |= OPpSORT_INPLACE;
113 /* transfer MODishness etc from LHS arg to RHS arg */
114 oright->op_flags = oleft->op_flags;
116 /* remove the aassign op and the lhs */
118 op_null(oleft_pushmark);
119 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
120 op_null(cUNOPx(oleft)->op_first);
124 static OP *S_scalarvoid(pTHX_ OP *);
126 static OP *S_scalar(pTHX_ OP *o) {
130 /* assumes no premature commitment */
131 if (!o || (PL_parser && PL_parser->error_count)
132 || (o->op_flags & OPf_WANT)
133 || o->op_type == OP_RETURN)
138 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
140 switch (o->op_type) {
142 S_scalar(aTHX_ cBINOPo->op_first);
147 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
157 if (o->op_flags & OPf_KIDS) {
158 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
164 kid = cLISTOPo->op_first;
166 kid = kid->op_sibling;
169 OP *sib = kid->op_sibling;
170 if (sib && kid->op_type != OP_LEAVEWHEN)
171 S_scalarvoid(aTHX_ kid);
176 PL_curcop = &PL_compiling;
181 kid = cLISTOPo->op_first;
184 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
190 static OP *S_scalarkids(pTHX_ OP *o) {
191 if (o && o->op_flags & OPf_KIDS) {
193 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
199 static OP *S_scalarvoid(pTHX_ OP *o) {
202 const char *useless = NULL;
203 U32 useless_is_utf8 = 0;
207 PERL_ARGS_ASSERT_SCALARVOID;
210 o->op_type == OP_NEXTSTATE ||
211 o->op_type == OP_DBSTATE || (
212 o->op_type == OP_NULL && (
213 o->op_targ == OP_NEXTSTATE ||
214 o->op_targ == OP_DBSTATE
218 PL_curcop = (COP*)o; /* for warning below */
221 /* assumes no premature commitment */
222 want = o->op_flags & OPf_WANT;
224 (want && want != OPf_WANT_SCALAR) ||
225 (PL_parser && PL_parser->error_count) ||
226 o->op_type == OP_RETURN ||
227 o->op_type == OP_REQUIRE ||
228 o->op_type == OP_LEAVEWHEN
234 (o->op_private & OPpTARGET_MY) &&
235 (PL_opargs[o->op_type] & OA_TARGLEX)
236 /* OPp share the meaning */
238 return S_scalar(aTHX_ o); /* As if inside SASSIGN */
241 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
243 switch (o->op_type) {
245 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
249 if (o->op_flags & OPf_STACKED)
253 if (o->op_private == 4)
278 case OP_AELEMFAST_LEX:
328 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
329 /* Otherwise it's "Useless use of grep iterator" */
330 useless = OP_DESC(o);
334 kid = cLISTOPo->op_first;
335 if (kid && kid->op_type == OP_PUSHRE
337 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
339 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
341 useless = OP_DESC(o);
345 kid = cUNOPo->op_first;
346 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
347 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
350 useless = "negative pattern binding (!~)";
354 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
355 useless = "non-destructive substitution (s///r)";
359 useless = "non-destructive transliteration (tr///r)";
366 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
367 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
368 useless = "a variable";
373 if (cSVOPo->op_private & OPpCONST_STRICT) {
374 //no_bareword_allowed(o);
377 if (ckWARN(WARN_VOID)) {
378 /* don't warn on optimised away booleans, eg
379 * use constant Foo, 5; Foo || print; */
380 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
382 /* the constants 0 and 1 are permitted as they are
383 conventionally used as dummies in constructs like
384 1 while some_condition_with_side_effects; */
385 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
387 else if (SvPOK(sv)) {
388 /* perl4's way of mixing documentation and code
389 (before the invention of POD) was based on a
390 trick to mix nroff and perl code. The trick was
391 built upon these three nroff macros being used in
392 void context. The pink camel has the details in
393 the script wrapman near page 319. */
394 const char * const maybe_macro = SvPVX_const(sv);
395 if (strnEQ(maybe_macro, "di", 2) ||
396 strnEQ(maybe_macro, "ds", 2) ||
397 strnEQ(maybe_macro, "ig", 2))
400 SV * const dsv = newSVpvs("");
401 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
403 pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
404 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
406 useless = SvPV_nolen(msv);
407 useless_is_utf8 = SvUTF8(msv);
411 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
412 "a constant (%"SVf")", sv));
413 useless = SvPV_nolen(msv);
416 useless = "a constant (undef)";
419 op_null(o); /* don't execute or even remember it */
423 o->op_type = OP_PREINC; /* pre-increment is faster */
424 o->op_ppaddr = PL_ppaddr[OP_PREINC];
428 o->op_type = OP_PREDEC; /* pre-decrement is faster */
429 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
433 o->op_type = OP_I_PREINC; /* pre-increment is faster */
434 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
438 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
439 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
444 UNOP *refgen, *rv2cv;
447 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
450 rv2gv = ((BINOP *)o)->op_last;
451 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
454 refgen = (UNOP *)((BINOP *)o)->op_first;
456 if (!refgen || refgen->op_type != OP_REFGEN)
459 exlist = (LISTOP *)refgen->op_first;
460 if (!exlist || exlist->op_type != OP_NULL
461 || exlist->op_targ != OP_LIST)
464 if (exlist->op_first->op_type != OP_PUSHMARK)
467 rv2cv = (UNOP*)exlist->op_last;
469 if (rv2cv->op_type != OP_RV2CV)
472 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
473 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
474 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
476 o->op_private |= OPpASSIGN_CV_TO_GV;
477 rv2gv->op_private |= OPpDONT_INIT_GV;
478 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
484 S_inplace_aassign(aTHX_ o);
490 kid = cLOGOPo->op_first;
491 if (kid->op_type == OP_NOT
492 && (kid->op_flags & OPf_KIDS)
494 if (o->op_type == OP_AND) {
496 o->op_ppaddr = PL_ppaddr[OP_OR];
499 o->op_ppaddr = PL_ppaddr[OP_AND];
508 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
509 S_scalarvoid(aTHX_ kid);
513 if (o->op_flags & OPf_STACKED)
520 if (!(o->op_flags & OPf_KIDS))
531 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
532 S_scalarvoid(aTHX_ kid);
535 S_scalarkids(aTHX_ o);
538 return S_scalar(aTHX_ o);
541 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
542 newSVpvn_flags(useless, strlen(useless),
543 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
547 static OP *S_scalarseq(pTHX_ OP *o) {
550 const OPCODE type = o->op_type;
552 if (type == OP_LINESEQ || type == OP_SCOPE ||
553 type == OP_LEAVE || type == OP_LEAVETRY)
556 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
557 if (kid->op_sibling) {
558 S_scalarvoid(aTHX_ kid);
561 PL_curcop = &PL_compiling;
563 o->op_flags &= ~OPf_PARENS;
564 if (PL_hints & HINT_BLOCK_SCOPE)
565 o->op_flags |= OPf_PARENS;
568 o = newOP(OP_STUB, 0);
572 static void S_pad_leavemy(pTHX) {
575 SV * const * const svp = AvARRAY(PL_comppad_name);
577 PL_pad_reset_pending = FALSE;
579 ASSERT_CURPAD_ACTIVE("pad_leavemy");
580 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
581 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
582 const SV * const sv = svp[off];
583 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
584 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
585 "%"SVf" never introduced",
589 /* "Deintroduce" my variables that are leaving with this scope. */
590 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
591 const SV * const sv = svp[off];
592 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
593 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
595 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
596 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
597 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
598 (long)off, SvPVX_const(sv),
599 (unsigned long)COP_SEQ_RANGE_LOW(sv),
600 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
605 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
607 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
608 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
611 static OP *S_block_end(pTHX_ I32 floor, OP *seq) {
613 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
614 OP *retval = S_scalarseq(aTHX_ seq);
616 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
619 CopHINTS_set(&PL_compiling, PL_hints);
621 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
624 CALL_BLOCK_HOOKS(bhk_post_end, &retval);