3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
21 /* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
35 #define PERL_IN_PP_HOT_C
49 PL_curcop = (COP*)PL_op;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
61 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
62 PUSHs(save_scalar(cGVOP_gv));
64 PUSHs(GvSVn(cGVOP_gv));
69 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
76 /* This is sometimes called directly by pp_coreargs, pp_grepstart and
80 PUSHMARK(PL_stack_sp);
91 /* no PUTBACK, SETs doesn't inc/dec SP */
98 XPUSHs(MUTABLE_SV(cGVOP_gv));
103 /* also used for: pp_andassign() */
109 /* SP is not used to remove a variable that is saved across the
110 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
111 register or load/store vs direct mem ops macro is introduced, this
112 should be a define block between direct PL_stack_sp and dSP operations,
113 presently, using PL_stack_sp is bias towards CISC cpus */
114 SV * const sv = *PL_stack_sp;
118 if (PL_op->op_type == OP_AND)
120 return cLOGOP->op_other;
128 /* sassign keeps its args in the optree traditionally backwards.
129 So we pop them differently.
131 SV *left = POPs; SV *right = TOPs;
133 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
134 SV * const temp = left;
135 left = right; right = temp;
137 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
139 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
141 SV * const cv = SvRV(right);
142 const U32 cv_type = SvTYPE(cv);
143 const bool is_gv = isGV_with_GP(left);
144 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
150 /* Can do the optimisation if left (LVALUE) is not a typeglob,
151 right (RVALUE) is a reference to something, and we're in void
153 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
154 /* Is the target symbol table currently empty? */
155 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
156 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
157 /* Good. Create a new proxy constant subroutine in the target.
158 The gv becomes a(nother) reference to the constant. */
159 SV *const value = SvRV(cv);
161 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
162 SvPCS_IMPORTED_on(gv);
164 SvREFCNT_inc_simple_void(value);
170 /* Need to fix things up. */
172 /* Need to fix GV. */
173 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
177 /* We've been returned a constant rather than a full subroutine,
178 but they expect a subroutine reference to apply. */
180 ENTER_with_name("sassign_coderef");
181 SvREFCNT_inc_void(SvRV(cv));
182 /* newCONSTSUB takes a reference count on the passed in SV
183 from us. We set the name to NULL, otherwise we get into
184 all sorts of fun as the reference to our new sub is
185 donated to the GV that we're about to assign to.
187 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
190 LEAVE_with_name("sassign_coderef");
192 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
194 First: ops for \&{"BONK"}; return us the constant in the
196 Second: ops for *{"BONK"} cause that symbol table entry
197 (and our reference to it) to be upgraded from RV
199 Thirdly: We get here. cv is actually PVGV now, and its
200 GvCV() is actually the subroutine we're looking for
202 So change the reference so that it points to the subroutine
203 of that typeglob, as that's what they were after all along.
205 GV *const upgraded = MUTABLE_GV(cv);
206 CV *const source = GvCV(upgraded);
209 assert(CvFLAGS(source) & CVf_CONST);
211 SvREFCNT_inc_void(source);
212 SvREFCNT_dec_NN(upgraded);
213 SvRV_set(right, MUTABLE_SV(source));
219 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
220 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
223 packWARN(WARN_MISC), "Useless assignment to a temporary"
225 SvSetMagicSV(left, right);
235 RETURNOP(cLOGOP->op_other);
237 RETURNOP(cLOGOP->op_next);
243 TAINT_NOT; /* Each statement is presumed innocent */
244 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
246 if (!(PL_op->op_flags & OPf_SPECIAL)) {
247 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
248 LEAVE_SCOPE(oldsave);
255 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
260 const char *rpv = NULL;
262 bool rcopied = FALSE;
264 if (TARG == right && right != left) { /* $r = $l.$r */
265 rpv = SvPV_nomg_const(right, rlen);
266 rbyte = !DO_UTF8(right);
267 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
268 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
272 if (TARG != left) { /* not $l .= $r */
274 const char* const lpv = SvPV_nomg_const(left, llen);
275 lbyte = !DO_UTF8(left);
276 sv_setpvn(TARG, lpv, llen);
282 else { /* $l .= $r and left == TARG */
284 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
285 report_uninit(right);
289 SvPV_force_nomg_nolen(left);
291 lbyte = !DO_UTF8(left);
297 rpv = SvPV_nomg_const(right, rlen);
298 rbyte = !DO_UTF8(right);
300 if (lbyte != rbyte) {
302 sv_utf8_upgrade_nomg(TARG);
305 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
306 sv_utf8_upgrade_nomg(right);
307 rpv = SvPV_nomg_const(right, rlen);
310 sv_catpvn_nomg(TARG, rpv, rlen);
317 /* push the elements of av onto the stack.
318 * XXX Note that padav has similar code but without the mg_get().
319 * I suspect that the mg_get is no longer needed, but while padav
320 * differs, it can't share this function */
323 S_pushav(pTHX_ AV* const av)
326 const SSize_t maxarg = AvFILL(av) + 1;
328 if (UNLIKELY(SvRMAGICAL(av))) {
330 for (i=0; i < (PADOFFSET)maxarg; i++) {
331 SV ** const svp = av_fetch(av, i, FALSE);
332 /* See note in pp_helem, and bug id #27839 */
334 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
340 for (i=0; i < (PADOFFSET)maxarg; i++) {
341 SV * const sv = AvARRAY(av)[i];
342 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
350 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
355 PADOFFSET base = PL_op->op_targ;
356 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
358 if (PL_op->op_flags & OPf_SPECIAL) {
359 /* fake the RHS of my ($x,$y,..) = @_ */
361 S_pushav(aTHX_ GvAVn(PL_defgv));
365 /* note, this is only skipped for compile-time-known void cxt */
366 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
369 for (i = 0; i <count; i++)
370 *++SP = PAD_SV(base+i);
372 if (PL_op->op_private & OPpLVAL_INTRO) {
373 SV **svp = &(PAD_SVl(base));
374 const UV payload = (UV)(
375 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
376 | (count << SAVE_TIGHT_SHIFT)
377 | SAVEt_CLEARPADRANGE);
378 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
379 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
386 for (i = 0; i <count; i++)
387 SvPADSTALE_off(*svp++); /* mark lexical as active */
398 OP * const op = PL_op;
399 /* access PL_curpad once */
400 SV ** const padentry = &(PAD_SVl(op->op_targ));
405 PUTBACK; /* no pop/push after this, TOPs ok */
407 if (op->op_flags & OPf_MOD) {
408 if (op->op_private & OPpLVAL_INTRO)
409 if (!(op->op_private & OPpPAD_STATE))
410 save_clearsv(padentry);
411 if (op->op_private & OPpDEREF) {
412 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
413 than TARG reduces the scope of TARG, so it does not
414 span the call to save_clearsv, resulting in smaller
416 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
428 tryAMAGICunTARGETlist(iter_amg, 0);
429 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
431 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
432 if (!isGV_with_GP(PL_last_in_gv)) {
433 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
434 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
437 XPUSHs(MUTABLE_SV(PL_last_in_gv));
440 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
441 if (PL_last_in_gv == (GV *)&PL_sv_undef)
442 PL_last_in_gv = NULL;
444 assert(isGV_with_GP(PL_last_in_gv));
447 return do_readline();
455 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
459 (SvIOK_notUV(left) && SvIOK_notUV(right))
460 ? (SvIVX(left) == SvIVX(right))
461 : ( do_ncmp(left, right) == 0)
467 /* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
473 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
474 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
475 Perl_croak_no_modify();
476 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
477 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
479 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
480 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
482 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
483 if (inc) sv_inc(TOPs);
490 /* also used for: pp_orassign() */
499 if (PL_op->op_type == OP_OR)
501 RETURNOP(cLOGOP->op_other);
506 /* also used for: pp_dor() pp_dorassign() */
513 const int op_type = PL_op->op_type;
514 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
519 if (UNLIKELY(!sv || !SvANY(sv))) {
520 if (op_type == OP_DOR)
522 RETURNOP(cLOGOP->op_other);
528 if (UNLIKELY(!sv || !SvANY(sv)))
533 switch (SvTYPE(sv)) {
535 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
539 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
543 if (CvROOT(sv) || CvXSUB(sv))
556 if(op_type == OP_DOR)
558 RETURNOP(cLOGOP->op_other);
560 /* assuming OP_DEFINED */
568 dSP; dATARGET; bool useleft; SV *svl, *svr;
569 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
573 useleft = USE_LEFT(svl);
574 #ifdef PERL_PRESERVE_IVUV
575 /* We must see if we can perform the addition with integers if possible,
576 as the integer code detects overflow while the NV code doesn't.
577 If either argument hasn't had a numeric conversion yet attempt to get
578 the IV. It's important to do this now, rather than just assuming that
579 it's not IOK as a PV of "9223372036854775806" may not take well to NV
580 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
581 integer in case the second argument is IV=9223372036854775806
582 We can (now) rely on sv_2iv to do the right thing, only setting the
583 public IOK flag if the value in the NV (or PV) slot is truly integer.
585 A side effect is that this also aggressively prefers integer maths over
586 fp maths for integer values.
588 How to detect overflow?
590 C 99 section 6.2.6.1 says
592 The range of nonnegative values of a signed integer type is a subrange
593 of the corresponding unsigned integer type, and the representation of
594 the same value in each type is the same. A computation involving
595 unsigned operands can never overflow, because a result that cannot be
596 represented by the resulting unsigned integer type is reduced modulo
597 the number that is one greater than the largest value that can be
598 represented by the resulting type.
602 which I read as "unsigned ints wrap."
604 signed integer overflow seems to be classed as "exception condition"
606 If an exceptional condition occurs during the evaluation of an
607 expression (that is, if the result is not mathematically defined or not
608 in the range of representable values for its type), the behavior is
611 (6.5, the 5th paragraph)
613 I had assumed that on 2s complement machines signed arithmetic would
614 wrap, hence coded pp_add and pp_subtract on the assumption that
615 everything perl builds on would be happy. After much wailing and
616 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
617 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
618 unsigned code below is actually shorter than the old code. :-)
621 if (SvIV_please_nomg(svr)) {
622 /* Unless the left argument is integer in range we are going to have to
623 use NV maths. Hence only attempt to coerce the right argument if
624 we know the left is integer. */
632 /* left operand is undef, treat as zero. + 0 is identity,
633 Could SETi or SETu right now, but space optimise by not adding
634 lots of code to speed up what is probably a rarish case. */
636 /* Left operand is defined, so is it IV? */
637 if (SvIV_please_nomg(svl)) {
638 if ((auvok = SvUOK(svl)))
641 const IV aiv = SvIVX(svl);
644 auvok = 1; /* Now acting as a sign flag. */
646 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
653 bool result_good = 0;
656 bool buvok = SvUOK(svr);
661 const IV biv = SvIVX(svr);
666 buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
668 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
669 else "IV" now, independent of how it came in.
670 if a, b represents positive, A, B negative, a maps to -A etc
675 all UV maths. negate result if A negative.
676 add if signs same, subtract if signs differ. */
682 /* Must get smaller */
688 /* result really should be -(auv-buv). as its negation
689 of true value, need to swap our result flag */
706 if (result <= (UV)IV_MIN)
707 SETi(result == (UV)IV_MIN
708 ? IV_MIN : -(IV)result);
710 /* result valid, but out of range for IV. */
715 } /* Overflow, drop through to NVs. */
720 NV value = SvNV_nomg(svr);
723 /* left operand is undef, treat as zero. + 0.0 is identity. */
727 SETn( value + SvNV_nomg(svl) );
733 /* also used for: pp_aelemfast_lex() */
738 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
739 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
740 const U32 lval = PL_op->op_flags & OPf_MOD;
741 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
742 SV *sv = (svp ? *svp : &PL_sv_undef);
744 if (UNLIKELY(!svp && lval))
745 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
748 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
758 do_join(TARG, *MARK, MARK, SP);
769 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
770 * will be enough to hold an OP*.
772 SV* const sv = sv_newmortal();
773 sv_upgrade(sv, SVt_PVLV);
775 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
778 XPUSHs(MUTABLE_SV(PL_op));
783 /* Oversized hot code. */
785 /* also used for: pp_say() */
789 dSP; dMARK; dORIGMARK;
793 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
797 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
800 if (MARK == ORIGMARK) {
801 /* If using default handle then we need to make space to
802 * pass object as 1st arg, so move other args up ...
806 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
809 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
811 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
812 | (PL_op->op_type == OP_SAY
813 ? TIED_METHOD_SAY : 0)), sp - mark);
816 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
817 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
820 SETERRNO(EBADF,RMS_IFI);
823 else if (!(fp = IoOFP(io))) {
825 report_wrongway_fh(gv, '<');
828 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
832 SV * const ofs = GvSV(PL_ofsgv); /* $, */
834 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
836 if (!do_print(*MARK, fp))
840 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
841 if (!do_print(GvSV(PL_ofsgv), fp)) {
850 if (!do_print(*MARK, fp))
858 if (PL_op->op_type == OP_SAY) {
859 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
862 else if (PL_ors_sv && SvOK(PL_ors_sv))
863 if (!do_print(PL_ors_sv, fp)) /* $\ */
866 if (IoFLAGS(io) & IOf_FLUSH)
867 if (PerlIO_flush(fp) == EOF)
877 XPUSHs(&PL_sv_undef);
882 /* also used for: pp_rv2hv() */
883 /* also called directly by pp_lvavref */
888 const I32 gimme = GIMME_V;
889 static const char an_array[] = "an ARRAY";
890 static const char a_hash[] = "a HASH";
891 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
892 || PL_op->op_type == OP_LVAVREF;
893 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
897 if (UNLIKELY(SvAMAGIC(sv))) {
898 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
901 if (UNLIKELY(SvTYPE(sv) != type))
902 /* diag_listed_as: Not an ARRAY reference */
903 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
904 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
905 && PL_op->op_private & OPpLVAL_INTRO))
906 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
908 else if (UNLIKELY(SvTYPE(sv) != type)) {
911 if (!isGV_with_GP(sv)) {
912 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
920 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
921 if (PL_op->op_private & OPpLVAL_INTRO)
922 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
924 if (PL_op->op_flags & OPf_REF) {
928 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
929 const I32 flags = is_lvalue_sub();
930 if (flags && !(flags & OPpENTERSUB_INARGS)) {
931 if (gimme != G_ARRAY)
932 goto croak_cant_return;
939 AV *const av = MUTABLE_AV(sv);
940 /* The guts of pp_rv2av */
941 if (gimme == G_ARRAY) {
947 else if (gimme == G_SCALAR) {
949 const SSize_t maxarg = AvFILL(av) + 1;
953 /* The guts of pp_rv2hv */
954 if (gimme == G_ARRAY) { /* array wanted */
956 return Perl_do_kv(aTHX);
958 else if ((PL_op->op_private & OPpTRUEBOOL
959 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
960 && block_gimme() == G_VOID ))
961 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
962 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
963 else if (gimme == G_SCALAR) {
965 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
972 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
973 is_pp_rv2av ? "array" : "hash");
978 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
980 PERL_ARGS_ASSERT_DO_ODDBALL;
983 if (ckWARN(WARN_MISC)) {
985 if (oddkey == firstkey &&
987 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
988 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
990 err = "Reference found where even-sized list expected";
993 err = "Odd number of elements in hash assignment";
994 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1001 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
1002 * are common to both the LHS and RHS of an aassign, and replace them
1003 * with copies. All these copies are made before the actual list assign is
1006 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
1007 * element ($b) to the first LH element ($a), modifies $a; when the
1008 * second assignment is done, the second RH element now has the wrong
1009 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
1010 * Note that we don't need to make a mortal copy of $b.
1012 * The algorithm below works by, for every RHS element, mark the
1013 * corresponding LHS target element with SVf_BREAK. Then if the RHS
1014 * element is found with SVf_BREAK set, it means it would have been
1015 * modified, so make a copy.
1016 * Note that by scanning both LHS and RHS in lockstep, we avoid
1017 * unnecessary copies (like $b above) compared with a naive
1018 * "mark all LHS; copy all marked RHS; unmark all LHS".
1020 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
1021 * it can't be common and can be skipped.
1023 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
1024 * that we thought we didn't need to call S_aassign_copy_common(), but we
1025 * have anyway for sanity checking. If we find we need to copy, then panic.
1028 PERL_STATIC_INLINE void
1029 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
1030 SV **firstrelem, SV **lastrelem
1039 SSize_t lcount = lastlelem - firstlelem + 1;
1040 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
1041 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
1043 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
1044 assert(firstlelem < lastlelem); /* at least 2 LH elements */
1045 assert(firstrelem < lastrelem); /* at least 2 RH elements */
1049 /* we never have to copy the first RH element; it can't be corrupted
1050 * by assigning something to the corresponding first LH element.
1051 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
1053 relem = firstrelem + 1;
1055 for (; relem <= lastrelem; relem++) {
1058 /* mark next LH element */
1060 if (--lcount >= 0) {
1063 if (UNLIKELY(!svl)) {/* skip AV alias marker */
1064 assert (lelem <= lastlelem);
1070 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
1073 /* this LH element will consume all further args;
1074 * no need to mark any further LH elements (if any).
1075 * But we still need to scan any remaining RHS elements;
1076 * set lcount negative to distinguish from lcount == 0,
1077 * so the loop condition continues being true
1080 lelem--; /* no need to unmark this element */
1082 else if (!(do_rc1 && SvREFCNT(svl) == 1) && svl != &PL_sv_undef) {
1083 assert(!SvIMMORTAL(svl));
1084 SvFLAGS(svl) |= SVf_BREAK;
1088 /* don't check RH element if no SVf_BREAK flags set yet */
1095 /* see if corresponding RH element needs copying */
1101 if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) {
1105 /* op_dump(PL_op); */
1107 "panic: aassign skipped needed copy of common RH elem %"
1108 UVuf, (UV)(relem - firstrelem));
1112 TAINT_NOT; /* Each item is independent */
1114 /* Dear TODO test in t/op/sort.t, I love you.
1115 (It's relying on a panic, not a "semi-panic" from newSVsv()
1116 and then an assertion failure below.) */
1117 if (UNLIKELY(SvIS_FREED(svr))) {
1118 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1121 /* avoid break flag while copying; otherwise COW etc
1123 SvFLAGS(svr) &= ~SVf_BREAK;
1124 /* Not newSVsv(), as it does not allow copy-on-write,
1125 resulting in wasteful copies.
1126 Also, we use SV_NOSTEAL in case the SV is used more than
1127 once, e.g. (...) = (f())[0,0]
1128 Where the same SV appears twice on the RHS without a ref
1129 count bump. (Although I suspect that the SV won't be
1130 stealable here anyway - DAPM).
1132 *relem = sv_mortalcopy_flags(svr,
1133 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1134 /* ... but restore afterwards in case it's needed again,
1135 * e.g. ($a,$b,$c) = (1,$a,$a)
1137 SvFLAGS(svr) |= SVf_BREAK;
1149 while (lelem > firstlelem) {
1150 SV * const svl = *(--lelem);
1152 SvFLAGS(svl) &= ~SVf_BREAK;
1161 SV **lastlelem = PL_stack_sp;
1162 SV **lastrelem = PL_stack_base + POPMARK;
1163 SV **firstrelem = PL_stack_base + POPMARK + 1;
1164 SV **firstlelem = lastrelem + 1;
1181 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1183 /* If there's a common identifier on both sides we have to take
1184 * special care that assigning the identifier on the left doesn't
1185 * clobber a value on the right that's used later in the list.
1188 if ( (PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1))
1189 /* at least 2 LH and RH elements, or commonality isn't an issue */
1190 && (firstlelem < lastlelem && firstrelem < lastrelem)
1192 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1193 /* skip the scan if all scalars have a ref count of 1 */
1194 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1196 if (!sv || SvREFCNT(sv) == 1)
1198 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1205 S_aassign_copy_common(aTHX_
1206 firstlelem, lastlelem, firstrelem, lastrelem
1215 /* on debugging builds, do the scan even if we've concluded we
1216 * don't need to, then panic if we find commonality. Note that the
1217 * scanner assumes at least 2 elements */
1218 if (firstlelem < lastlelem && firstrelem < lastrelem) {
1226 lval = (gimme == G_ARRAY) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1233 while (LIKELY(lelem <= lastlelem)) {
1235 TAINT_NOT; /* Each item stands on its own, taintwise. */
1237 if (UNLIKELY(!sv)) {
1240 ASSUME(SvTYPE(sv) == SVt_PVAV);
1242 switch (SvTYPE(sv)) {
1244 bool already_copied = FALSE;
1245 ary = MUTABLE_AV(sv);
1246 magic = SvMAGICAL(ary) != 0;
1248 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1250 /* We need to clear ary. The is a danger that if we do this,
1251 * elements on the RHS may be prematurely freed, e.g.
1253 * In the case of possible commonality, make a copy of each
1254 * RHS SV *before* clearing the array, and add a reference
1255 * from the tmps stack, so that it doesn't leak on death.
1256 * Otherwise, make a copy of each RHS SV only as we're storing
1257 * it into the array - that way we don't have to worry about
1258 * it being leaked if we die, but don't incur the cost of
1259 * mortalising everything.
1262 if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1263 && (relem <= lastrelem)
1264 && (magic || AvFILL(ary) != -1))
1267 EXTEND_MORTAL(lastrelem - relem + 1);
1268 for (svp = relem; svp <= lastrelem; svp++) {
1269 /* see comment in S_aassign_copy_common about SV_NOSTEAL */
1270 *svp = sv_mortalcopy_flags(*svp,
1271 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1274 already_copied = TRUE;
1278 av_extend(ary, lastrelem - relem);
1280 while (relem <= lastrelem) { /* gobble up all the rest */
1282 if (LIKELY(!alias)) {
1287 /* before newSV, in case it dies */
1290 /* see comment in S_aassign_copy_common about
1292 sv_setsv_flags(sv, *relem,
1293 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1298 if (!already_copied)
1301 DIE(aTHX_ "Assigned value is not a reference");
1302 if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1303 /* diag_listed_as: Assigned value is not %s reference */
1305 "Assigned value is not a SCALAR reference");
1306 if (lval && !already_copied)
1307 *relem = sv_mortalcopy(*relem);
1308 /* XXX else check for weak refs? */
1309 sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1313 SvREFCNT_inc_simple_NN(sv); /* undo mortal free */
1314 didstore = av_store(ary,i++,sv);
1323 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1324 SvSETMAGIC(MUTABLE_SV(ary));
1329 case SVt_PVHV: { /* normal hash */
1333 SV** topelem = relem;
1334 SV **firsthashrelem = relem;
1335 bool already_copied = FALSE;
1337 hash = MUTABLE_HV(sv);
1338 magic = SvMAGICAL(hash) != 0;
1340 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1341 if (UNLIKELY(odd)) {
1342 do_oddball(lastrelem, firsthashrelem);
1343 /* we have firstlelem to reuse, it's not needed anymore
1345 *(lastrelem+1) = &PL_sv_undef;
1349 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1351 /* We need to clear hash. The is a danger that if we do this,
1352 * elements on the RHS may be prematurely freed, e.g.
1353 * %h = (foo => $h{bar});
1354 * In the case of possible commonality, make a copy of each
1355 * RHS SV *before* clearing the hash, and add a reference
1356 * from the tmps stack, so that it doesn't leak on death.
1359 if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1360 && (relem <= lastrelem)
1361 && (magic || HvUSEDKEYS(hash)))
1364 EXTEND_MORTAL(lastrelem - relem + 1);
1365 for (svp = relem; svp <= lastrelem; svp++) {
1366 *svp = sv_mortalcopy_flags(*svp,
1367 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1370 already_copied = TRUE;
1375 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1378 /* Copy the key if aassign is called in lvalue context,
1379 to avoid having the next op modify our rhs. Copy
1380 it also if it is gmagical, lest it make the
1381 hv_store_ent call below croak, leaking the value. */
1382 sv = (lval || SvGMAGICAL(*relem)) && !already_copied
1383 ? sv_mortalcopy(*relem)
1392 sv_setsv_nomg(tmpstr,*relem++); /* value */
1395 if (gimme == G_ARRAY) {
1396 if (hv_exists_ent(hash, sv, 0))
1397 /* key overwrites an existing entry */
1400 /* copy element back: possibly to an earlier
1401 * stack location if we encountered dups earlier,
1402 * possibly to a later stack location if odd */
1404 *topelem++ = tmpstr;
1408 SvREFCNT_inc_simple_NN(tmpstr); /* undo mortal free */
1409 didstore = hv_store_ent(hash,sv,tmpstr,0);
1411 if (!didstore) sv_2mortal(tmpstr);
1417 if (duplicates && gimme == G_ARRAY) {
1418 /* at this point we have removed the duplicate key/value
1419 * pairs from the stack, but the remaining values may be
1420 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1421 * the (a 2), but the stack now probably contains
1422 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1423 * obliterates the earlier key. So refresh all values. */
1424 lastrelem -= duplicates;
1425 relem = firsthashrelem;
1426 while (relem < lastrelem+odd) {
1428 he = hv_fetch_ent(hash, *relem++, 0, 0);
1429 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1432 if (odd && gimme == G_ARRAY) lastrelem++;
1436 if (SvIMMORTAL(sv)) {
1437 if (relem <= lastrelem)
1441 if (relem <= lastrelem) {
1443 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1444 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1447 packWARN(WARN_MISC),
1448 "Useless assignment to a temporary"
1450 sv_setsv(sv, *relem);
1454 sv_setsv(sv, &PL_sv_undef);
1459 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1460 /* Will be used to set PL_tainting below */
1461 Uid_t tmp_uid = PerlProc_getuid();
1462 Uid_t tmp_euid = PerlProc_geteuid();
1463 Gid_t tmp_gid = PerlProc_getgid();
1464 Gid_t tmp_egid = PerlProc_getegid();
1466 /* XXX $> et al currently silently ignore failures */
1467 if (PL_delaymagic & DM_UID) {
1468 #ifdef HAS_SETRESUID
1470 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1471 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1474 # ifdef HAS_SETREUID
1476 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1477 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1480 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1481 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1482 PL_delaymagic &= ~DM_RUID;
1484 # endif /* HAS_SETRUID */
1486 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1487 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1488 PL_delaymagic &= ~DM_EUID;
1490 # endif /* HAS_SETEUID */
1491 if (PL_delaymagic & DM_UID) {
1492 if (PL_delaymagic_uid != PL_delaymagic_euid)
1493 DIE(aTHX_ "No setreuid available");
1494 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1496 # endif /* HAS_SETREUID */
1497 #endif /* HAS_SETRESUID */
1499 tmp_uid = PerlProc_getuid();
1500 tmp_euid = PerlProc_geteuid();
1502 /* XXX $> et al currently silently ignore failures */
1503 if (PL_delaymagic & DM_GID) {
1504 #ifdef HAS_SETRESGID
1506 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1507 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1510 # ifdef HAS_SETREGID
1512 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1513 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1516 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1517 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1518 PL_delaymagic &= ~DM_RGID;
1520 # endif /* HAS_SETRGID */
1522 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1523 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1524 PL_delaymagic &= ~DM_EGID;
1526 # endif /* HAS_SETEGID */
1527 if (PL_delaymagic & DM_GID) {
1528 if (PL_delaymagic_gid != PL_delaymagic_egid)
1529 DIE(aTHX_ "No setregid available");
1530 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1532 # endif /* HAS_SETREGID */
1533 #endif /* HAS_SETRESGID */
1535 tmp_gid = PerlProc_getgid();
1536 tmp_egid = PerlProc_getegid();
1538 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1539 #ifdef NO_TAINT_SUPPORT
1540 PERL_UNUSED_VAR(tmp_uid);
1541 PERL_UNUSED_VAR(tmp_euid);
1542 PERL_UNUSED_VAR(tmp_gid);
1543 PERL_UNUSED_VAR(tmp_egid);
1548 if (gimme == G_VOID)
1549 SP = firstrelem - 1;
1550 else if (gimme == G_SCALAR) {
1553 SETi(lastrelem - firstrelem + 1);
1557 /* note that in this case *firstlelem may have been overwritten
1558 by sv_undef in the odd hash case */
1561 SP = firstrelem + (lastlelem - firstlelem);
1562 lelem = firstlelem + (relem - firstrelem);
1564 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1574 PMOP * const pm = cPMOP;
1575 REGEXP * rx = PM_GETRE(pm);
1576 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1577 SV * const rv = sv_newmortal();
1581 SvUPGRADE(rv, SVt_IV);
1582 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1583 loathe to use it here, but it seems to be the right fix. Or close.
1584 The key part appears to be that it's essential for pp_qr to return a new
1585 object (SV), which implies that there needs to be an effective way to
1586 generate a new SV from the existing SV that is pre-compiled in the
1588 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1591 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1592 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1593 *cvp = cv_clone(cv);
1594 SvREFCNT_dec_NN(cv);
1598 HV *const stash = gv_stashsv(pkg, GV_ADD);
1599 SvREFCNT_dec_NN(pkg);
1600 (void)sv_bless(rv, stash);
1603 if (UNLIKELY(RX_ISTAINTED(rx))) {
1605 SvTAINTED_on(SvRV(rv));
1618 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1621 const char *truebase; /* Start of string */
1622 REGEXP *rx = PM_GETRE(pm);
1624 const I32 gimme = GIMME_V;
1626 const I32 oldsave = PL_savestack_ix;
1627 I32 had_zerolen = 0;
1630 if (PL_op->op_flags & OPf_STACKED)
1639 PUTBACK; /* EVAL blocks need stack_sp. */
1640 /* Skip get-magic if this is a qr// clone, because regcomp has
1642 truebase = ReANY(rx)->mother_re
1643 ? SvPV_nomg_const(TARG, len)
1644 : SvPV_const(TARG, len);
1646 DIE(aTHX_ "panic: pp_match");
1647 strend = truebase + len;
1648 rxtainted = (RX_ISTAINTED(rx) ||
1649 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1652 /* We need to know this in case we fail out early - pos() must be reset */
1653 global = dynpm->op_pmflags & PMf_GLOBAL;
1655 /* PMdf_USED is set after a ?? matches once */
1658 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1660 pm->op_pmflags & PMf_USED
1663 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1667 /* empty pattern special-cased to use last successful pattern if
1668 possible, except for qr// */
1669 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1675 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1676 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1677 UVuf" < %"IVdf")\n",
1678 (UV)len, (IV)RX_MINLEN(rx)));
1682 /* get pos() if //g */
1684 mg = mg_find_mglob(TARG);
1685 if (mg && mg->mg_len >= 0) {
1686 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1687 /* last time pos() was set, it was zero-length match */
1688 if (mg->mg_flags & MGf_MINMATCH)
1693 #ifdef PERL_SAWAMPERSAND
1696 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1697 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1701 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1702 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1703 * only on the first iteration. Therefore we need to copy $' as well
1704 * as $&, to make the rest of the string available for captures in
1705 * subsequent iterations */
1706 if (! (global && gimme == G_ARRAY))
1707 r_flags |= REXEC_COPY_SKIP_POST;
1709 #ifdef PERL_SAWAMPERSAND
1710 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1711 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1712 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1719 s = truebase + curpos;
1721 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1722 had_zerolen, TARG, NULL, r_flags))
1726 if (dynpm->op_pmflags & PMf_ONCE)
1728 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1730 dynpm->op_pmflags |= PMf_USED;
1734 RX_MATCH_TAINTED_on(rx);
1735 TAINT_IF(RX_MATCH_TAINTED(rx));
1739 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1741 mg = sv_magicext_mglob(TARG);
1742 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1743 if (RX_ZERO_LEN(rx))
1744 mg->mg_flags |= MGf_MINMATCH;
1746 mg->mg_flags &= ~MGf_MINMATCH;
1749 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1750 LEAVE_SCOPE(oldsave);
1754 /* push captures on stack */
1757 const I32 nparens = RX_NPARENS(rx);
1758 I32 i = (global && !nparens) ? 1 : 0;
1760 SPAGAIN; /* EVAL blocks could move the stack. */
1761 EXTEND(SP, nparens + i);
1762 EXTEND_MORTAL(nparens + i);
1763 for (i = !i; i <= nparens; i++) {
1764 PUSHs(sv_newmortal());
1765 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1766 && RX_OFFS(rx)[i].end != -1 ))
1768 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1769 const char * const s = RX_OFFS(rx)[i].start + truebase;
1770 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1771 || len < 0 || len > strend - s))
1772 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1773 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1774 (long) i, (long) RX_OFFS(rx)[i].start,
1775 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1776 sv_setpvn(*SP, s, len);
1777 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1782 curpos = (UV)RX_OFFS(rx)[0].end;
1783 had_zerolen = RX_ZERO_LEN(rx);
1784 PUTBACK; /* EVAL blocks may use stack */
1785 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1788 LEAVE_SCOPE(oldsave);
1791 NOT_REACHED; /* NOTREACHED */
1794 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1796 mg = mg_find_mglob(TARG);
1800 LEAVE_SCOPE(oldsave);
1801 if (gimme == G_ARRAY)
1807 Perl_do_readline(pTHX)
1809 dSP; dTARGETSTACKED;
1814 IO * const io = GvIO(PL_last_in_gv);
1815 const I32 type = PL_op->op_type;
1816 const I32 gimme = GIMME_V;
1819 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1821 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1822 if (gimme == G_SCALAR) {
1824 SvSetSV_nosteal(TARG, TOPs);
1834 if (IoFLAGS(io) & IOf_ARGV) {
1835 if (IoFLAGS(io) & IOf_START) {
1837 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1838 IoFLAGS(io) &= ~IOf_START;
1839 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1840 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1841 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1842 SvSETMAGIC(GvSV(PL_last_in_gv));
1847 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1848 if (!fp) { /* Note: fp != IoIFP(io) */
1849 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1852 else if (type == OP_GLOB)
1853 fp = Perl_start_glob(aTHX_ POPs, io);
1855 else if (type == OP_GLOB)
1857 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1858 report_wrongway_fh(PL_last_in_gv, '>');
1862 if ((!io || !(IoFLAGS(io) & IOf_START))
1863 && ckWARN(WARN_CLOSED)
1866 report_evil_fh(PL_last_in_gv);
1868 if (gimme == G_SCALAR) {
1869 /* undef TARG, and push that undefined value */
1870 if (type != OP_RCATLINE) {
1871 sv_setsv(TARG,NULL);
1878 if (gimme == G_SCALAR) {
1880 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1883 if (type == OP_RCATLINE)
1884 SvPV_force_nomg_nolen(sv);
1888 else if (isGV_with_GP(sv)) {
1889 SvPV_force_nomg_nolen(sv);
1891 SvUPGRADE(sv, SVt_PV);
1892 tmplen = SvLEN(sv); /* remember if already alloced */
1893 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1894 /* try short-buffering it. Please update t/op/readline.t
1895 * if you change the growth length.
1900 if (type == OP_RCATLINE && SvOK(sv)) {
1902 SvPV_force_nomg_nolen(sv);
1908 sv = sv_2mortal(newSV(80));
1912 /* This should not be marked tainted if the fp is marked clean */
1913 #define MAYBE_TAINT_LINE(io, sv) \
1914 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1919 /* delay EOF state for a snarfed empty file */
1920 #define SNARF_EOF(gimme,rs,io,sv) \
1921 (gimme != G_SCALAR || SvCUR(sv) \
1922 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1926 if (!sv_gets(sv, fp, offset)
1928 || SNARF_EOF(gimme, PL_rs, io, sv)
1929 || PerlIO_error(fp)))
1931 PerlIO_clearerr(fp);
1932 if (IoFLAGS(io) & IOf_ARGV) {
1933 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1936 (void)do_close(PL_last_in_gv, FALSE);
1938 else if (type == OP_GLOB) {
1939 if (!do_close(PL_last_in_gv, FALSE)) {
1940 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1941 "glob failed (child exited with status %d%s)",
1942 (int)(STATUS_CURRENT >> 8),
1943 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1946 if (gimme == G_SCALAR) {
1947 if (type != OP_RCATLINE) {
1948 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1954 MAYBE_TAINT_LINE(io, sv);
1957 MAYBE_TAINT_LINE(io, sv);
1959 IoFLAGS(io) |= IOf_NOLINE;
1963 if (type == OP_GLOB) {
1966 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1967 char * const tmps = SvEND(sv) - 1;
1968 if (*tmps == *SvPVX_const(PL_rs)) {
1970 SvCUR_set(sv, SvCUR(sv) - 1);
1973 for (t1 = SvPVX_const(sv); *t1; t1++)
1975 if (strchr("*%?", *t1))
1977 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1980 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1981 (void)POPs; /* Unmatched wildcard? Chuck it... */
1984 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1985 if (ckWARN(WARN_UTF8)) {
1986 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1987 const STRLEN len = SvCUR(sv) - offset;
1990 if (!is_utf8_string_loc(s, len, &f))
1991 /* Emulate :encoding(utf8) warning in the same case. */
1992 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1993 "utf8 \"\\x%02X\" does not map to Unicode",
1994 f < (U8*)SvEND(sv) ? *f : 0);
1997 if (gimme == G_ARRAY) {
1998 if (SvLEN(sv) - SvCUR(sv) > 20) {
1999 SvPV_shrink_to_cur(sv);
2001 sv = sv_2mortal(newSV(80));
2004 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2005 /* try to reclaim a bit of scalar space (only on 1st alloc) */
2006 const STRLEN new_len
2007 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2008 SvPV_renew(sv, new_len);
2019 SV * const keysv = POPs;
2020 HV * const hv = MUTABLE_HV(POPs);
2021 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2022 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2024 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2025 bool preeminent = TRUE;
2027 if (SvTYPE(hv) != SVt_PVHV)
2034 /* If we can determine whether the element exist,
2035 * Try to preserve the existenceness of a tied hash
2036 * element by using EXISTS and DELETE if possible.
2037 * Fallback to FETCH and STORE otherwise. */
2038 if (SvCANEXISTDELETE(hv))
2039 preeminent = hv_exists_ent(hv, keysv, 0);
2042 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2043 svp = he ? &HeVAL(he) : NULL;
2045 if (!svp || !*svp || *svp == &PL_sv_undef) {
2049 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2051 lv = sv_newmortal();
2052 sv_upgrade(lv, SVt_PVLV);
2054 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2055 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
2056 LvTARG(lv) = SvREFCNT_inc_simple(hv);
2062 if (HvNAME_get(hv) && isGV(*svp))
2063 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2064 else if (preeminent)
2065 save_helem_flags(hv, keysv, svp,
2066 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2068 SAVEHDELETE(hv, keysv);
2070 else if (PL_op->op_private & OPpDEREF) {
2071 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2075 sv = (svp && *svp ? *svp : &PL_sv_undef);
2076 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2077 * was to make C<local $tied{foo} = $tied{foo}> possible.
2078 * However, it seems no longer to be needed for that purpose, and
2079 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2080 * would loop endlessly since the pos magic is getting set on the
2081 * mortal copy and lost. However, the copy has the effect of
2082 * triggering the get magic, and losing it altogether made things like
2083 * c<$tied{foo};> in void context no longer do get magic, which some
2084 * code relied on. Also, delayed triggering of magic on @+ and friends
2085 * meant the original regex may be out of scope by now. So as a
2086 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2087 * being called too many times). */
2088 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2095 /* a stripped-down version of Perl_softref2xv() for use by
2096 * pp_multideref(), which doesn't use PL_op->op_flags */
2099 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2102 if (PL_op->op_private & HINT_STRICT_REFS) {
2104 Perl_die(aTHX_ PL_no_symref_sv, sv,
2105 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2107 Perl_die(aTHX_ PL_no_usym, what);
2110 Perl_die(aTHX_ PL_no_usym, what);
2111 return gv_fetchsv_nomg(sv, GV_ADD, type);
2115 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2116 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
2118 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2119 * Each of these either contains a set of actions, or an argument, such as
2120 * an IV to use as an array index, or a lexical var to retrieve.
2121 * Several actions re stored per UV; we keep shifting new actions off the
2122 * one UV, and only reload when it becomes zero.
2127 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2128 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2129 UV actions = items->uv;
2132 /* this tells find_uninit_var() where we're up to */
2133 PL_multideref_pc = items;
2136 /* there are three main classes of action; the first retrieve
2137 * the initial AV or HV from a variable or the stack; the second
2138 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2139 * the third an unrolled (/DREFHV, rv2hv, helem).
2141 switch (actions & MDEREF_ACTION_MASK) {
2144 actions = (++items)->uv;
2147 case MDEREF_AV_padav_aelem: /* $lex[...] */
2148 sv = PAD_SVl((++items)->pad_offset);
2151 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
2152 sv = UNOP_AUX_item_sv(++items);
2153 assert(isGV_with_GP(sv));
2154 sv = (SV*)GvAVn((GV*)sv);
2157 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
2162 goto do_AV_rv2av_aelem;
2165 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
2166 sv = UNOP_AUX_item_sv(++items);
2167 assert(isGV_with_GP(sv));
2168 sv = GvSVn((GV*)sv);
2169 goto do_AV_vivify_rv2av_aelem;
2171 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
2172 sv = PAD_SVl((++items)->pad_offset);
2175 do_AV_vivify_rv2av_aelem:
2176 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
2177 /* this is the OPpDEREF action normally found at the end of
2178 * ops like aelem, helem, rv2sv */
2179 sv = vivify_ref(sv, OPpDEREF_AV);
2183 /* this is basically a copy of pp_rv2av when it just has the
2186 if (LIKELY(SvROK(sv))) {
2187 if (UNLIKELY(SvAMAGIC(sv))) {
2188 sv = amagic_deref_call(sv, to_av_amg);
2191 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2192 DIE(aTHX_ "Not an ARRAY reference");
2194 else if (SvTYPE(sv) != SVt_PVAV) {
2195 if (!isGV_with_GP(sv))
2196 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2197 sv = MUTABLE_SV(GvAVn((GV*)sv));
2203 /* retrieve the key; this may be either a lexical or package
2204 * var (whose index/ptr is stored as an item) or a signed
2205 * integer constant stored as an item.
2208 IV elem = 0; /* to shut up stupid compiler warnings */
2211 assert(SvTYPE(sv) == SVt_PVAV);
2213 switch (actions & MDEREF_INDEX_MASK) {
2214 case MDEREF_INDEX_none:
2216 case MDEREF_INDEX_const:
2217 elem = (++items)->iv;
2219 case MDEREF_INDEX_padsv:
2220 elemsv = PAD_SVl((++items)->pad_offset);
2222 case MDEREF_INDEX_gvsv:
2223 elemsv = UNOP_AUX_item_sv(++items);
2224 assert(isGV_with_GP(elemsv));
2225 elemsv = GvSVn((GV*)elemsv);
2227 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2228 && ckWARN(WARN_MISC)))
2229 Perl_warner(aTHX_ packWARN(WARN_MISC),
2230 "Use of reference \"%"SVf"\" as array index",
2232 /* the only time that S_find_uninit_var() needs this
2233 * is to determine which index value triggered the
2234 * undef warning. So just update it here. Note that
2235 * since we don't save and restore this var (e.g. for
2236 * tie or overload execution), its value will be
2237 * meaningless apart from just here */
2238 PL_multideref_pc = items;
2239 elem = SvIV(elemsv);
2244 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2246 if (!(actions & MDEREF_FLAG_last)) {
2247 SV** svp = av_fetch((AV*)sv, elem, 1);
2248 if (!svp || ! (sv=*svp))
2249 DIE(aTHX_ PL_no_aelem, elem);
2253 if (PL_op->op_private &
2254 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2256 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2257 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2260 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2261 sv = av_delete((AV*)sv, elem, discard);
2269 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2270 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2271 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2272 bool preeminent = TRUE;
2273 AV *const av = (AV*)sv;
2276 if (UNLIKELY(localizing)) {
2280 /* If we can determine whether the element exist,
2281 * Try to preserve the existenceness of a tied array
2282 * element by using EXISTS and DELETE if possible.
2283 * Fallback to FETCH and STORE otherwise. */
2284 if (SvCANEXISTDELETE(av))
2285 preeminent = av_exists(av, elem);
2288 svp = av_fetch(av, elem, lval && !defer);
2291 if (!svp || !(sv = *svp)) {
2294 DIE(aTHX_ PL_no_aelem, elem);
2295 len = av_tindex(av);
2296 sv = sv_2mortal(newSVavdefelem(av,
2297 /* Resolve a negative index now, unless it points
2298 * before the beginning of the array, in which
2299 * case record it for error reporting in
2300 * magic_setdefelem. */
2301 elem < 0 && len + elem >= 0
2302 ? len + elem : elem, 1));
2305 if (UNLIKELY(localizing)) {
2307 save_aelem(av, elem, svp);
2308 sv = *svp; /* may have changed */
2311 SAVEADELETE(av, elem);
2316 sv = (svp ? *svp : &PL_sv_undef);
2317 /* see note in pp_helem() */
2318 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2335 case MDEREF_HV_padhv_helem: /* $lex{...} */
2336 sv = PAD_SVl((++items)->pad_offset);
2339 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
2340 sv = UNOP_AUX_item_sv(++items);
2341 assert(isGV_with_GP(sv));
2342 sv = (SV*)GvHVn((GV*)sv);
2345 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
2350 goto do_HV_rv2hv_helem;
2353 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
2354 sv = UNOP_AUX_item_sv(++items);
2355 assert(isGV_with_GP(sv));
2356 sv = GvSVn((GV*)sv);
2357 goto do_HV_vivify_rv2hv_helem;
2359 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
2360 sv = PAD_SVl((++items)->pad_offset);
2363 do_HV_vivify_rv2hv_helem:
2364 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
2365 /* this is the OPpDEREF action normally found at the end of
2366 * ops like aelem, helem, rv2sv */
2367 sv = vivify_ref(sv, OPpDEREF_HV);
2371 /* this is basically a copy of pp_rv2hv when it just has the
2372 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2375 if (LIKELY(SvROK(sv))) {
2376 if (UNLIKELY(SvAMAGIC(sv))) {
2377 sv = amagic_deref_call(sv, to_hv_amg);
2380 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2381 DIE(aTHX_ "Not a HASH reference");
2383 else if (SvTYPE(sv) != SVt_PVHV) {
2384 if (!isGV_with_GP(sv))
2385 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2386 sv = MUTABLE_SV(GvHVn((GV*)sv));
2392 /* retrieve the key; this may be either a lexical / package
2393 * var or a string constant, whose index/ptr is stored as an
2396 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2398 assert(SvTYPE(sv) == SVt_PVHV);
2400 switch (actions & MDEREF_INDEX_MASK) {
2401 case MDEREF_INDEX_none:
2404 case MDEREF_INDEX_const:
2405 keysv = UNOP_AUX_item_sv(++items);
2408 case MDEREF_INDEX_padsv:
2409 keysv = PAD_SVl((++items)->pad_offset);
2412 case MDEREF_INDEX_gvsv:
2413 keysv = UNOP_AUX_item_sv(++items);
2414 keysv = GvSVn((GV*)keysv);
2418 /* see comment above about setting this var */
2419 PL_multideref_pc = items;
2422 /* ensure that candidate CONSTs have been HEKified */
2423 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2424 || SvTYPE(keysv) >= SVt_PVMG
2427 || SvIsCOW_shared_hash(keysv));
2429 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2431 if (!(actions & MDEREF_FLAG_last)) {
2432 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2433 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2434 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2438 if (PL_op->op_private &
2439 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2441 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2442 sv = hv_exists_ent((HV*)sv, keysv, 0)
2443 ? &PL_sv_yes : &PL_sv_no;
2446 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2447 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2455 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2456 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2457 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2458 bool preeminent = TRUE;
2460 HV * const hv = (HV*)sv;
2463 if (UNLIKELY(localizing)) {
2467 /* If we can determine whether the element exist,
2468 * Try to preserve the existenceness of a tied hash
2469 * element by using EXISTS and DELETE if possible.
2470 * Fallback to FETCH and STORE otherwise. */
2471 if (SvCANEXISTDELETE(hv))
2472 preeminent = hv_exists_ent(hv, keysv, 0);
2475 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2476 svp = he ? &HeVAL(he) : NULL;
2480 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2484 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2485 lv = sv_newmortal();
2486 sv_upgrade(lv, SVt_PVLV);
2488 sv_magic(lv, key2 = newSVsv(keysv),
2489 PERL_MAGIC_defelem, NULL, 0);
2490 /* sv_magic() increments refcount */
2491 SvREFCNT_dec_NN(key2);
2492 LvTARG(lv) = SvREFCNT_inc_simple(hv);
2498 if (HvNAME_get(hv) && isGV(sv))
2499 save_gp(MUTABLE_GV(sv),
2500 !(PL_op->op_flags & OPf_SPECIAL));
2501 else if (preeminent) {
2502 save_helem_flags(hv, keysv, svp,
2503 (PL_op->op_flags & OPf_SPECIAL)
2504 ? 0 : SAVEf_SETMAGIC);
2505 sv = *svp; /* may have changed */
2508 SAVEHDELETE(hv, keysv);
2513 sv = (svp && *svp ? *svp : &PL_sv_undef);
2514 /* see note in pp_helem() */
2515 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2524 actions >>= MDEREF_SHIFT;
2538 cx = &cxstack[cxstack_ix];
2539 itersvp = CxITERVAR(cx);
2541 switch (CxTYPE(cx)) {
2543 case CXt_LOOP_LAZYSV: /* string increment */
2545 SV* cur = cx->blk_loop.state_u.lazysv.cur;
2546 SV *end = cx->blk_loop.state_u.lazysv.end;
2547 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2548 It has SvPVX of "" and SvCUR of 0, which is what we want. */
2550 const char *max = SvPV_const(end, maxlen);
2551 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2555 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2556 /* safe to reuse old SV */
2557 sv_setsv(oldsv, cur);
2561 /* we need a fresh SV every time so that loop body sees a
2562 * completely new SV for closures/references to work as
2564 *itersvp = newSVsv(cur);
2565 SvREFCNT_dec_NN(oldsv);
2567 if (strEQ(SvPVX_const(cur), max))
2568 sv_setiv(cur, 0); /* terminate next time */
2574 case CXt_LOOP_LAZYIV: /* integer increment */
2576 IV cur = cx->blk_loop.state_u.lazyiv.cur;
2577 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2581 /* don't risk potential race */
2582 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2583 /* safe to reuse old SV */
2584 sv_setiv(oldsv, cur);
2588 /* we need a fresh SV every time so that loop body sees a
2589 * completely new SV for closures/references to work as they
2591 *itersvp = newSViv(cur);
2592 SvREFCNT_dec_NN(oldsv);
2595 if (UNLIKELY(cur == IV_MAX)) {
2596 /* Handle end of range at IV_MAX */
2597 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2599 ++cx->blk_loop.state_u.lazyiv.cur;
2603 case CXt_LOOP_FOR: /* iterate array */
2606 AV *av = cx->blk_loop.state_u.ary.ary;
2608 bool av_is_stack = FALSE;
2615 if (PL_op->op_private & OPpITER_REVERSED) {
2616 ix = --cx->blk_loop.state_u.ary.ix;
2617 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
2621 ix = ++cx->blk_loop.state_u.ary.ix;
2622 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
2626 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
2627 SV * const * const svp = av_fetch(av, ix, FALSE);
2628 sv = svp ? *svp : NULL;
2631 sv = AvARRAY(av)[ix];
2634 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2635 SvSetMagicSV(*itersvp, sv);
2640 if (UNLIKELY(SvIS_FREED(sv))) {
2642 Perl_croak(aTHX_ "Use of freed value in iteration");
2649 SvREFCNT_inc_simple_void_NN(sv);
2652 else if (!av_is_stack) {
2653 sv = newSVavdefelem(av, ix, 0);
2660 SvREFCNT_dec(oldsv);
2665 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2671 A description of how taint works in pattern matching and substitution.
2673 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2674 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2676 While the pattern is being assembled/concatenated and then compiled,
2677 PL_tainted will get set (via TAINT_set) if any component of the pattern
2678 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2679 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2680 TAINT_get). It will also be set if any component of the pattern matches
2681 based on locale-dependent behavior.
2683 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2684 the pattern is marked as tainted. This means that subsequent usage, such
2685 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2686 on the new pattern too.
2688 RXf_TAINTED_SEEN is used post-execution by the get magic code
2689 of $1 et al to indicate whether the returned value should be tainted.
2690 It is the responsibility of the caller of the pattern (i.e. pp_match,
2691 pp_subst etc) to set this flag for any other circumstances where $1 needs
2694 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2696 There are three possible sources of taint
2698 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2699 * the replacement string (or expression under /e)
2701 There are four destinations of taint and they are affected by the sources
2702 according to the rules below:
2704 * the return value (not including /r):
2705 tainted by the source string and pattern, but only for the
2706 number-of-iterations case; boolean returns aren't tainted;
2707 * the modified string (or modified copy under /r):
2708 tainted by the source string, pattern, and replacement strings;
2710 tainted by the pattern, and under 'use re "taint"', by the source
2712 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2713 should always be unset before executing subsequent code.
2715 The overall action of pp_subst is:
2717 * at the start, set bits in rxtainted indicating the taint status of
2718 the various sources.
2720 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2721 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2722 pattern has subsequently become tainted via locale ops.
2724 * If control is being passed to pp_substcont to execute a /e block,
2725 save rxtainted in the CXt_SUBST block, for future use by
2728 * Whenever control is being returned to perl code (either by falling
2729 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2730 use the flag bits in rxtainted to make all the appropriate types of
2731 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2732 et al will appear tainted.
2734 pp_match is just a simpler version of the above.
2750 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2751 See "how taint works" above */
2754 REGEXP *rx = PM_GETRE(pm);
2756 int force_on_match = 0;
2757 const I32 oldsave = PL_savestack_ix;
2759 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2764 /* known replacement string? */
2765 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2769 if (PL_op->op_flags & OPf_STACKED)
2778 SvGETMAGIC(TARG); /* must come before cow check */
2780 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2781 because they make integers such as 256 "false". */
2782 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2785 sv_force_normal_flags(TARG,0);
2787 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2788 && (SvREADONLY(TARG)
2789 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2790 || SvTYPE(TARG) > SVt_PVLV)
2791 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2792 Perl_croak_no_modify();
2795 orig = SvPV_nomg(TARG, len);
2796 /* note we don't (yet) force the var into being a string; if we fail
2797 * to match, we leave as-is; on successful match howeverm, we *will*
2798 * coerce into a string, then repeat the match */
2799 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2802 /* only replace once? */
2803 once = !(rpm->op_pmflags & PMf_GLOBAL);
2805 /* See "how taint works" above */
2808 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2809 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2810 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2811 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2812 ? SUBST_TAINT_BOOLRET : 0));
2818 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2820 strend = orig + len;
2821 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2822 maxiters = 2 * slen + 10; /* We can match twice at each
2823 position, once with zero-length,
2824 second time with non-zero. */
2826 if (!RX_PRELEN(rx) && PL_curpm
2827 && !ReANY(rx)->mother_re) {
2832 #ifdef PERL_SAWAMPERSAND
2833 r_flags = ( RX_NPARENS(rx)
2835 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2836 || (rpm->op_pmflags & PMf_KEEPCOPY)
2841 r_flags = REXEC_COPY_STR;
2844 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2847 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2848 LEAVE_SCOPE(oldsave);
2853 /* known replacement string? */
2855 /* replacement needing upgrading? */
2856 if (DO_UTF8(TARG) && !doutf8) {
2857 nsv = sv_newmortal();
2860 sv_recode_to_utf8(nsv, _get_encoding());
2862 sv_utf8_upgrade(nsv);
2863 c = SvPV_const(nsv, clen);
2867 c = SvPV_const(dstr, clen);
2868 doutf8 = DO_UTF8(dstr);
2871 if (SvTAINTED(dstr))
2872 rxtainted |= SUBST_TAINT_REPL;
2879 /* can do inplace substitution? */
2884 && (I32)clen <= RX_MINLENRET(rx)
2886 || !(r_flags & REXEC_COPY_STR)
2887 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2889 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2890 && (!doutf8 || SvUTF8(TARG))
2891 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2895 if (SvIsCOW(TARG)) {
2896 if (!force_on_match)
2898 assert(SvVOK(TARG));
2901 if (force_on_match) {
2902 /* redo the first match, this time with the orig var
2903 * forced into being a string */
2905 orig = SvPV_force_nomg(TARG, len);
2911 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2912 rxtainted |= SUBST_TAINT_PAT;
2913 m = orig + RX_OFFS(rx)[0].start;
2914 d = orig + RX_OFFS(rx)[0].end;
2916 if (m - s > strend - d) { /* faster to shorten from end */
2919 Copy(c, m, clen, char);
2924 Move(d, m, i, char);
2928 SvCUR_set(TARG, m - s);
2930 else { /* faster from front */
2934 Move(s, d - i, i, char);
2937 Copy(c, d, clen, char);
2944 d = s = RX_OFFS(rx)[0].start + orig;
2947 if (UNLIKELY(iters++ > maxiters))
2948 DIE(aTHX_ "Substitution loop");
2949 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2950 rxtainted |= SUBST_TAINT_PAT;
2951 m = RX_OFFS(rx)[0].start + orig;
2954 Move(s, d, i, char);
2958 Copy(c, d, clen, char);
2961 s = RX_OFFS(rx)[0].end + orig;
2962 } while (CALLREGEXEC(rx, s, strend, orig,
2963 s == m, /* don't match same null twice */
2965 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2968 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2969 Move(s, d, i+1, char); /* include the NUL */
2979 if (force_on_match) {
2980 /* redo the first match, this time with the orig var
2981 * forced into being a string */
2983 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2984 /* I feel that it should be possible to avoid this mortal copy
2985 given that the code below copies into a new destination.
2986 However, I suspect it isn't worth the complexity of
2987 unravelling the C<goto force_it> for the small number of
2988 cases where it would be viable to drop into the copy code. */
2989 TARG = sv_2mortal(newSVsv(TARG));
2991 orig = SvPV_force_nomg(TARG, len);
2997 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2998 rxtainted |= SUBST_TAINT_PAT;
3000 s = RX_OFFS(rx)[0].start + orig;
3001 dstr = newSVpvn_flags(orig, s-orig,
3002 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3007 /* note that a whole bunch of local vars are saved here for
3008 * use by pp_substcont: here's a list of them in case you're
3009 * searching for places in this sub that uses a particular var:
3010 * iters maxiters r_flags oldsave rxtainted orig dstr targ
3011 * s m strend rx once */
3013 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3017 if (UNLIKELY(iters++ > maxiters))
3018 DIE(aTHX_ "Substitution loop");
3019 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
3020 rxtainted |= SUBST_TAINT_PAT;
3021 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
3023 char *old_orig = orig;
3024 assert(RX_SUBOFFSET(rx) == 0);
3026 orig = RX_SUBBEG(rx);
3027 s = orig + (old_s - old_orig);
3028 strend = s + (strend - old_s);
3030 m = RX_OFFS(rx)[0].start + orig;
3031 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3032 s = RX_OFFS(rx)[0].end + orig;
3034 /* replacement already stringified */
3036 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3041 if (!nsv) nsv = sv_newmortal();
3042 sv_copypv(nsv, repl);
3043 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
3044 sv_catsv(dstr, nsv);
3046 else sv_catsv(dstr, repl);
3047 if (UNLIKELY(SvTAINTED(repl)))
3048 rxtainted |= SUBST_TAINT_REPL;
3052 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
3054 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3055 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3057 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3058 /* From here on down we're using the copy, and leaving the original
3065 /* The match may make the string COW. If so, brilliant, because
3066 that's just saved us one malloc, copy and free - the regexp has
3067 donated the old buffer, and we malloc an entirely new one, rather
3068 than the regexp malloc()ing a buffer and copying our original,
3069 only for us to throw it away here during the substitution. */
3070 if (SvIsCOW(TARG)) {
3071 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3077 SvPV_set(TARG, SvPVX(dstr));
3078 SvCUR_set(TARG, SvCUR(dstr));
3079 SvLEN_set(TARG, SvLEN(dstr));
3080 SvFLAGS(TARG) |= SvUTF8(dstr);
3081 SvPV_set(dstr, NULL);
3088 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3089 (void)SvPOK_only_UTF8(TARG);
3092 /* See "how taint works" above */
3094 if ((rxtainted & SUBST_TAINT_PAT) ||
3095 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3096 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3098 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
3100 if (!(rxtainted & SUBST_TAINT_BOOLRET)
3101 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3103 SvTAINTED_on(TOPs); /* taint return value */
3105 SvTAINTED_off(TOPs); /* may have got tainted earlier */
3107 /* needed for mg_set below */
3109 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3113 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3115 LEAVE_SCOPE(oldsave);
3124 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3125 ++*PL_markstack_ptr;
3127 LEAVE_with_name("grep_item"); /* exit inner scope */
3130 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3132 const I32 gimme = GIMME_V;
3134 LEAVE_with_name("grep"); /* exit outer scope */
3135 (void)POPMARK; /* pop src */
3136 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3137 (void)POPMARK; /* pop dst */
3138 SP = PL_stack_base + POPMARK; /* pop original mark */
3139 if (gimme == G_SCALAR) {
3140 if (PL_op->op_private & OPpGREP_LEX) {
3141 SV* const sv = sv_newmortal();
3142 sv_setiv(sv, items);
3150 else if (gimme == G_ARRAY)
3157 ENTER_with_name("grep_item"); /* enter inner scope */
3160 src = PL_stack_base[*PL_markstack_ptr];
3161 if (SvPADTMP(src)) {
3162 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
3166 if (PL_op->op_private & OPpGREP_LEX)
3167 PAD_SVl(PL_op->op_targ) = src;
3171 RETURNOP(cLOGOP->op_other);
3185 if (CxMULTICALL(&cxstack[cxstack_ix])) {
3186 /* entry zero of a stack is always PL_sv_undef, which
3187 * simplifies converting a '()' return into undef in scalar context */
3188 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
3193 cxstack_ix++; /* temporarily protect top context */
3196 if (gimme == G_SCALAR) {
3198 if (LIKELY(MARK <= SP)) {
3199 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
3200 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3201 && !SvMAGICAL(TOPs)) {
3202 *MARK = SvREFCNT_inc(TOPs);
3207 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
3209 *MARK = sv_mortalcopy(sv);
3210 SvREFCNT_dec_NN(sv);
3213 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3214 && !SvMAGICAL(TOPs)) {
3218 *MARK = sv_mortalcopy(TOPs);
3222 *MARK = &PL_sv_undef;
3226 else if (gimme == G_ARRAY) {
3227 for (MARK = newsp + 1; MARK <= SP; MARK++) {
3228 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
3229 || SvMAGICAL(*MARK)) {
3230 *MARK = sv_mortalcopy(*MARK);
3231 TAINT_NOT; /* Each item is independent */
3238 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3240 PL_curpm = newpm; /* ... and pop $1 et al */
3243 return cx->blk_sub.retop;
3253 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
3256 DIE(aTHX_ "Not a CODE reference");
3257 /* This is overwhelmingly the most common case: */
3258 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
3259 switch (SvTYPE(sv)) {
3262 if (!(cv = GvCVu((const GV *)sv))) {
3264 cv = sv_2cv(sv, &stash, &gv, 0);
3273 if(isGV_with_GP(sv)) goto we_have_a_glob;
3276 if (sv == &PL_sv_yes) { /* unfound import, ignore */
3278 SP = PL_stack_base + POPMARK;
3286 sv = amagic_deref_call(sv, to_cv_amg);
3287 /* Don't SPAGAIN here. */
3294 DIE(aTHX_ PL_no_usym, "a subroutine");
3295 sym = SvPV_nomg_const(sv, len);
3296 if (PL_op->op_private & HINT_STRICT_REFS)
3297 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3298 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3301 cv = MUTABLE_CV(SvRV(sv));
3302 if (SvTYPE(cv) == SVt_PVCV)
3307 DIE(aTHX_ "Not a CODE reference");
3308 /* This is the second most common case: */
3310 cv = MUTABLE_CV(sv);
3318 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
3319 DIE(aTHX_ "Closure prototype called");
3320 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
3324 /* anonymous or undef'd function leaves us no recourse */
3325 if (CvLEXICAL(cv) && CvHASGV(cv))
3326 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
3327 SVfARG(cv_name(cv, NULL, 0)));
3328 if (CvANON(cv) || !CvHASGV(cv)) {
3329 DIE(aTHX_ "Undefined subroutine called");
3332 /* autoloaded stub? */
3333 if (cv != GvCV(gv = CvGV(cv))) {
3336 /* should call AUTOLOAD now? */
3339 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3340 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
3346 sub_name = sv_newmortal();
3347 gv_efullname3(sub_name, gv, NULL);
3348 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
3356 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3359 Perl_get_db_sub(aTHX_ &sv, cv);
3361 PL_curcopdb = PL_curcop;
3363 /* check for lsub that handles lvalue subroutines */
3364 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
3365 /* if lsub not found then fall back to DB::sub */
3366 if (!cv) cv = GvCV(PL_DBsub);
3368 cv = GvCV(PL_DBsub);
3371 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3372 DIE(aTHX_ "No DB::sub routine defined");
3377 if (!(CvISXSUB(cv))) {
3378 /* This path taken at least 75% of the time */
3380 PADLIST * const padlist = CvPADLIST(cv);
3383 PUSHBLOCK(cx, CXt_SUB, MARK);
3385 cx->blk_sub.retop = PL_op->op_next;
3386 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3387 PERL_STACK_OVERFLOW_CHECK();
3388 pad_push(padlist, depth);
3391 PAD_SET_CUR_NOSAVE(padlist, depth);
3392 if (LIKELY(hasargs)) {
3393 AV *const av = MUTABLE_AV(PAD_SVl(0));
3397 if (UNLIKELY(AvREAL(av))) {
3398 /* @_ is normally not REAL--this should only ever
3399 * happen when DB::sub() calls things that modify @_ */
3404 defavp = &GvAV(PL_defgv);
3405 cx->blk_sub.savearray = *defavp;
3406 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
3407 CX_CURPAD_SAVE(cx->blk_sub);
3408 cx->blk_sub.argarray = av;
3411 if (UNLIKELY(items - 1 > AvMAX(av))) {
3412 SV **ary = AvALLOC(av);
3413 AvMAX(av) = items - 1;
3414 Renew(ary, items, SV*);
3419 Copy(MARK+1,AvARRAY(av),items,SV*);
3420 AvFILLp(av) = items - 1;
3426 if (SvPADTMP(*MARK)) {
3427 *MARK = sv_mortalcopy(*MARK);
3435 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3437 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3438 /* warning must come *after* we fully set up the context
3439 * stuff so that __WARN__ handlers can safely dounwind()
3442 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
3443 && ckWARN(WARN_RECURSION)
3444 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
3445 sub_crush_depth(cv);
3446 RETURNOP(CvSTART(cv));
3449 SSize_t markix = TOPMARK;
3454 if (UNLIKELY(((PL_op->op_private
3455 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3456 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3458 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3460 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3461 /* Need to copy @_ to stack. Alternative may be to
3462 * switch stack to @_, and copy return values
3463 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3464 AV * const av = GvAV(PL_defgv);
3465 const SSize_t items = AvFILL(av) + 1;
3469 const bool m = cBOOL(SvRMAGICAL(av));
3470 /* Mark is at the end of the stack. */
3472 for (; i < items; ++i)
3476 SV ** const svp = av_fetch(av, i, 0);
3477 sv = svp ? *svp : NULL;
3479 else sv = AvARRAY(av)[i];
3480 if (sv) SP[i+1] = sv;
3482 SP[i+1] = newSVavdefelem(av, i, 1);
3490 SV **mark = PL_stack_base + markix;
3491 SSize_t items = SP - mark;
3494 if (*mark && SvPADTMP(*mark)) {
3495 *mark = sv_mortalcopy(*mark);
3499 /* We assume first XSUB in &DB::sub is the called one. */
3500 if (UNLIKELY(PL_curcopdb)) {
3501 SAVEVPTR(PL_curcop);
3502 PL_curcop = PL_curcopdb;
3505 /* Do we need to open block here? XXXX */
3507 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3509 CvXSUB(cv)(aTHX_ cv);
3511 /* Enforce some sanity in scalar context. */
3512 if (gimme == G_SCALAR) {
3513 SV **svp = PL_stack_base + markix + 1;
3514 if (svp != PL_stack_sp) {
3515 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3525 Perl_sub_crush_depth(pTHX_ CV *cv)
3527 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3530 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3532 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3533 SVfARG(cv_name(cv,NULL,0)));
3541 SV* const elemsv = POPs;
3542 IV elem = SvIV(elemsv);
3543 AV *const av = MUTABLE_AV(POPs);
3544 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3545 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3546 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3547 bool preeminent = TRUE;
3550 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
3551 Perl_warner(aTHX_ packWARN(WARN_MISC),
3552 "Use of reference \"%"SVf"\" as array index",
3554 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
3557 if (UNLIKELY(localizing)) {
3561 /* If we can determine whether the element exist,
3562 * Try to preserve the existenceness of a tied array
3563 * element by using EXISTS and DELETE if possible.
3564 * Fallback to FETCH and STORE otherwise. */
3565 if (SvCANEXISTDELETE(av))
3566 preeminent = av_exists(av, elem);
3569 svp = av_fetch(av, elem, lval && !defer);
3571 #ifdef PERL_MALLOC_WRAP
3572 if (SvUOK(elemsv)) {
3573 const UV uv = SvUV(elemsv);
3574 elem = uv > IV_MAX ? IV_MAX : uv;
3576 else if (SvNOK(elemsv))
3577 elem = (IV)SvNV(elemsv);
3579 static const char oom_array_extend[] =
3580 "Out of memory during array extend"; /* Duplicated in av.c */
3581 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3584 if (!svp || !*svp) {
3587 DIE(aTHX_ PL_no_aelem, elem);
3588 len = av_tindex(av);
3589 mPUSHs(newSVavdefelem(av,
3590 /* Resolve a negative index now, unless it points before the
3591 beginning of the array, in which case record it for error
3592 reporting in magic_setdefelem. */
3593 elem < 0 && len + elem >= 0 ? len + elem : elem,
3597 if (UNLIKELY(localizing)) {
3599 save_aelem(av, elem, svp);
3601 SAVEADELETE(av, elem);
3603 else if (PL_op->op_private & OPpDEREF) {
3604 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3608 sv = (svp ? *svp : &PL_sv_undef);
3609 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3616 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3618 PERL_ARGS_ASSERT_VIVIFY_REF;
3623 Perl_croak_no_modify();
3624 prepare_SV_for_RV(sv);
3627 SvRV_set(sv, newSV(0));
3630 SvRV_set(sv, MUTABLE_SV(newAV()));
3633 SvRV_set(sv, MUTABLE_SV(newHV()));
3640 if (SvGMAGICAL(sv)) {
3641 /* copy the sv without magic to prevent magic from being
3643 SV* msv = sv_newmortal();
3644 sv_setsv_nomg(msv, sv);
3650 PERL_STATIC_INLINE HV *
3651 S_opmethod_stash(pTHX_ SV* meth)
3656 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
3657 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3658 "package or object reference", SVfARG(meth)),
3660 : *(PL_stack_base + TOPMARK + 1);
3662 PERL_ARGS_ASSERT_OPMETHOD_STASH;
3666 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3669 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3670 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3671 stash = gv_stashsv(sv, GV_CACHE_ONLY);
3672 if (stash) return stash;
3676 ob = MUTABLE_SV(SvRV(sv));
3677 else if (!SvOK(sv)) goto undefined;
3678 else if (isGV_with_GP(sv)) {
3680 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3681 "without a package or object reference",
3684 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3685 assert(!LvTARGLEN(ob));
3689 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3692 /* this isn't a reference */
3695 const char * const packname = SvPV_nomg_const(sv, packlen);
3696 const U32 packname_utf8 = SvUTF8(sv);
3697 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3698 if (stash) return stash;
3700 if (!(iogv = gv_fetchpvn_flags(
3701 packname, packlen, packname_utf8, SVt_PVIO
3703 !(ob=MUTABLE_SV(GvIO(iogv))))
3705 /* this isn't the name of a filehandle either */
3708 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3709 "without a package or object reference",
3712 /* assume it's a package name */
3713 stash = gv_stashpvn(packname, packlen, packname_utf8);
3714 if (stash) return stash;
3715 else return MUTABLE_HV(sv);
3717 /* it _is_ a filehandle name -- replace with a reference */
3718 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3721 /* if we got here, ob should be an object or a glob */
3722 if (!ob || !(SvOBJECT(ob)
3723 || (isGV_with_GP(ob)
3724 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3727 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3728 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3729 ? newSVpvs_flags("DOES", SVs_TEMP)
3741 SV* const meth = TOPs;
3744 SV* const rmeth = SvRV(meth);
3745 if (SvTYPE(rmeth) == SVt_PVCV) {
3751 stash = opmethod_stash(meth);
3753 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3756 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3760 #define METHOD_CHECK_CACHE(stash,cache,meth) \
3761 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
3763 gv = MUTABLE_GV(HeVAL(he)); \
3764 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
3765 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
3767 XPUSHs(MUTABLE_SV(GvCV(gv))); \
3776 SV* const meth = cMETHOPx_meth(PL_op);
3777 HV* const stash = opmethod_stash(meth);
3779 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
3780 METHOD_CHECK_CACHE(stash, stash, meth);
3783 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3786 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3795 SV* const meth = cMETHOPx_meth(PL_op);
3796 HV* const stash = CopSTASH(PL_curcop);
3797 /* Actually, SUPER doesn't need real object's (or class') stash at all,
3798 * as it uses CopSTASH. However, we must ensure that object(class) is
3799 * correct (this check is done by S_opmethod_stash) */
3800 opmethod_stash(meth);
3802 if ((cache = HvMROMETA(stash)->super)) {
3803 METHOD_CHECK_CACHE(stash, cache, meth);
3806 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3809 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3817 SV* const meth = cMETHOPx_meth(PL_op);
3818 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3819 opmethod_stash(meth); /* not used but needed for error checks */
3821 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3822 else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3824 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3827 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3831 PP(pp_method_redir_super)
3836 SV* const meth = cMETHOPx_meth(PL_op);
3837 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3838 opmethod_stash(meth); /* not used but needed for error checks */
3840 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3841 else if ((cache = HvMROMETA(stash)->super)) {
3842 METHOD_CHECK_CACHE(stash, cache, meth);
3845 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3848 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3853 * ex: set ts=8 sts=4 sw=4 et: