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 STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END
9 #define COP_SEQ_RANGE_HIGH_set(SV, VAL) \
10 STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END
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 IF_HAVE_PERL_5_16(case OP_AELEMFAST_LEX:, )
326 IF_HAVE_PERL_5_16(case OP_RUNCV:, )
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);
632 #define pad_alloc(OPTYPE, TMPTYPE) \
633 S_pad_alloc(aTHX_ OPTYPE, TMPTYPE)
635 static PADOFFSET S_pad_alloc(pTHX_ I32 optype, U32 tmptype) {
640 PERL_UNUSED_ARG(optype);
641 ASSERT_CURPAD_ACTIVE("pad_alloc");
643 if (AvARRAY(PL_comppad) != PL_curpad)
644 Perl_croak(aTHX_ "panic: pad_alloc");
645 PL_pad_reset_pending = FALSE;
646 if (tmptype & SVs_PADMY) {
647 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
648 retval = AvFILLp(PL_comppad);
651 SV * const * const names = AvARRAY(PL_comppad_name);
652 const SSize_t names_fill = AvFILLp(PL_comppad_name);
655 * "foreach" index vars temporarily become aliases to non-"my"
656 * values. Thus we must skip, not just pad values that are
657 * marked as current pad values, but also those with names.
659 /* HVDS why copy to sv here? we don't seem to use it */
660 if (++PL_padix <= names_fill &&
661 (sv = names[PL_padix]) && sv != &PL_sv_undef)
663 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
664 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
665 !IS_PADGV(sv) && !IS_PADCONST(sv))
670 SvFLAGS(sv) |= tmptype;
671 PL_curpad = AvARRAY(PL_comppad);
673 DEBUG_X(PerlIO_printf(Perl_debug_log,
674 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
675 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
676 PL_op_name[optype]));
677 #ifdef DEBUG_LEAKING_SCALARS
678 sv->sv_debug_optype = optype;
679 sv->sv_debug_inpad = 1;
681 return (PADOFFSET)retval;
687 #ifndef pad_add_name_pvs
688 #define pad_add_name_pvs(NAME, FLAGS, TYPESTASH, OURSTASH) S_pad_add_name_pvn(aTHX_ "" NAME "", sizeof NAME - 1, FLAGS, TYPESTASH, OURSTASH)
691 #ifndef pad_add_name_sv
693 #define pad_add_name_sv(NAMESV, FLAGS, TYPESTASH, OURSTASH) \
694 S_pad_add_name_sv(aTHX_ NAMESV, FLAGS, TYPESTASH, OURSTASH)
696 static PADOFFSET S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) {
698 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
702 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
705 assert(SvTYPE(namesv) == SVt_PVMG);
706 SvPAD_TYPED_on(namesv);
707 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
710 SvPAD_OUR_on(namesv);
711 SvOURSTASH_set(namesv, ourstash);
712 SvREFCNT_inc_simple_void_NN(ourstash);
715 av_store(PL_comppad_name, offset, namesv);
719 static PADOFFSET S_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash) {
726 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
728 sv_setpvn(namesv, namepv, namelen);
730 offset = S_pad_alloc_name(aTHX_ namesv, flags, typestash, ourstash);
732 /* not yet introduced */
733 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
734 COP_SEQ_RANGE_HIGH_set(namesv, 0);
736 if (!PL_min_intro_pending)
737 PL_min_intro_pending = offset;
738 PL_max_intro_pending = offset;
739 /* if it's not a simple scalar, replace with an AV or HV */
740 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
741 assert(SvREFCNT(PL_curpad[offset]) == 1);
742 if (namelen != 0 && *namepv == '@')
743 sv_upgrade(PL_curpad[offset], SVt_PVAV);
744 else if (namelen != 0 && *namepv == '%')
745 sv_upgrade(PL_curpad[offset], SVt_PVHV);
746 assert(SvPADMY(PL_curpad[offset]));
747 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
748 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
749 (long)offset, SvPVX(namesv),
750 PTR2UV(PL_curpad[offset])));
755 static PADOFFSET S_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) {
759 namepv = SvPV(name, namelen);
760 return S_pad_add_name_pvn(aTHX_ namepv, namelen, flags, typestash, ourstash);
765 #ifndef pad_findmy_sv
767 #define pad_findmy_sv(SV, FLAGS) \
768 S_pad_findmy(aTHX_ SvPV_nolen(SV), FLAGS)
770 #define PARENT_PAD_INDEX_set(SV, VAL) \
771 STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END
772 #define PARENT_FAKELEX_FLAGS_set(SV, VAL) \
773 STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END
775 static PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV *cv, U32 seq, int warn, SV **out_capture, SV **out_name_sv, int *out_flags) {
776 #define CvCOMPILED(CV) CvROOT(CV)
777 #define CvLATE(CV) (CvANON(CV) || SvTYPE(CV) == SVt_PVFM)
779 I32 offset, new_offset;
782 const AV *const padlist = CvPADLIST(cv);
786 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
787 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
788 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
790 /* first, search this pad */
792 if (padlist) { /* not an undef CV */
794 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
795 SV * const * const name_svp = AvARRAY(nameav);
797 for (offset = AvFILLp(nameav); offset > 0; offset--) {
798 const SV * const namesv = name_svp[offset];
799 if (namesv && namesv != &PL_sv_undef
800 && strEQ(SvPVX_const(namesv), name))
802 if (SvFAKE(namesv)) {
803 fake_offset = offset; /* in case we don't find a real one */
806 /* is seq within the range _LOW to _HIGH ?
807 * This is complicated by the fact that PL_cop_seqmax
808 * may have wrapped around at some point */
809 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
810 continue; /* not yet introduced */
812 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
813 /* in compiling scope */
815 (seq > COP_SEQ_RANGE_LOW(namesv))
816 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
817 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
822 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
824 ( seq > COP_SEQ_RANGE_LOW(namesv)
825 || seq <= COP_SEQ_RANGE_HIGH(namesv))
827 : ( seq > COP_SEQ_RANGE_LOW(namesv)
828 && seq <= COP_SEQ_RANGE_HIGH(namesv))
834 if (offset > 0 || fake_offset > 0 ) { /* a match! */
835 if (offset > 0) { /* not fake */
837 *out_name_sv = name_svp[offset]; /* return the namesv */
839 /* set PAD_FAKELEX_MULTI if this lex can have multiple
840 * instances. For now, we just test !CvUNIQUE(cv), but
841 * ideally, we should detect my's declared within loops
842 * etc - this would allow a wider range of 'not stayed
843 * shared' warnings. We also treated already-compiled
844 * lexes as not multi as viewed from evals. */
846 *out_flags = CvANON(cv) ?
848 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
849 ? PAD_FAKELEX_MULTI : 0;
851 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
852 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
853 PTR2UV(cv), (long)offset,
854 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
855 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
857 else { /* fake match */
858 offset = fake_offset;
859 *out_name_sv = name_svp[offset]; /* return the namesv */
860 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
861 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
862 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
863 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
864 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
868 /* return the lex? */
873 if (SvPAD_OUR(*out_name_sv)) {
878 /* trying to capture from an anon prototype? */
880 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
881 : *out_flags & PAD_FAKELEX_ANON)
884 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
885 "Variable \"%s\" is not available", name);
892 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
893 && !SvPAD_STATE(name_svp[offset])
894 && warn && ckWARN(WARN_CLOSURE)) {
896 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
897 "Variable \"%s\" will not stay shared", name);
900 if (fake_offset && CvANON(cv)
901 && CvCLONE(cv) &&!CvCLONED(cv))
904 /* not yet caught - look further up */
905 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
906 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
909 (void)S_pad_findlex(aTHX_ name, CvOUTSIDE(cv),
911 newwarn, out_capture, out_name_sv, out_flags);
916 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
917 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
918 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
919 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
920 PTR2UV(cv), PTR2UV(*out_capture)));
922 if (SvPADSTALE(*out_capture)
923 && !SvPAD_STATE(name_svp[offset]))
925 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
926 "Variable \"%s\" is not available", name);
932 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
933 else if (*name == '%')
934 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
936 *out_capture = sv_newmortal();
944 /* it's not in this pad - try above */
949 /* out_capture non-null means caller wants us to capture lex; in
950 * addition we capture ourselves unless it's an ANON/format */
951 new_capturep = out_capture ? out_capture :
952 CvLATE(cv) ? NULL : &new_capture;
954 offset = S_pad_findlex(aTHX_ name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
955 new_capturep, out_name_sv, out_flags);
956 if ((PADOFFSET)offset == NOT_IN_PAD)
959 /* found in an outer CV. Add appropriate fake entry to this pad */
961 /* don't add new fake entries (via eval) to CVs that we have already
962 * finished compiling, or to undef CVs */
963 if (CvCOMPILED(cv) || !padlist)
964 return 0; /* this dummy (and invalid) value isnt used by the caller */
967 /* This relies on sv_setsv_flags() upgrading the destination to the same
968 type as the source, independent of the flags set, and on it being
969 "good" and only copying flag bits and pointers that it understands.
971 SV *new_namesv = newSVsv(*out_name_sv);
972 AV * const ocomppad_name = PL_comppad_name;
973 PAD * const ocomppad = PL_comppad;
974 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
975 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
976 PL_curpad = AvARRAY(PL_comppad);
979 = pad_add_name_sv(new_namesv,
981 SvPAD_TYPED(*out_name_sv)
982 ? SvSTASH(*out_name_sv) : NULL,
983 SvOURSTASH(*out_name_sv)
986 SvFAKE_on(new_namesv);
987 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
988 "Pad addname: %ld \"%.*s\" FAKE\n",
990 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
991 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
993 PARENT_PAD_INDEX_set(new_namesv, 0);
994 if (SvPAD_OUR(new_namesv)) {
995 NOOP; /* do nothing */
997 else if (CvLATE(cv)) {
998 /* delayed creation - just note the offset within parent pad */
999 PARENT_PAD_INDEX_set(new_namesv, offset);
1003 /* immediate creation - capture outer value right now */
1004 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1005 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1006 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1007 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1009 *out_name_sv = new_namesv;
1010 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1012 PL_comppad_name = ocomppad_name;
1013 PL_comppad = ocomppad;
1014 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1021 static PADOFFSET S_pad_findmy(pTHX_ const char *name, U32 flags) {
1029 offset = S_pad_findlex(aTHX_ name, PL_compcv, PL_cop_seqmax, 1,
1030 NULL, &out_sv, &out_flags);
1031 if ((PADOFFSET)offset != NOT_IN_PAD)
1034 /* look for an our that's being introduced; this allows
1035 * our $foo = 0 unless defined $foo;
1036 * to not give a warning. (Yes, this is a hack) */
1038 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
1039 name_svp = AvARRAY(nameav);
1040 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1041 const SV * const namesv = name_svp[offset];
1042 if (namesv && namesv != &PL_sv_undef
1044 && (SvPAD_OUR(namesv))
1045 && strEQ(SvPVX_const(namesv), name)
1046 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
1055 #ifndef pad_findmy_pvs
1056 #define pad_findmy_pvs(S, FLAGS) S_pad_findmy(aTHX_ "" S "", FLAGS)
1059 static OP *S_newDEFSVOP(pTHX) {
1061 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
1062 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1063 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1066 OP * const o = newOP(OP_PADSV, 0);
1067 o->op_targ = offset;
1072 static U32 S_intro_my(pTHX) {
1078 ASSERT_CURPAD_ACTIVE("intro_my");
1079 if (!PL_min_intro_pending)
1080 return PL_cop_seqmax;
1082 svp = AvARRAY(PL_comppad_name);
1083 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1084 SV *const sv = svp[i];
1086 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1087 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1089 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1090 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1091 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1092 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1093 (long)i, SvPVX_const(sv),
1094 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1095 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1099 seq = PL_cop_seqmax;
1101 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1103 PL_min_intro_pending = 0;
1104 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1105 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1106 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));