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 + CX_CUR()->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) { /* {or,and,dor}assign */
134 SV * const temp = left;
135 left = right; right = temp;
137 assert(TAINTING_get || !TAINT_get);
138 if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
140 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
142 SV * const cv = SvRV(right);
143 const U32 cv_type = SvTYPE(cv);
144 const bool is_gv = isGV_with_GP(left);
145 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
151 /* Can do the optimisation if left (LVALUE) is not a typeglob,
152 right (RVALUE) is a reference to something, and we're in void
154 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
155 /* Is the target symbol table currently empty? */
156 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
157 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
158 /* Good. Create a new proxy constant subroutine in the target.
159 The gv becomes a(nother) reference to the constant. */
160 SV *const value = SvRV(cv);
162 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
163 SvPCS_IMPORTED_on(gv);
165 SvREFCNT_inc_simple_void(value);
171 /* Need to fix things up. */
173 /* Need to fix GV. */
174 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
178 /* We've been returned a constant rather than a full subroutine,
179 but they expect a subroutine reference to apply. */
181 ENTER_with_name("sassign_coderef");
182 SvREFCNT_inc_void(SvRV(cv));
183 /* newCONSTSUB takes a reference count on the passed in SV
184 from us. We set the name to NULL, otherwise we get into
185 all sorts of fun as the reference to our new sub is
186 donated to the GV that we're about to assign to.
188 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
191 LEAVE_with_name("sassign_coderef");
193 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
195 First: ops for \&{"BONK"}; return us the constant in the
197 Second: ops for *{"BONK"} cause that symbol table entry
198 (and our reference to it) to be upgraded from RV
200 Thirdly: We get here. cv is actually PVGV now, and its
201 GvCV() is actually the subroutine we're looking for
203 So change the reference so that it points to the subroutine
204 of that typeglob, as that's what they were after all along.
206 GV *const upgraded = MUTABLE_GV(cv);
207 CV *const source = GvCV(upgraded);
210 assert(CvFLAGS(source) & CVf_CONST);
212 SvREFCNT_inc_simple_void_NN(source);
213 SvREFCNT_dec_NN(upgraded);
214 SvRV_set(right, MUTABLE_SV(source));
220 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
221 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
224 packWARN(WARN_MISC), "Useless assignment to a temporary"
226 SvSetMagicSV(left, right);
238 RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
245 TAINT_NOT; /* Each statement is presumed innocent */
247 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
249 if (!(PL_op->op_flags & OPf_SPECIAL)) {
250 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
257 /* The main body of pp_concat, not including the magic/overload and
259 * It does targ = left . right.
260 * Moved into a separate function so that pp_multiconcat() can use it
264 PERL_STATIC_INLINE void
265 S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy)
269 const char *rpv = NULL;
271 bool rcopied = FALSE;
273 if (TARG == right && right != left) { /* $r = $l.$r */
274 rpv = SvPV_nomg_const(right, rlen);
275 rbyte = !DO_UTF8(right);
276 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
277 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
281 if (TARG != left) { /* not $l .= $r */
283 const char* const lpv = SvPV_nomg_const(left, llen);
284 lbyte = !DO_UTF8(left);
285 sv_setpvn(TARG, lpv, llen);
291 else { /* $l .= $r and left == TARG */
293 if ((left == right /* $l .= $l */
294 || targmy) /* $l = $l . $r */
295 && ckWARN(WARN_UNINITIALIZED)
301 SvPV_force_nomg_nolen(left);
303 lbyte = !DO_UTF8(left);
309 rpv = SvPV_nomg_const(right, rlen);
310 rbyte = !DO_UTF8(right);
312 if (lbyte != rbyte) {
314 sv_utf8_upgrade_nomg(TARG);
317 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
318 sv_utf8_upgrade_nomg(right);
319 rpv = SvPV_nomg_const(right, rlen);
322 sv_catpvn_nomg(TARG, rpv, rlen);
329 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
332 S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY);
341 Concatenate one or more args, possibly interleaved with constant string
342 segments. The result may be assigned to, or appended to, a variable or
345 Several op_flags and/or op_private bits indicate what the target is, and
346 whether it's appended to. Valid permutations are:
348 - (PADTMP) = (A.B.C....)
349 OPpTARGET_MY $lex = (A.B.C....)
350 OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....)
351 OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....)
352 OPf_STACKED expr = (A.B.C....)
353 OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....)
355 Other combinations like (A.B).(C.D) are not optimised into a multiconcat
356 op, as it's too hard to get the correct ordering of ties, overload etc.
360 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised
361 sprintf "...%s...". Don't call '.'
362 overloading: only use '""' overloading.
364 OPpMULTICONCAT_STRINGIFY: the RHS was of the form
365 "...$a...$b..." rather than
366 "..." . $a . "..." . $b . "..."
368 An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
369 defined with PERL_MULTICONCAT_IX_FOO constants, where:
372 FOO index description
373 -------- ----- ----------------------------------
374 NARGS 0 number of arguments
375 PLAIN_PV 1 non-utf8 constant string
376 PLAIN_LEN 2 non-utf8 constant string length
377 UTF8_PV 3 utf8 constant string
378 UTF8_LEN 4 utf8 constant string length
379 LENGTHS 5 first of nargs+1 const segment lengths
381 The idea is that a general string concatenation will have a fixed (known
382 at compile time) number of variable args, interspersed with constant
383 strings, e.g. "a=$a b=$b\n"
385 All the constant string segments "a=", " b=" and "\n" are stored as a
386 single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
387 with a series of segment lengths: e.g. 2,3,1. In the case where the
388 constant string is plain but has a different utf8 representation, both
389 variants are stored, and two sets of (nargs+1) segments lengths are stored
390 in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
392 A segment length of -1 indicates that there is no constant string at that
393 point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
394 have differing overloading behaviour.
401 SV *targ; /* The SV to be assigned or appended to */
402 char *targ_pv; /* where within SvPVX(targ) we're writing to */
403 STRLEN targ_len; /* SvCUR(targ) */
404 SV **toparg; /* the highest arg position on the stack */
405 UNOP_AUX_item *aux; /* PL_op->op_aux buffer */
406 UNOP_AUX_item *const_lens; /* the segment length array part of aux */
407 const char *const_pv; /* the current segment of the const string buf */
408 SSize_t nargs; /* how many args were expected */
409 SSize_t stack_adj; /* how much to adjust SP on return */
410 STRLEN grow; /* final size of destination string (targ) */
411 UV targ_count; /* how many times targ has appeared on the RHS */
412 bool is_append; /* OPpMULTICONCAT_APPEND flag is set */
413 bool slow_concat; /* args too complex for quick concat */
414 U32 dst_utf8; /* the result will be utf8 (indicate this with
415 SVf_UTF8 in a U32, rather than using bool,
416 for ease of testing and setting) */
417 /* for each arg, holds the result of an SvPV() call */
418 struct multiconcat_svpv {
422 *targ_chain, /* chain of slots where targ has appeared on RHS */
423 *svpv_p, /* ptr for looping through svpv_buf */
424 *svpv_base, /* first slot (may be greater than svpv_buf), */
425 *svpv_end, /* and slot after highest result so far, of: */
426 svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
428 aux = cUNOP_AUXx(PL_op)->op_aux;
429 stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
430 is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
432 /* get targ from the stack or pad */
434 if (PL_op->op_flags & OPf_STACKED) {
436 /* for 'expr .= ...', expr is the bottom item on the stack */
441 /* for 'expr = ...', expr is the top item on the stack */
445 SV **svp = &(PAD_SVl(PL_op->op_targ));
447 if (PL_op->op_private & OPpLVAL_INTRO) {
448 assert(PL_op->op_private & OPpTARGET_MY);
452 /* $lex .= "const" doesn't cause anything to be pushed */
458 grow = 1; /* allow for '\0' at minimum */
463 /* only utf8 variants of the const strings? */
464 dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
467 /* --------------------------------------------------------------
470 * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
471 * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
473 * utf8 is indicated by storing a negative length.
475 * Where an arg is actually targ, the stringification is deferred:
476 * the length is set to 0, and the slot is added to targ_chain.
478 * If a magic, overloaded, or otherwise weird arg is found, which
479 * might have side effects when stringified, the loop is abandoned and
480 * we goto a code block where a more basic 'emulate calling
481 * pp_cpncat() on each arg in turn' is done.
484 for (; SP <= toparg; SP++, svpv_end++) {
489 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
493 /* this if/else chain is arranged so that common/simple cases
494 * take few conditionals */
496 if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) {
497 /* common case: sv is a simple non-magical PV */
499 /* targ appears on RHS.
500 * Delay storing PV pointer; instead, add slot to targ_chain
501 * so it can be populated later, after targ has been grown and
502 * we know its final SvPVX() address.
505 svpv_end->len = 0; /* zerojng here means we can skip
506 updating later if targ_len == 0 */
507 svpv_end->pv = (char*)targ_chain;
508 targ_chain = svpv_end;
514 svpv_end->pv = SvPVX(sv);
516 else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK)))
517 /* may have side effects: tie, overload etc.
518 * Abandon 'stringify everything first' and handle
519 * args in strict order. Note that already-stringified args
520 * will be reprocessed, which is safe because the each first
521 * stringification would have been idempotent.
524 else if (SvNIOK(sv)) {
527 /* stringify general valid scalar */
528 svpv_end->pv = sv_2pv_flags(sv, &len, 0);
530 else if (!SvOK(sv)) {
531 if (ckWARN(WARN_UNINITIALIZED))
532 /* an undef value in the presence of warnings may trigger
535 svpv_end->pv = (char*)"";
539 goto do_magical; /* something weird */
541 utf8 = (SvFLAGS(sv) & SVf_UTF8);
543 ASSUME(len < SSize_t_MAX);
544 svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
548 /* --------------------------------------------------------------
553 * if targ appears on the RHS or is appended to, force stringify it;
554 * otherwise set it to "". Then set targ_len.
558 /* abandon quick route if using targ might have side effects */
559 if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK)))
565 SvPV_force_nomg_nolen(targ);
566 targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
567 if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
568 if (LIKELY(!IN_BYTES))
569 sv_utf8_upgrade_nomg(targ);
572 dst_utf8 |= targ_utf8;
574 targ_len = SvCUR(targ);
575 grow += targ_len * (targ_count + is_append);
578 else if (ckWARN(WARN_UNINITIALIZED))
579 /* warning might have side effects */
581 /* the undef targ will be silently SvPVCLEAR()ed below */
583 else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
584 /* Assigning to some weird LHS type. Don't force the LHS to be an
585 * empty string; instead, do things 'long hand' by using the
586 * overload code path, which concats to a TEMP sv and does
587 * sv_catsv() calls rather than COPY()s. This ensures that even
588 * bizarre code like this doesn't break or crash:
590 * (which makes the 'F' typeglob an alias to the
591 * '*main::F*main::F' typeglob).
596 /* targ was found on RHS.
597 * Force stringify it, using the same code as the append branch
598 * above, except that we don't need the magic/overload/undef
599 * checks as these will already have been done in the phase 1
604 /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
605 * those will be done later. */
606 SV_CHECK_THINKFIRST_COW_DROP(targ);
607 SvUPGRADE(targ, SVt_PV);
608 SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
609 SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
613 /* --------------------------------------------------------------
616 * UTF-8 tweaks and grow targ:
618 * Now that we know the length and utf8-ness of both the targ and
619 * args, grow targ to the size needed to accumulate all the args, based
620 * on whether targ appears on the RHS, whether we're appending, and
621 * whether any non-utf8 args expand in size if converted to utf8.
623 * For the latter, if dst_utf8 we scan non-utf8 args looking for
624 * variant chars, and adjust the svpv->len value of those args to the
625 * utf8 size and negate it to flag them. At the same time we un-negate
626 * the lens of any utf8 args since after this phase we no longer care
627 * whether an arg is utf8 or not.
629 * Finally, initialise const_lens and const_pv based on utf8ness.
630 * Note that there are 3 permutations:
632 * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
633 * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
634 * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
637 * * If the string is fully utf8, e.g. "\x{100}", then
638 * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
639 * one set of segment lengths.
641 * * If the string has different plain and utf8 representations
642 * (e.g. "\x80"), then then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
643 * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
644 * holds the utf8 rep, and there are 2 sets of segment lengths,
645 * with the utf8 set following after the plain set.
647 * On entry to this section the (pv,len) pairs in svpv_buf have the
648 * following meanings:
649 * (pv, len) a plain string
650 * (pv, -len) a utf8 string
651 * (NULL, 0) left-most targ \ linked together R-to-L
652 * (next, 0) other targ / in targ_chain
655 /* turn off utf8 handling if 'use bytes' is in scope */
656 if (UNLIKELY(dst_utf8 && IN_BYTES)) {
659 /* undo all the negative lengths which flag utf8-ness */
660 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
661 SSize_t len = svpv_p->len;
667 /* grow += total of lengths of constant string segments */
670 len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
671 : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
672 slow_concat = cBOOL(len);
676 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
679 const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
680 if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
681 && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
682 /* separate sets of lengths for plain and utf8 */
683 const_lens += nargs + 1;
685 /* If the result is utf8 but some of the args aren't,
686 * calculate how much extra growth is needed for all the chars
687 * which will expand to two utf8 bytes.
688 * Also, if the growth is non-zero, negate the length to indicate
689 * that this this is a variant string. Conversely, un-negate the
690 * length on utf8 args (which was only needed to flag non-utf8
691 * args in this loop */
692 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
701 extra = variant_under_utf8_count((U8 *) svpv_p->pv,
702 (U8 *) svpv_p->pv + len);
703 if (UNLIKELY(extra)) {
705 /* -ve len indicates special handling */
706 svpv_p->len = -(len + extra);
712 const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
714 /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
715 * already have been dropped */
716 assert(!SvIsCOW(targ));
717 targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ));
720 /* --------------------------------------------------------------
723 * Now that targ has been grown, we know the final address of the targ
724 * PVX, if needed. Preserve / move targ contents if appending or if
725 * targ appears on RHS.
727 * Also update svpv_buf slots in targ_chain.
729 * Don't bother with any of this if the target length is zero:
730 * targ_len is set to zero unless we're appending or targ appears on
731 * RHS. And even if it is, we can optimise by skipping this chunk of
732 * code for zero targ_len. In the latter case, we don't need to update
733 * the slots in targ_chain with the (zero length) target string, since
734 * we set the len in such slots to 0 earlier, and since the Copy() is
735 * skipped on zero length, it doesn't matter what svpv_p->pv contains.
737 * On entry to this section the (pv,len) pairs in svpv_buf have the
738 * following meanings:
739 * (pv, len) a pure-plain or utf8 string
740 * (pv, -(len+extra)) a plain string which will expand by 'extra'
741 * bytes when converted to utf8
742 * (NULL, 0) left-most targ \ linked together R-to-L
743 * (next, 0) other targ / in targ_chain
745 * On exit, the targ contents will have been moved to the
746 * earliest place they are needed (e.g. $x = "abc$x" will shift them
747 * 3 bytes, while $x .= ... will leave them at the beginning);
748 * and dst_pv will point to the location within SvPVX(targ) where the
749 * next arg should be copied.
752 svpv_base = svpv_buf;
755 struct multiconcat_svpv *tc_stop;
756 char *targ_buf = targ_pv; /* ptr to original targ string */
758 assert(is_append || targ_count);
765 /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
766 * Move the current contents of targ to the first
767 * position where it's needed, and use that as the src buffer
768 * for any further uses (such as the second RHS $t above).
769 * In calculating the first position, we need to sum the
770 * lengths of all consts and args before that.
773 UNOP_AUX_item *lens = const_lens;
774 /* length of first const string segment */
775 STRLEN offset = lens->ssize > 0 ? lens->ssize : 0;
783 break; /* the first targ argument */
784 /* add lengths of the next arg and const string segment */
786 if (len < 0) /* variant args have this */
788 offset += (STRLEN)len;
789 len = (++lens)->ssize;
790 offset += (len >= 0) ? (STRLEN)len : 0;
792 /* all args and consts so far are empty; update
793 * the start position for the concat later */
798 assert(svpv_p < svpv_end);
803 Move(targ_pv, targ_buf, targ_len, char);
804 /* a negative length implies don't Copy(), but do increment */
805 svpv_p->len = -((SSize_t)targ_len);
809 /* skip the first targ copy */
815 /* Don't populate the first targ slot in the loop below; it's
816 * either not used because we advanced svpv_base beyond it, or
817 * we already stored the special -targ_len value in it
822 /* populate slots in svpv_buf representing targ on RHS */
823 while (targ_chain != tc_stop) {
824 struct multiconcat_svpv *p = targ_chain;
825 targ_chain = (struct multiconcat_svpv *)(p->pv);
827 p->len = (SSize_t)targ_len;
832 /* --------------------------------------------------------------
835 * Append all the args in svpv_buf, plus the const strings, to targ.
837 * On entry to this section the (pv,len) pairs in svpv_buf have the
838 * following meanings:
839 * (pv, len) a pure-plain or utf8 string (which may be targ)
840 * (pv, -(len+extra)) a plain string which will expand by 'extra'
841 * bytes when converted to utf8
842 * (0, -len) left-most targ, whose content has already
843 * been copied. Just advance targ_pv by len.
846 /* If there are no constant strings and no special case args
847 * (svpv_p->len < 0), use a simpler, more efficient concat loop
850 for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
851 SSize_t len = svpv_p->len;
854 Copy(svpv_p->pv, targ_pv, len, char);
857 const_lens += (svpv_end - svpv_base + 1);
860 /* Note that we iterate the loop nargs+1 times: to append nargs
861 * arguments and nargs+1 constant strings. For example, "-$a-$b-"
863 svpv_p = svpv_base - 1;
866 SSize_t len = (const_lens++)->ssize;
868 /* append next const string segment */
870 Copy(const_pv, targ_pv, len, char);
875 if (++svpv_p == svpv_end)
878 /* append next arg */
881 if (LIKELY(len > 0)) {
882 Copy(svpv_p->pv, targ_pv, len, char);
885 else if (UNLIKELY(len < 0)) {
886 /* negative length indicates two special cases */
887 const char *p = svpv_p->pv;
890 /* copy plain-but-variant pv to a utf8 targ */
891 char * end_pv = targ_pv + len;
893 while (targ_pv < end_pv) {
895 append_utf8_from_native_byte(c, (U8**)&targ_pv);
899 /* arg is already-copied targ */
907 SvCUR_set(targ, targ_pv - SvPVX(targ));
908 assert(grow >= SvCUR(targ) + 1);
909 assert(SvLEN(targ) >= SvCUR(targ) + 1);
911 /* --------------------------------------------------------------
922 /* --------------------------------------------------------------
925 * We only get here if any of the args (or targ too in the case of
926 * append) have something which might cause side effects, such
927 * as magic, overload, or an undef value in the presence of warnings.
928 * In that case, any earlier attempt to stringify the args will have
929 * been abandoned, and we come here instead.
931 * Here, we concat each arg in turn the old-fashioned way: essentially
932 * emulating pp_concat() in a loop. This means that all the weird edge
933 * cases will be handled correctly, if not necessarily speedily.
935 * Note that some args may already have been stringified - those are
936 * processed again, which is safe, since only args without side-effects
937 * were stringified earlier.
949 const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
950 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
951 Size_t arg_count = 0; /* how many args have been processed */
954 cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
958 svp = toparg - nargs + 1;
962 * plus possible nargs+1 consts,
963 * plus, if appending, a final targ in an extra last iteration
967 for (i = 0; i <= n; i++) {
970 /* if necessary, stringify the final RHS result in
971 * something like $targ .= "$a$b$c" - simulating
975 && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY)
977 /* extra conditions for backwards compatibility:
978 * probably incorrect, but keep the existing behaviour
979 * for now. The rules are:
980 * $x = "$ov" single arg: stringify;
981 * $x = "$ov$y" multiple args: don't stringify,
982 * $lex = "$ov$y$z" except TARGMY with at least 2 concats
987 && (PL_op->op_private & OPpTARGET_MY)
988 && !(PL_op->op_private & OPpLVAL_INTRO)
993 SV *tmp = sv_newmortal();
994 sv_copypv(tmp, left);
999 /* do one extra iteration to handle $targ in $targ .= ... */
1000 if (i == n && !is_append)
1003 /* get the next arg SV or regen the next const SV */
1004 len = lens[i >> 1].ssize;
1006 /* handle the final targ .= (....) */
1011 right = svp[(i >> 1)];
1013 continue; /* no const in this position */
1015 right = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP));
1021 if (arg_count <= 1) {
1023 continue; /* need at least two SVs to concat together */
1026 if (arg_count == 2 && i < n) {
1027 /* for the first concat, create a mortal acting like the
1028 * padtmp from OP_CONST. In later iterations this will
1030 nexttarg = sv_newmortal();
1038 /* Handle possible overloading.
1039 * This is basically an unrolled
1040 * tryAMAGICbin_MG(concat_amg, AMGf_assign);
1042 * Perl_try_amagic_bin()
1043 * call, but using left and right rather than SP[-1], SP[0],
1044 * and not relying on OPf_STACKED implying .=
1047 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
1052 if ((SvAMAGIC(left) || SvAMAGIC(right))
1053 /* sprintf doesn't do concat overloading,
1054 * but allow for $x .= sprintf(...)
1056 && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
1060 SV * const tmpsv = amagic_call(left, right, concat_amg,
1061 (nextappend ? AMGf_assign: 0));
1063 /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
1064 * here, which isn't needed as any implicit
1065 * assign done under OPpTARGET_MY is done after
1068 sv_setsv(left, tmpsv);
1077 /* if both args are the same magical value, make one a copy */
1078 if (left == right && SvGMAGICAL(left)) {
1079 left = sv_newmortal();
1080 /* Print the uninitialized warning now, so it includes the
1083 if (ckWARN(WARN_UNINITIALIZED))
1084 report_uninit(right);
1085 sv_setsv_flags(left, &PL_sv_no, 0);
1088 sv_setsv_flags(left, right, 0);
1093 /* nexttarg = left . right */
1094 S_do_concat(aTHX_ left, right, nexttarg, 0);
1098 SP = toparg - stack_adj + 1;
1100 /* Return the result of all RHS concats, unless this op includes
1101 * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
1102 * to target (which will be $lex or expr).
1103 * If we are appending, targ will already have been appended to in
1106 && ( (PL_op->op_flags & OPf_STACKED)
1107 || (PL_op->op_private & OPpTARGET_MY))
1109 sv_setsv(targ, left);
1120 /* push the elements of av onto the stack.
1121 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
1124 S_pushav(pTHX_ AV* const av)
1127 const SSize_t maxarg = AvFILL(av) + 1;
1129 if (UNLIKELY(SvRMAGICAL(av))) {
1131 for (i=0; i < (PADOFFSET)maxarg; i++) {
1132 SV ** const svp = av_fetch(av, i, FALSE);
1133 SP[i+1] = LIKELY(svp)
1135 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1142 for (i=0; i < (PADOFFSET)maxarg; i++) {
1143 SV *sv = AvARRAY(av)[i];
1144 SP[i+1] = LIKELY(sv)
1146 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1157 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
1162 PADOFFSET base = PL_op->op_targ;
1163 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
1164 if (PL_op->op_flags & OPf_SPECIAL) {
1165 /* fake the RHS of my ($x,$y,..) = @_ */
1167 (void)S_pushav(aTHX_ GvAVn(PL_defgv));
1171 /* note, this is only skipped for compile-time-known void cxt */
1172 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
1177 for (i = 0; i <count; i++)
1178 *++SP = PAD_SV(base+i);
1180 if (PL_op->op_private & OPpLVAL_INTRO) {
1181 SV **svp = &(PAD_SVl(base));
1182 const UV payload = (UV)(
1183 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1184 | (count << SAVE_TIGHT_SHIFT)
1185 | SAVEt_CLEARPADRANGE);
1188 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
1189 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1197 for (i = 0; i <count; i++)
1198 SvPADSTALE_off(*svp++); /* mark lexical as active */
1209 OP * const op = PL_op;
1210 /* access PL_curpad once */
1211 SV ** const padentry = &(PAD_SVl(op->op_targ));
1216 PUTBACK; /* no pop/push after this, TOPs ok */
1218 if (op->op_flags & OPf_MOD) {
1219 if (op->op_private & OPpLVAL_INTRO)
1220 if (!(op->op_private & OPpPAD_STATE))
1221 save_clearsv(padentry);
1222 if (op->op_private & OPpDEREF) {
1223 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
1224 than TARG reduces the scope of TARG, so it does not
1225 span the call to save_clearsv, resulting in smaller
1227 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
1237 /* pp_coreargs pushes a NULL to indicate no args passed to
1238 * CORE::readline() */
1241 tryAMAGICunTARGETlist(iter_amg, 0);
1242 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1244 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
1245 if (!isGV_with_GP(PL_last_in_gv)) {
1246 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
1247 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
1250 XPUSHs(MUTABLE_SV(PL_last_in_gv));
1252 Perl_pp_rv2gv(aTHX);
1253 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1254 assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
1257 return do_readline();
1265 tryAMAGICbin_MG(eq_amg, AMGf_numeric);
1269 (SvIOK_notUV(left) && SvIOK_notUV(right))
1270 ? (SvIVX(left) == SvIVX(right))
1271 : ( do_ncmp(left, right) == 0)
1277 /* also used for: pp_i_preinc() */
1281 SV *sv = *PL_stack_sp;
1283 if (LIKELY(((sv->sv_flags &
1284 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1285 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1287 && SvIVX(sv) != IV_MAX)
1289 SvIV_set(sv, SvIVX(sv) + 1);
1291 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1298 /* also used for: pp_i_predec() */
1302 SV *sv = *PL_stack_sp;
1304 if (LIKELY(((sv->sv_flags &
1305 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1306 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1308 && SvIVX(sv) != IV_MIN)
1310 SvIV_set(sv, SvIVX(sv) - 1);
1312 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
1319 /* also used for: pp_orassign() */
1330 if (PL_op->op_type == OP_OR)
1332 RETURNOP(cLOGOP->op_other);
1337 /* also used for: pp_dor() pp_dorassign() */
1344 const int op_type = PL_op->op_type;
1345 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
1350 if (UNLIKELY(!sv || !SvANY(sv))) {
1351 if (op_type == OP_DOR)
1353 RETURNOP(cLOGOP->op_other);
1359 if (UNLIKELY(!sv || !SvANY(sv)))
1364 switch (SvTYPE(sv)) {
1366 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1370 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1374 if (CvROOT(sv) || CvXSUB(sv))
1387 if(op_type == OP_DOR)
1389 RETURNOP(cLOGOP->op_other);
1391 /* assuming OP_DEFINED */
1401 dSP; dATARGET; bool useleft; SV *svl, *svr;
1403 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1407 #ifdef PERL_PRESERVE_IVUV
1409 /* special-case some simple common cases */
1410 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1412 U32 flags = (svl->sv_flags & svr->sv_flags);
1413 if (flags & SVf_IOK) {
1414 /* both args are simple IVs */
1419 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1420 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1422 /* if both are in a range that can't under/overflow, do a
1423 * simple integer add: if the top of both numbers
1424 * are 00 or 11, then it's safe */
1425 if (!( ((topl+1) | (topr+1)) & 2)) {
1427 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1433 else if (flags & SVf_NOK) {
1434 /* both args are NVs */
1439 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1440 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1441 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1443 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1446 /* nothing was lost by converting to IVs */
1449 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1457 useleft = USE_LEFT(svl);
1458 /* We must see if we can perform the addition with integers if possible,
1459 as the integer code detects overflow while the NV code doesn't.
1460 If either argument hasn't had a numeric conversion yet attempt to get
1461 the IV. It's important to do this now, rather than just assuming that
1462 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1463 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1464 integer in case the second argument is IV=9223372036854775806
1465 We can (now) rely on sv_2iv to do the right thing, only setting the
1466 public IOK flag if the value in the NV (or PV) slot is truly integer.
1468 A side effect is that this also aggressively prefers integer maths over
1469 fp maths for integer values.
1471 How to detect overflow?
1473 C 99 section 6.2.6.1 says
1475 The range of nonnegative values of a signed integer type is a subrange
1476 of the corresponding unsigned integer type, and the representation of
1477 the same value in each type is the same. A computation involving
1478 unsigned operands can never overflow, because a result that cannot be
1479 represented by the resulting unsigned integer type is reduced modulo
1480 the number that is one greater than the largest value that can be
1481 represented by the resulting type.
1485 which I read as "unsigned ints wrap."
1487 signed integer overflow seems to be classed as "exception condition"
1489 If an exceptional condition occurs during the evaluation of an
1490 expression (that is, if the result is not mathematically defined or not
1491 in the range of representable values for its type), the behavior is
1494 (6.5, the 5th paragraph)
1496 I had assumed that on 2s complement machines signed arithmetic would
1497 wrap, hence coded pp_add and pp_subtract on the assumption that
1498 everything perl builds on would be happy. After much wailing and
1499 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1500 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1501 unsigned code below is actually shorter than the old code. :-)
1504 if (SvIV_please_nomg(svr)) {
1505 /* Unless the left argument is integer in range we are going to have to
1506 use NV maths. Hence only attempt to coerce the right argument if
1507 we know the left is integer. */
1514 a_valid = auvok = 1;
1515 /* left operand is undef, treat as zero. + 0 is identity,
1516 Could SETi or SETu right now, but space optimise by not adding
1517 lots of code to speed up what is probably a rarish case. */
1519 /* Left operand is defined, so is it IV? */
1520 if (SvIV_please_nomg(svl)) {
1521 if ((auvok = SvUOK(svl)))
1524 const IV aiv = SvIVX(svl);
1527 auvok = 1; /* Now acting as a sign flag. */
1529 /* Using 0- here and later to silence bogus warning
1531 auv = (UV) (0 - (UV) aiv);
1538 bool result_good = 0;
1541 bool buvok = SvUOK(svr);
1546 const IV biv = SvIVX(svr);
1551 buv = (UV) (0 - (UV) biv);
1553 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1554 else "IV" now, independent of how it came in.
1555 if a, b represents positive, A, B negative, a maps to -A etc
1560 all UV maths. negate result if A negative.
1561 add if signs same, subtract if signs differ. */
1563 if (auvok ^ buvok) {
1567 /* Must get smaller */
1572 if (result <= buv) {
1573 /* result really should be -(auv-buv). as its negation
1574 of true value, need to swap our result flag */
1591 if (result <= (UV)IV_MIN)
1592 SETi(result == (UV)IV_MIN
1593 ? IV_MIN : -(IV)result);
1595 /* result valid, but out of range for IV. */
1596 SETn( -(NV)result );
1600 } /* Overflow, drop through to NVs. */
1605 useleft = USE_LEFT(svl);
1609 NV value = SvNV_nomg(svr);
1612 /* left operand is undef, treat as zero. + 0.0 is identity. */
1616 SETn( value + SvNV_nomg(svl) );
1622 /* also used for: pp_aelemfast_lex() */
1627 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
1628 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
1629 const U32 lval = PL_op->op_flags & OPf_MOD;
1630 const I8 key = (I8)PL_op->op_private;
1634 assert(SvTYPE(av) == SVt_PVAV);
1638 /* inlined av_fetch() for simple cases ... */
1639 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1640 sv = AvARRAY(av)[key];
1647 /* ... else do it the hard way */
1648 svp = av_fetch(av, key, lval);
1649 sv = (svp ? *svp : &PL_sv_undef);
1651 if (UNLIKELY(!svp && lval))
1652 DIE(aTHX_ PL_no_aelem, (int)key);
1654 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
1662 dSP; dMARK; dTARGET;
1664 do_join(TARG, *MARK, MARK, SP);
1670 /* Oversized hot code. */
1672 /* also used for: pp_say() */
1676 dSP; dMARK; dORIGMARK;
1680 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1684 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1687 if (MARK == ORIGMARK) {
1688 /* If using default handle then we need to make space to
1689 * pass object as 1st arg, so move other args up ...
1693 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1696 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
1698 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1699 | (PL_op->op_type == OP_SAY
1700 ? TIED_METHOD_SAY : 0)), sp - mark);
1703 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
1704 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1707 SETERRNO(EBADF,RMS_IFI);
1710 else if (!(fp = IoOFP(io))) {
1712 report_wrongway_fh(gv, '<');
1715 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1719 SV * const ofs = GvSV(PL_ofsgv); /* $, */
1721 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
1722 while (MARK <= SP) {
1723 if (!do_print(*MARK, fp))
1727 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1728 if (!do_print(GvSV(PL_ofsgv), fp)) {
1736 while (MARK <= SP) {
1737 if (!do_print(*MARK, fp))
1745 if (PL_op->op_type == OP_SAY) {
1746 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1749 else if (PL_ors_sv && SvOK(PL_ors_sv))
1750 if (!do_print(PL_ors_sv, fp)) /* $\ */
1753 if (IoFLAGS(io) & IOf_FLUSH)
1754 if (PerlIO_flush(fp) == EOF)
1764 XPUSHs(&PL_sv_undef);
1769 /* do the common parts of pp_padhv() and pp_rv2hv()
1770 * It assumes the caller has done EXTEND(SP, 1) or equivalent.
1771 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
1772 * 'has_targ' indicates that the op has a target - this should
1773 * be a compile-time constant so that the code can constant-folded as
1777 PERL_STATIC_INLINE OP*
1778 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
1787 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1789 if (gimme == G_ARRAY) {
1795 /* 'keys %h' masquerading as '%h': reset iterator */
1796 (void)hv_iterinit(hv);
1798 if (gimme == G_VOID)
1801 is_bool = ( PL_op->op_private & OPpTRUEBOOL
1802 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
1803 && block_gimme() == G_VOID));
1804 is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
1806 if (UNLIKELY(is_tied)) {
1807 if (is_keys && !is_bool) {
1809 while (hv_iternext(hv))
1814 sv = magic_scalarpack(hv, mg);
1821 sv = i ? &PL_sv_yes : &PL_sv_zero;
1833 /* parent op should be an unused OP_KEYS whose targ we can
1838 assert(!OpHAS_SIBLING(PL_op));
1839 k = PL_op->op_sibparent;
1840 assert(k->op_type == OP_KEYS);
1841 TARG = PAD_SV(k->op_targ);
1854 /* This is also called directly by pp_lvavref. */
1859 assert(SvTYPE(TARG) == SVt_PVAV);
1860 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1861 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1862 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1865 if (PL_op->op_flags & OPf_REF) {
1869 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1870 const I32 flags = is_lvalue_sub();
1871 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1872 if (GIMME_V == G_SCALAR)
1873 /* diag_listed_as: Can't return %s to lvalue scalar context */
1874 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1881 if (gimme == G_ARRAY)
1882 return S_pushav(aTHX_ (AV*)TARG);
1884 if (gimme == G_SCALAR) {
1885 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1888 else if (PL_op->op_private & OPpTRUEBOOL)
1902 assert(SvTYPE(TARG) == SVt_PVHV);
1903 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1904 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1905 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1909 if (PL_op->op_flags & OPf_REF) {
1913 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1914 const I32 flags = is_lvalue_sub();
1915 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1916 if (GIMME_V == G_SCALAR)
1917 /* diag_listed_as: Can't return %s to lvalue scalar context */
1918 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
1926 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
1927 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1932 /* also used for: pp_rv2hv() */
1933 /* also called directly by pp_lvavref */
1938 const U8 gimme = GIMME_V;
1939 static const char an_array[] = "an ARRAY";
1940 static const char a_hash[] = "a HASH";
1941 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1942 || PL_op->op_type == OP_LVAVREF;
1943 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
1947 if (UNLIKELY(SvAMAGIC(sv))) {
1948 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
1951 if (UNLIKELY(SvTYPE(sv) != type))
1952 /* diag_listed_as: Not an ARRAY reference */
1953 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
1954 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1955 && PL_op->op_private & OPpLVAL_INTRO))
1956 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
1958 else if (UNLIKELY(SvTYPE(sv) != type)) {
1961 if (!isGV_with_GP(sv)) {
1962 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
1968 gv = MUTABLE_GV(sv);
1970 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
1971 if (PL_op->op_private & OPpLVAL_INTRO)
1972 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
1974 if (PL_op->op_flags & OPf_REF) {
1978 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
1979 const I32 flags = is_lvalue_sub();
1980 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1981 if (gimme != G_ARRAY)
1982 goto croak_cant_return;
1989 AV *const av = MUTABLE_AV(sv);
1991 if (gimme == G_ARRAY) {
1994 return S_pushav(aTHX_ av);
1997 if (gimme == G_SCALAR) {
1998 const SSize_t maxarg = AvFILL(av) + 1;
1999 if (PL_op->op_private & OPpTRUEBOOL)
2000 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
2009 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
2010 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2016 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2017 is_pp_rv2av ? "array" : "hash");
2022 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
2024 PERL_ARGS_ASSERT_DO_ODDBALL;
2027 if (ckWARN(WARN_MISC)) {
2029 if (oddkey == firstkey &&
2031 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2032 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
2034 err = "Reference found where even-sized list expected";
2037 err = "Odd number of elements in hash assignment";
2038 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
2045 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2046 * are common to both the LHS and RHS of an aassign, and replace them
2047 * with copies. All these copies are made before the actual list assign is
2050 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2051 * element ($b) to the first LH element ($a), modifies $a; when the
2052 * second assignment is done, the second RH element now has the wrong
2053 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2054 * Note that we don't need to make a mortal copy of $b.
2056 * The algorithm below works by, for every RHS element, mark the
2057 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2058 * element is found with SVf_BREAK set, it means it would have been
2059 * modified, so make a copy.
2060 * Note that by scanning both LHS and RHS in lockstep, we avoid
2061 * unnecessary copies (like $b above) compared with a naive
2062 * "mark all LHS; copy all marked RHS; unmark all LHS".
2064 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2065 * it can't be common and can be skipped.
2067 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2068 * that we thought we didn't need to call S_aassign_copy_common(), but we
2069 * have anyway for sanity checking. If we find we need to copy, then panic.
2072 PERL_STATIC_INLINE void
2073 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
2074 SV **firstrelem, SV **lastrelem
2083 SSize_t lcount = lastlelem - firstlelem + 1;
2084 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2085 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
2086 bool copy_all = FALSE;
2088 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2089 assert(firstlelem < lastlelem); /* at least 2 LH elements */
2090 assert(firstrelem < lastrelem); /* at least 2 RH elements */
2094 /* we never have to copy the first RH element; it can't be corrupted
2095 * by assigning something to the corresponding first LH element.
2096 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2098 relem = firstrelem + 1;
2100 for (; relem <= lastrelem; relem++) {
2103 /* mark next LH element */
2105 if (--lcount >= 0) {
2108 if (UNLIKELY(!svl)) {/* skip AV alias marker */
2109 assert (lelem <= lastlelem);
2115 if (SvSMAGICAL(svl)) {
2118 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2121 /* this LH element will consume all further args;
2122 * no need to mark any further LH elements (if any).
2123 * But we still need to scan any remaining RHS elements;
2124 * set lcount negative to distinguish from lcount == 0,
2125 * so the loop condition continues being true
2128 lelem--; /* no need to unmark this element */
2130 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
2131 SvFLAGS(svl) |= SVf_BREAK;
2135 /* don't check RH element if no SVf_BREAK flags set yet */
2142 /* see if corresponding RH element needs copying */
2148 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
2149 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
2153 /* op_dump(PL_op); */
2155 "panic: aassign skipped needed copy of common RH elem %"
2156 UVuf, (UV)(relem - firstrelem));
2160 TAINT_NOT; /* Each item is independent */
2162 /* Dear TODO test in t/op/sort.t, I love you.
2163 (It's relying on a panic, not a "semi-panic" from newSVsv()
2164 and then an assertion failure below.) */
2165 if (UNLIKELY(SvIS_FREED(svr))) {
2166 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2169 /* avoid break flag while copying; otherwise COW etc
2171 SvFLAGS(svr) &= ~SVf_BREAK;
2172 /* Not newSVsv(), as it does not allow copy-on-write,
2173 resulting in wasteful copies.
2174 Also, we use SV_NOSTEAL in case the SV is used more than
2175 once, e.g. (...) = (f())[0,0]
2176 Where the same SV appears twice on the RHS without a ref
2177 count bump. (Although I suspect that the SV won't be
2178 stealable here anyway - DAPM).
2180 *relem = sv_mortalcopy_flags(svr,
2181 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2182 /* ... but restore afterwards in case it's needed again,
2183 * e.g. ($a,$b,$c) = (1,$a,$a)
2185 SvFLAGS(svr) |= brk;
2197 while (lelem > firstlelem) {
2198 SV * const svl = *(--lelem);
2200 SvFLAGS(svl) &= ~SVf_BREAK;
2209 SV **lastlelem = PL_stack_sp;
2210 SV **lastrelem = PL_stack_base + POPMARK;
2211 SV **firstrelem = PL_stack_base + POPMARK + 1;
2212 SV **firstlelem = lastrelem + 1;
2217 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
2218 * only need to save locally, not on the save stack */
2219 U16 old_delaymagic = PL_delaymagic;
2224 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
2226 /* If there's a common identifier on both sides we have to take
2227 * special care that assigning the identifier on the left doesn't
2228 * clobber a value on the right that's used later in the list.
2231 /* at least 2 LH and RH elements, or commonality isn't an issue */
2232 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2233 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2234 if (SvGMAGICAL(*relem))
2237 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2238 if (*lelem && SvSMAGICAL(*lelem))
2241 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2242 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2243 /* skip the scan if all scalars have a ref count of 1 */
2244 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2246 if (!sv || SvREFCNT(sv) == 1)
2248 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2255 S_aassign_copy_common(aTHX_
2256 firstlelem, lastlelem, firstrelem, lastrelem
2266 /* on debugging builds, do the scan even if we've concluded we
2267 * don't need to, then panic if we find commonality. Note that the
2268 * scanner assumes at least 2 elements */
2269 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2280 if (relem > lastrelem)
2283 /* first lelem loop while there are still relems */
2284 while (LIKELY(lelem <= lastlelem)) {
2288 TAINT_NOT; /* Each item stands on its own, taintwise. */
2290 assert(relem <= lastrelem);
2291 if (UNLIKELY(!lsv)) {
2294 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2297 switch (SvTYPE(lsv)) {
2302 SSize_t nelems = lastrelem - relem + 1;
2303 AV *ary = MUTABLE_AV(lsv);
2305 /* Assigning to an aggregate is tricky. First there is the
2306 * issue of commonality, e.g. @a = ($a[0]). Since the
2307 * stack isn't refcounted, clearing @a prior to storing
2308 * elements will free $a[0]. Similarly with
2309 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2311 * The way to avoid these issues is to make the copy of each
2312 * SV (and we normally store a *copy* in the array) *before*
2313 * clearing the array. But this has a problem in that
2314 * if the code croaks during copying, the not-yet-stored copies
2315 * could leak. One way to avoid this is to make all the copies
2316 * mortal, but that's quite expensive.
2318 * The current solution to these issues is to use a chunk
2319 * of the tmps stack as a temporary refcounted-stack. SVs
2320 * will be put on there during processing to avoid leaks,
2321 * but will be removed again before the end of this block,
2322 * so free_tmps() is never normally called. Also, the
2323 * sv_refcnt of the SVs doesn't have to be manipulated, since
2324 * the ownership of 1 reference count is transferred directly
2325 * from the tmps stack to the AV when the SV is stored.
2327 * We disarm slots in the temps stack by storing PL_sv_undef
2328 * there: it doesn't matter if that SV's refcount is
2329 * repeatedly decremented during a croak. But usually this is
2330 * only an interim measure. By the end of this code block
2331 * we try where possible to not leave any PL_sv_undef's on the
2332 * tmps stack e.g. by shuffling newer entries down.
2334 * There is one case where we don't copy: non-magical
2335 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2336 * is on the tmps stack, so its safe to directly steal the SV
2337 * rather than copying. This is common in things like function
2338 * returns, map etc, which all return a list of such SVs.
2340 * Note however something like @a = (f())[0,0], where there is
2341 * a danger of the same SV being shared: this avoided because
2342 * when the SV is stored as $a[0], its ref count gets bumped,
2343 * so the RC==1 test fails and the second element is copied
2346 * We also use one slot in the tmps stack to hold an extra
2347 * ref to the array, to ensure it doesn't get prematurely
2348 * freed. Again, this is removed before the end of this block.
2350 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2351 * @a = ($a[0]) case, but the current implementation uses the
2352 * same algorithm regardless, so ignores that flag. (It *is*
2353 * used in the hash branch below, however).
2356 /* Reserve slots for ary, plus the elems we're about to copy,
2357 * then protect ary and temporarily void the remaining slots
2358 * with &PL_sv_undef */
2359 EXTEND_MORTAL(nelems + 1);
2360 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2361 tmps_base = PL_tmps_ix + 1;
2362 for (i = 0; i < nelems; i++)
2363 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2364 PL_tmps_ix += nelems;
2366 /* Make a copy of each RHS elem and save on the tmps_stack
2367 * (or pass through where we can optimise away the copy) */
2369 if (UNLIKELY(alias)) {
2370 U32 lval = (gimme == G_ARRAY)
2371 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
2372 for (svp = relem; svp <= lastrelem; svp++) {
2377 DIE(aTHX_ "Assigned value is not a reference");
2378 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2379 /* diag_listed_as: Assigned value is not %s reference */
2381 "Assigned value is not a SCALAR reference");
2383 *svp = rsv = sv_mortalcopy(rsv);
2384 /* XXX else check for weak refs? */
2385 rsv = SvREFCNT_inc_NN(SvRV(rsv));
2386 assert(tmps_base <= PL_tmps_max);
2387 PL_tmps_stack[tmps_base++] = rsv;
2391 for (svp = relem; svp <= lastrelem; svp++) {
2394 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2395 /* can skip the copy */
2396 SvREFCNT_inc_simple_void_NN(rsv);
2401 /* do get before newSV, in case it dies and leaks */
2404 /* see comment in S_aassign_copy_common about
2406 sv_setsv_flags(nsv, rsv,
2407 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2411 assert(tmps_base <= PL_tmps_max);
2412 PL_tmps_stack[tmps_base++] = rsv;
2416 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2419 /* store in the array, the SVs that are in the tmps stack */
2421 tmps_base -= nelems;
2423 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
2424 /* for arrays we can't cheat with, use the official API */
2425 av_extend(ary, nelems - 1);
2426 for (i = 0; i < nelems; i++) {
2427 SV **svp = &(PL_tmps_stack[tmps_base + i]);
2429 /* A tied store won't take ownership of rsv, so keep
2430 * the 1 refcnt on the tmps stack; otherwise disarm
2431 * the tmps stack entry */
2432 if (av_store(ary, i, rsv))
2433 *svp = &PL_sv_undef;
2434 /* av_store() may have added set magic to rsv */;
2437 /* disarm ary refcount: see comments below about leak */
2438 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2441 /* directly access/set the guts of the AV */
2442 SSize_t fill = nelems - 1;
2443 if (fill > AvMAX(ary))
2444 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2446 AvFILLp(ary) = fill;
2447 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2448 /* Quietly remove all the SVs from the tmps stack slots,
2449 * since ary has now taken ownership of the refcnt.
2450 * Also remove ary: which will now leak if we die before
2451 * the SvREFCNT_dec_NN(ary) below */
2452 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2453 Move(&PL_tmps_stack[tmps_base + nelems],
2454 &PL_tmps_stack[tmps_base - 1],
2455 PL_tmps_ix - (tmps_base + nelems) + 1,
2457 PL_tmps_ix -= (nelems + 1);
2460 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2461 /* its assumed @ISA set magic can't die and leak ary */
2462 SvSETMAGIC(MUTABLE_SV(ary));
2463 SvREFCNT_dec_NN(ary);
2465 relem = lastrelem + 1;
2469 case SVt_PVHV: { /* normal hash */
2475 SSize_t nelems = lastrelem - relem + 1;
2476 HV *hash = MUTABLE_HV(lsv);
2478 if (UNLIKELY(nelems & 1)) {
2479 do_oddball(lastrelem, relem);
2480 /* we have firstlelem to reuse, it's not needed any more */
2481 *++lastrelem = &PL_sv_undef;
2485 /* See the SVt_PVAV branch above for a long description of
2486 * how the following all works. The main difference for hashes
2487 * is that we treat keys and values separately (and have
2488 * separate loops for them): as for arrays, values are always
2489 * copied (except for the SvTEMP optimisation), since they
2490 * need to be stored in the hash; while keys are only
2491 * processed where they might get prematurely freed or
2494 /* tmps stack slots:
2495 * * reserve a slot for the hash keepalive;
2496 * * reserve slots for the hash values we're about to copy;
2497 * * preallocate for the keys we'll possibly copy or refcount bump
2499 * then protect hash and temporarily void the remaining
2500 * value slots with &PL_sv_undef */
2501 EXTEND_MORTAL(nelems + 1);
2503 /* convert to number of key/value pairs */
2506 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2507 tmps_base = PL_tmps_ix + 1;
2508 for (i = 0; i < nelems; i++)
2509 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2510 PL_tmps_ix += nelems;
2512 /* Make a copy of each RHS hash value and save on the tmps_stack
2513 * (or pass through where we can optimise away the copy) */
2515 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2518 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2519 /* can skip the copy */
2520 SvREFCNT_inc_simple_void_NN(rsv);
2525 /* do get before newSV, in case it dies and leaks */
2528 /* see comment in S_aassign_copy_common about
2530 sv_setsv_flags(nsv, rsv,
2531 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2535 assert(tmps_base <= PL_tmps_max);
2536 PL_tmps_stack[tmps_base++] = rsv;
2538 tmps_base -= nelems;
2541 /* possibly protect keys */
2543 if (UNLIKELY(gimme == G_ARRAY)) {
2545 * @a = ((%h = ($$r, 1)), $r = "x");
2546 * $_++ for %h = (1,2,3,4);
2548 EXTEND_MORTAL(nelems);
2549 for (svp = relem; svp <= lastrelem; svp += 2)
2550 *svp = sv_mortalcopy_flags(*svp,
2551 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2553 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2554 /* for possible commonality, e.g.
2556 * avoid premature freeing RHS keys by mortalising
2558 * For a magic element, make a copy so that its magic is
2559 * called *before* the hash is emptied (which may affect
2560 * a tied value for example).
2561 * In theory we should check for magic keys in all
2562 * cases, not just under OPpASSIGN_COMMON_AGG, but in
2563 * practice, !OPpASSIGN_COMMON_AGG implies only
2564 * constants or padtmps on the RHS.
2566 EXTEND_MORTAL(nelems);
2567 for (svp = relem; svp <= lastrelem; svp += 2) {
2569 if (UNLIKELY(SvGMAGICAL(rsv))) {
2571 *svp = sv_mortalcopy_flags(*svp,
2572 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2573 /* allow other branch to continue pushing
2574 * onto tmps stack without checking each time */
2575 n = (lastrelem - relem) >> 1;
2579 PL_tmps_stack[++PL_tmps_ix] =
2580 SvREFCNT_inc_simple_NN(rsv);
2584 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2587 /* now assign the keys and values to the hash */
2591 if (UNLIKELY(gimme == G_ARRAY)) {
2592 /* @a = (%h = (...)) etc */
2594 SV **topelem = relem;
2596 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2599 /* remove duplicates from list we return */
2600 if (!hv_exists_ent(hash, key, 0)) {
2601 /* copy key back: possibly to an earlier
2602 * stack location if we encountered dups earlier,
2603 * The values will be updated later
2608 /* A tied store won't take ownership of val, so keep
2609 * the 1 refcnt on the tmps stack; otherwise disarm
2610 * the tmps stack entry */
2611 if (hv_store_ent(hash, key, val, 0))
2612 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2615 /* hv_store_ent() may have added set magic to val */;
2618 if (topelem < svp) {
2619 /* at this point we have removed the duplicate key/value
2620 * pairs from the stack, but the remaining values may be
2621 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
2622 * the (a 2), but the stack now probably contains
2623 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
2624 * obliterates the earlier key. So refresh all values. */
2625 lastrelem = topelem - 1;
2626 while (relem < lastrelem) {
2628 he = hv_fetch_ent(hash, *relem++, 0, 0);
2629 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
2635 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2638 if (hv_store_ent(hash, key, val, 0))
2639 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2642 /* hv_store_ent() may have added set magic to val */;
2648 /* there are still some 'live' recounts on the tmps stack
2649 * - usually caused by storing into a tied hash. So let
2650 * free_tmps() do the proper but slow job later.
2651 * Just disarm hash refcount: see comments below about leak
2653 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2656 /* Quietly remove all the SVs from the tmps stack slots,
2657 * since hash has now taken ownership of the refcnt.
2658 * Also remove hash: which will now leak if we die before
2659 * the SvREFCNT_dec_NN(hash) below */
2660 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2661 Move(&PL_tmps_stack[tmps_base + nelems],
2662 &PL_tmps_stack[tmps_base - 1],
2663 PL_tmps_ix - (tmps_base + nelems) + 1,
2665 PL_tmps_ix -= (nelems + 1);
2668 SvREFCNT_dec_NN(hash);
2670 relem = lastrelem + 1;
2675 if (!SvIMMORTAL(lsv)) {
2679 SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
2680 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
2683 packWARN(WARN_MISC),
2684 "Useless assignment to a temporary"
2687 /* avoid freeing $$lsv if it might be needed for further
2688 * elements, e.g. ($ref, $foo) = (1, $$ref) */
2690 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
2691 && lelem <= lastlelem
2694 SvREFCNT_inc_simple_void_NN(ref);
2695 /* an unrolled sv_2mortal */
2697 if (UNLIKELY(ix >= PL_tmps_max))
2698 /* speculatively grow enough to cover other
2700 (void)tmps_grow_p(ix + (lastlelem - lelem));
2701 PL_tmps_stack[ix] = ref;
2704 sv_setsv(lsv, *relem);
2708 if (++relem > lastrelem)
2717 /* simplified lelem loop for when there are no relems left */
2718 while (LIKELY(lelem <= lastlelem)) {
2721 TAINT_NOT; /* Each item stands on its own, taintwise. */
2723 if (UNLIKELY(!lsv)) {
2725 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2728 switch (SvTYPE(lsv)) {
2730 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
2732 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2738 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
2743 if (!SvIMMORTAL(lsv)) {
2752 TAINT_NOT; /* result of list assign isn't tainted */
2754 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
2755 /* Will be used to set PL_tainting below */
2756 Uid_t tmp_uid = PerlProc_getuid();
2757 Uid_t tmp_euid = PerlProc_geteuid();
2758 Gid_t tmp_gid = PerlProc_getgid();
2759 Gid_t tmp_egid = PerlProc_getegid();
2761 /* XXX $> et al currently silently ignore failures */
2762 if (PL_delaymagic & DM_UID) {
2763 #ifdef HAS_SETRESUID
2765 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2766 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
2768 #elif defined(HAS_SETREUID)
2770 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
2771 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
2774 if ((PL_delaymagic & DM_UID) == DM_RUID) {
2775 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
2776 PL_delaymagic &= ~DM_RUID;
2778 # endif /* HAS_SETRUID */
2780 if ((PL_delaymagic & DM_UID) == DM_EUID) {
2781 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
2782 PL_delaymagic &= ~DM_EUID;
2784 # endif /* HAS_SETEUID */
2785 if (PL_delaymagic & DM_UID) {
2786 if (PL_delaymagic_uid != PL_delaymagic_euid)
2787 DIE(aTHX_ "No setreuid available");
2788 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
2790 #endif /* HAS_SETRESUID */
2792 tmp_uid = PerlProc_getuid();
2793 tmp_euid = PerlProc_geteuid();
2795 /* XXX $> et al currently silently ignore failures */
2796 if (PL_delaymagic & DM_GID) {
2797 #ifdef HAS_SETRESGID
2799 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2800 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
2802 #elif defined(HAS_SETREGID)
2804 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
2805 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
2808 if ((PL_delaymagic & DM_GID) == DM_RGID) {
2809 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
2810 PL_delaymagic &= ~DM_RGID;
2812 # endif /* HAS_SETRGID */
2814 if ((PL_delaymagic & DM_GID) == DM_EGID) {
2815 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
2816 PL_delaymagic &= ~DM_EGID;
2818 # endif /* HAS_SETEGID */
2819 if (PL_delaymagic & DM_GID) {
2820 if (PL_delaymagic_gid != PL_delaymagic_egid)
2821 DIE(aTHX_ "No setregid available");
2822 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
2824 #endif /* HAS_SETRESGID */
2826 tmp_gid = PerlProc_getgid();
2827 tmp_egid = PerlProc_getegid();
2829 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
2830 #ifdef NO_TAINT_SUPPORT
2831 PERL_UNUSED_VAR(tmp_uid);
2832 PERL_UNUSED_VAR(tmp_euid);
2833 PERL_UNUSED_VAR(tmp_gid);
2834 PERL_UNUSED_VAR(tmp_egid);
2837 PL_delaymagic = old_delaymagic;
2839 if (gimme == G_VOID)
2840 SP = firstrelem - 1;
2841 else if (gimme == G_SCALAR) {
2844 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2845 SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2848 SETi(firstlelem - firstrelem);
2860 PMOP * const pm = cPMOP;
2861 REGEXP * rx = PM_GETRE(pm);
2862 regexp *prog = ReANY(rx);
2863 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
2864 SV * const rv = sv_newmortal();
2868 SvUPGRADE(rv, SVt_IV);
2869 /* For a subroutine describing itself as "This is a hacky workaround" I'm
2870 loathe to use it here, but it seems to be the right fix. Or close.
2871 The key part appears to be that it's essential for pp_qr to return a new
2872 object (SV), which implies that there needs to be an effective way to
2873 generate a new SV from the existing SV that is pre-compiled in the
2875 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
2878 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
2879 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
2880 *cvp = cv_clone(cv);
2881 SvREFCNT_dec_NN(cv);
2885 HV *const stash = gv_stashsv(pkg, GV_ADD);
2886 SvREFCNT_dec_NN(pkg);
2887 (void)sv_bless(rv, stash);
2890 if (UNLIKELY(RXp_ISTAINTED(prog))) {
2892 SvTAINTED_on(SvRV(rv));
2905 SSize_t curpos = 0; /* initial pos() or current $+[0] */
2908 const char *truebase; /* Start of string */
2909 REGEXP *rx = PM_GETRE(pm);
2910 regexp *prog = ReANY(rx);
2912 const U8 gimme = GIMME_V;
2914 const I32 oldsave = PL_savestack_ix;
2915 I32 had_zerolen = 0;
2918 if (PL_op->op_flags & OPf_STACKED)
2929 PUTBACK; /* EVAL blocks need stack_sp. */
2930 /* Skip get-magic if this is a qr// clone, because regcomp has
2932 truebase = prog->mother_re
2933 ? SvPV_nomg_const(TARG, len)
2934 : SvPV_const(TARG, len);
2936 DIE(aTHX_ "panic: pp_match");
2937 strend = truebase + len;
2938 rxtainted = (RXp_ISTAINTED(prog) ||
2939 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
2942 /* We need to know this in case we fail out early - pos() must be reset */
2943 global = dynpm->op_pmflags & PMf_GLOBAL;
2945 /* PMdf_USED is set after a ?? matches once */
2948 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2950 pm->op_pmflags & PMf_USED
2953 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
2957 /* handle the empty pattern */
2958 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
2959 if (PL_curpm == PL_reg_curpm) {
2960 if (PL_curpm_under) {
2961 if (PL_curpm_under == PL_reg_curpm) {
2962 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2964 pm = PL_curpm_under;
2974 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
2975 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
2976 UVuf " < %" IVdf ")\n",
2977 (UV)len, (IV)RXp_MINLEN(prog)));
2981 /* get pos() if //g */
2983 mg = mg_find_mglob(TARG);
2984 if (mg && mg->mg_len >= 0) {
2985 curpos = MgBYTEPOS(mg, TARG, truebase, len);
2986 /* last time pos() was set, it was zero-length match */
2987 if (mg->mg_flags & MGf_MINMATCH)
2992 #ifdef PERL_SAWAMPERSAND
2993 if ( RXp_NPARENS(prog)
2995 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2996 || (dynpm->op_pmflags & PMf_KEEPCOPY)
3000 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
3001 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
3002 * only on the first iteration. Therefore we need to copy $' as well
3003 * as $&, to make the rest of the string available for captures in
3004 * subsequent iterations */
3005 if (! (global && gimme == G_ARRAY))
3006 r_flags |= REXEC_COPY_SKIP_POST;
3008 #ifdef PERL_SAWAMPERSAND
3009 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3010 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3011 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3018 s = truebase + curpos;
3020 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
3021 had_zerolen, TARG, NULL, r_flags))
3025 if (dynpm->op_pmflags & PMf_ONCE)
3027 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
3029 dynpm->op_pmflags |= PMf_USED;
3033 RXp_MATCH_TAINTED_on(prog);
3034 TAINT_IF(RXp_MATCH_TAINTED(prog));
3038 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
3040 mg = sv_magicext_mglob(TARG);
3041 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
3042 if (RXp_ZERO_LEN(prog))
3043 mg->mg_flags |= MGf_MINMATCH;
3045 mg->mg_flags &= ~MGf_MINMATCH;
3048 if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
3049 LEAVE_SCOPE(oldsave);
3053 /* push captures on stack */
3056 const I32 nparens = RXp_NPARENS(prog);
3057 I32 i = (global && !nparens) ? 1 : 0;
3059 SPAGAIN; /* EVAL blocks could move the stack. */
3060 EXTEND(SP, nparens + i);
3061 EXTEND_MORTAL(nparens + i);
3062 for (i = !i; i <= nparens; i++) {
3063 PUSHs(sv_newmortal());
3064 if (LIKELY((RXp_OFFS(prog)[i].start != -1)
3065 && RXp_OFFS(prog)[i].end != -1 ))
3067 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
3068 const char * const s = RXp_OFFS(prog)[i].start + truebase;
3069 if (UNLIKELY( RXp_OFFS(prog)[i].end < 0
3070 || RXp_OFFS(prog)[i].start < 0
3072 || len > strend - s)
3074 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
3075 "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
3076 (long) i, (long) RXp_OFFS(prog)[i].start,
3077 (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
3078 sv_setpvn(*SP, s, len);
3079 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
3084 curpos = (UV)RXp_OFFS(prog)[0].end;
3085 had_zerolen = RXp_ZERO_LEN(prog);
3086 PUTBACK; /* EVAL blocks may use stack */
3087 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
3090 LEAVE_SCOPE(oldsave);
3093 NOT_REACHED; /* NOTREACHED */
3096 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
3098 mg = mg_find_mglob(TARG);
3102 LEAVE_SCOPE(oldsave);
3103 if (gimme == G_ARRAY)
3109 Perl_do_readline(pTHX)
3111 dSP; dTARGETSTACKED;
3116 IO * const io = GvIO(PL_last_in_gv);
3117 const I32 type = PL_op->op_type;
3118 const U8 gimme = GIMME_V;
3121 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
3123 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
3124 if (gimme == G_SCALAR) {
3126 SvSetSV_nosteal(TARG, TOPs);
3136 if (IoFLAGS(io) & IOf_ARGV) {
3137 if (IoFLAGS(io) & IOf_START) {
3139 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
3140 IoFLAGS(io) &= ~IOf_START;
3141 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
3142 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
3143 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3144 SvSETMAGIC(GvSV(PL_last_in_gv));
3149 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3150 if (!fp) { /* Note: fp != IoIFP(io) */
3151 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
3154 else if (type == OP_GLOB)
3155 fp = Perl_start_glob(aTHX_ POPs, io);
3157 else if (type == OP_GLOB)
3159 else if (IoTYPE(io) == IoTYPE_WRONLY) {
3160 report_wrongway_fh(PL_last_in_gv, '>');
3164 if ((!io || !(IoFLAGS(io) & IOf_START))
3165 && ckWARN(WARN_CLOSED)
3168 report_evil_fh(PL_last_in_gv);
3170 if (gimme == G_SCALAR) {
3171 /* undef TARG, and push that undefined value */
3172 if (type != OP_RCATLINE) {
3180 if (gimme == G_SCALAR) {
3182 if (type == OP_RCATLINE && SvGMAGICAL(sv))
3185 if (type == OP_RCATLINE)
3186 SvPV_force_nomg_nolen(sv);
3190 else if (isGV_with_GP(sv)) {
3191 SvPV_force_nomg_nolen(sv);
3193 SvUPGRADE(sv, SVt_PV);
3194 tmplen = SvLEN(sv); /* remember if already alloced */
3195 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
3196 /* try short-buffering it. Please update t/op/readline.t
3197 * if you change the growth length.
3202 if (type == OP_RCATLINE && SvOK(sv)) {
3204 SvPV_force_nomg_nolen(sv);
3210 sv = sv_2mortal(newSV(80));
3214 /* This should not be marked tainted if the fp is marked clean */
3215 #define MAYBE_TAINT_LINE(io, sv) \
3216 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3221 /* delay EOF state for a snarfed empty file */
3222 #define SNARF_EOF(gimme,rs,io,sv) \
3223 (gimme != G_SCALAR || SvCUR(sv) \
3224 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
3228 if (!sv_gets(sv, fp, offset)
3230 || SNARF_EOF(gimme, PL_rs, io, sv)
3231 || PerlIO_error(fp)))
3233 PerlIO_clearerr(fp);
3234 if (IoFLAGS(io) & IOf_ARGV) {
3235 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3238 (void)do_close(PL_last_in_gv, FALSE);
3240 else if (type == OP_GLOB) {
3241 if (!do_close(PL_last_in_gv, FALSE)) {
3242 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3243 "glob failed (child exited with status %d%s)",
3244 (int)(STATUS_CURRENT >> 8),
3245 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
3248 if (gimme == G_SCALAR) {
3249 if (type != OP_RCATLINE) {
3250 SV_CHECK_THINKFIRST_COW_DROP(TARG);
3256 MAYBE_TAINT_LINE(io, sv);
3259 MAYBE_TAINT_LINE(io, sv);
3261 IoFLAGS(io) |= IOf_NOLINE;
3265 if (type == OP_GLOB) {
3269 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
3270 char * const tmps = SvEND(sv) - 1;
3271 if (*tmps == *SvPVX_const(PL_rs)) {
3273 SvCUR_set(sv, SvCUR(sv) - 1);
3276 for (t1 = SvPVX_const(sv); *t1; t1++)
3278 if (strchr("*%?", *t1))
3280 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
3283 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
3284 (void)POPs; /* Unmatched wildcard? Chuck it... */
3287 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
3288 if (ckWARN(WARN_UTF8)) {
3289 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3290 const STRLEN len = SvCUR(sv) - offset;
3293 if (!is_utf8_string_loc(s, len, &f))
3294 /* Emulate :encoding(utf8) warning in the same case. */
3295 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3296 "utf8 \"\\x%02X\" does not map to Unicode",
3297 f < (U8*)SvEND(sv) ? *f : 0);
3300 if (gimme == G_ARRAY) {
3301 if (SvLEN(sv) - SvCUR(sv) > 20) {
3302 SvPV_shrink_to_cur(sv);
3304 sv = sv_2mortal(newSV(80));
3307 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
3308 /* try to reclaim a bit of scalar space (only on 1st alloc) */
3309 const STRLEN new_len
3310 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
3311 SvPV_renew(sv, new_len);
3322 SV * const keysv = POPs;
3323 HV * const hv = MUTABLE_HV(POPs);
3324 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3325 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3327 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3328 bool preeminent = TRUE;
3330 if (SvTYPE(hv) != SVt_PVHV)
3337 /* If we can determine whether the element exist,
3338 * Try to preserve the existenceness of a tied hash
3339 * element by using EXISTS and DELETE if possible.
3340 * Fallback to FETCH and STORE otherwise. */
3341 if (SvCANEXISTDELETE(hv))
3342 preeminent = hv_exists_ent(hv, keysv, 0);
3345 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3346 svp = he ? &HeVAL(he) : NULL;
3348 if (!svp || !*svp || *svp == &PL_sv_undef) {
3352 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3354 lv = sv_newmortal();
3355 sv_upgrade(lv, SVt_PVLV);
3357 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
3358 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
3359 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3365 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
3366 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
3367 else if (preeminent)
3368 save_helem_flags(hv, keysv, svp,
3369 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3371 SAVEHDELETE(hv, keysv);
3373 else if (PL_op->op_private & OPpDEREF) {
3374 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3378 sv = (svp && *svp ? *svp : &PL_sv_undef);
3379 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3380 * was to make C<local $tied{foo} = $tied{foo}> possible.
3381 * However, it seems no longer to be needed for that purpose, and
3382 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3383 * would loop endlessly since the pos magic is getting set on the
3384 * mortal copy and lost. However, the copy has the effect of
3385 * triggering the get magic, and losing it altogether made things like
3386 * c<$tied{foo};> in void context no longer do get magic, which some
3387 * code relied on. Also, delayed triggering of magic on @+ and friends
3388 * meant the original regex may be out of scope by now. So as a
3389 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3390 * being called too many times). */
3391 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
3398 /* a stripped-down version of Perl_softref2xv() for use by
3399 * pp_multideref(), which doesn't use PL_op->op_flags */
3402 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3405 if (PL_op->op_private & HINT_STRICT_REFS) {
3407 Perl_die(aTHX_ PL_no_symref_sv, sv,
3408 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3410 Perl_die(aTHX_ PL_no_usym, what);
3413 Perl_die(aTHX_ PL_no_usym, what);
3414 return gv_fetchsv_nomg(sv, GV_ADD, type);
3418 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
3419 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
3421 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
3422 * Each of these either contains a set of actions, or an argument, such as
3423 * an IV to use as an array index, or a lexical var to retrieve.
3424 * Several actions re stored per UV; we keep shifting new actions off the
3425 * one UV, and only reload when it becomes zero.
3430 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3431 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3432 UV actions = items->uv;
3435 /* this tells find_uninit_var() where we're up to */
3436 PL_multideref_pc = items;
3439 /* there are three main classes of action; the first retrieve
3440 * the initial AV or HV from a variable or the stack; the second
3441 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3442 * the third an unrolled (/DREFHV, rv2hv, helem).
3444 switch (actions & MDEREF_ACTION_MASK) {
3447 actions = (++items)->uv;
3450 case MDEREF_AV_padav_aelem: /* $lex[...] */
3451 sv = PAD_SVl((++items)->pad_offset);
3454 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
3455 sv = UNOP_AUX_item_sv(++items);
3456 assert(isGV_with_GP(sv));
3457 sv = (SV*)GvAVn((GV*)sv);
3460 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3465 goto do_AV_rv2av_aelem;
3468 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
3469 sv = UNOP_AUX_item_sv(++items);
3470 assert(isGV_with_GP(sv));
3471 sv = GvSVn((GV*)sv);
3472 goto do_AV_vivify_rv2av_aelem;
3474 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
3475 sv = PAD_SVl((++items)->pad_offset);
3478 do_AV_vivify_rv2av_aelem:
3479 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
3480 /* this is the OPpDEREF action normally found at the end of
3481 * ops like aelem, helem, rv2sv */
3482 sv = vivify_ref(sv, OPpDEREF_AV);
3486 /* this is basically a copy of pp_rv2av when it just has the
3489 if (LIKELY(SvROK(sv))) {
3490 if (UNLIKELY(SvAMAGIC(sv))) {
3491 sv = amagic_deref_call(sv, to_av_amg);
3494 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3495 DIE(aTHX_ "Not an ARRAY reference");
3497 else if (SvTYPE(sv) != SVt_PVAV) {
3498 if (!isGV_with_GP(sv))
3499 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3500 sv = MUTABLE_SV(GvAVn((GV*)sv));
3506 /* retrieve the key; this may be either a lexical or package
3507 * var (whose index/ptr is stored as an item) or a signed
3508 * integer constant stored as an item.
3511 IV elem = 0; /* to shut up stupid compiler warnings */
3514 assert(SvTYPE(sv) == SVt_PVAV);
3516 switch (actions & MDEREF_INDEX_MASK) {
3517 case MDEREF_INDEX_none:
3519 case MDEREF_INDEX_const:
3520 elem = (++items)->iv;
3522 case MDEREF_INDEX_padsv:
3523 elemsv = PAD_SVl((++items)->pad_offset);
3525 case MDEREF_INDEX_gvsv:
3526 elemsv = UNOP_AUX_item_sv(++items);
3527 assert(isGV_with_GP(elemsv));
3528 elemsv = GvSVn((GV*)elemsv);
3530 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
3531 && ckWARN(WARN_MISC)))
3532 Perl_warner(aTHX_ packWARN(WARN_MISC),
3533 "Use of reference \"%" SVf "\" as array index",
3535 /* the only time that S_find_uninit_var() needs this
3536 * is to determine which index value triggered the
3537 * undef warning. So just update it here. Note that
3538 * since we don't save and restore this var (e.g. for
3539 * tie or overload execution), its value will be
3540 * meaningless apart from just here */
3541 PL_multideref_pc = items;
3542 elem = SvIV(elemsv);
3547 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
3549 if (!(actions & MDEREF_FLAG_last)) {
3550 SV** svp = av_fetch((AV*)sv, elem, 1);
3551 if (!svp || ! (sv=*svp))
3552 DIE(aTHX_ PL_no_aelem, elem);
3556 if (PL_op->op_private &
3557 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3559 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3560 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
3563 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3564 sv = av_delete((AV*)sv, elem, discard);
3572 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3573 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3574 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3575 bool preeminent = TRUE;
3576 AV *const av = (AV*)sv;
3579 if (UNLIKELY(localizing)) {
3583 /* If we can determine whether the element exist,
3584 * Try to preserve the existenceness of a tied array
3585 * element by using EXISTS and DELETE if possible.
3586 * Fallback to FETCH and STORE otherwise. */
3587 if (SvCANEXISTDELETE(av))
3588 preeminent = av_exists(av, elem);
3591 svp = av_fetch(av, elem, lval && !defer);
3594 if (!svp || !(sv = *svp)) {
3597 DIE(aTHX_ PL_no_aelem, elem);
3598 len = av_tindex(av);
3599 /* Resolve a negative index that falls within
3600 * the array. Leave it negative it if falls
3601 * outside the array. */
3602 if (elem < 0 && len + elem >= 0)
3604 if (elem >= 0 && elem <= len)
3605 /* Falls within the array. */
3606 sv = av_nonelem(av,elem);
3608 /* Falls outside the array. If it is neg-
3609 ative, magic_setdefelem will use the
3610 index for error reporting. */
3611 sv = sv_2mortal(newSVavdefelem(av,elem,1));
3614 if (UNLIKELY(localizing)) {
3616 save_aelem(av, elem, svp);
3617 sv = *svp; /* may have changed */
3620 SAVEADELETE(av, elem);
3625 sv = (svp ? *svp : &PL_sv_undef);
3626 /* see note in pp_helem() */
3627 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3644 case MDEREF_HV_padhv_helem: /* $lex{...} */
3645 sv = PAD_SVl((++items)->pad_offset);
3648 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
3649 sv = UNOP_AUX_item_sv(++items);
3650 assert(isGV_with_GP(sv));
3651 sv = (SV*)GvHVn((GV*)sv);
3654 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
3659 goto do_HV_rv2hv_helem;
3662 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
3663 sv = UNOP_AUX_item_sv(++items);
3664 assert(isGV_with_GP(sv));
3665 sv = GvSVn((GV*)sv);
3666 goto do_HV_vivify_rv2hv_helem;
3668 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
3669 sv = PAD_SVl((++items)->pad_offset);
3672 do_HV_vivify_rv2hv_helem:
3673 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
3674 /* this is the OPpDEREF action normally found at the end of
3675 * ops like aelem, helem, rv2sv */
3676 sv = vivify_ref(sv, OPpDEREF_HV);
3680 /* this is basically a copy of pp_rv2hv when it just has the
3681 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3684 if (LIKELY(SvROK(sv))) {
3685 if (UNLIKELY(SvAMAGIC(sv))) {
3686 sv = amagic_deref_call(sv, to_hv_amg);
3689 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3690 DIE(aTHX_ "Not a HASH reference");
3692 else if (SvTYPE(sv) != SVt_PVHV) {
3693 if (!isGV_with_GP(sv))
3694 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3695 sv = MUTABLE_SV(GvHVn((GV*)sv));
3701 /* retrieve the key; this may be either a lexical / package
3702 * var or a string constant, whose index/ptr is stored as an
3705 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3707 assert(SvTYPE(sv) == SVt_PVHV);
3709 switch (actions & MDEREF_INDEX_MASK) {
3710 case MDEREF_INDEX_none:
3713 case MDEREF_INDEX_const:
3714 keysv = UNOP_AUX_item_sv(++items);
3717 case MDEREF_INDEX_padsv:
3718 keysv = PAD_SVl((++items)->pad_offset);
3721 case MDEREF_INDEX_gvsv:
3722 keysv = UNOP_AUX_item_sv(++items);
3723 keysv = GvSVn((GV*)keysv);
3727 /* see comment above about setting this var */
3728 PL_multideref_pc = items;
3731 /* ensure that candidate CONSTs have been HEKified */
3732 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3733 || SvTYPE(keysv) >= SVt_PVMG
3736 || SvIsCOW_shared_hash(keysv));
3738 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3740 if (!(actions & MDEREF_FLAG_last)) {
3741 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3742 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3743 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3747 if (PL_op->op_private &
3748 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3750 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3751 sv = hv_exists_ent((HV*)sv, keysv, 0)
3752 ? &PL_sv_yes : &PL_sv_no;
3755 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3756 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3764 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3765 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3766 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3767 bool preeminent = TRUE;
3769 HV * const hv = (HV*)sv;
3772 if (UNLIKELY(localizing)) {
3776 /* If we can determine whether the element exist,
3777 * Try to preserve the existenceness of a tied hash
3778 * element by using EXISTS and DELETE if possible.
3779 * Fallback to FETCH and STORE otherwise. */
3780 if (SvCANEXISTDELETE(hv))
3781 preeminent = hv_exists_ent(hv, keysv, 0);
3784 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3785 svp = he ? &HeVAL(he) : NULL;
3789 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
3793 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3794 lv = sv_newmortal();
3795 sv_upgrade(lv, SVt_PVLV);
3797 sv_magic(lv, key2 = newSVsv(keysv),
3798 PERL_MAGIC_defelem, NULL, 0);
3799 /* sv_magic() increments refcount */
3800 SvREFCNT_dec_NN(key2);
3801 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3807 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
3808 save_gp(MUTABLE_GV(sv),
3809 !(PL_op->op_flags & OPf_SPECIAL));
3810 else if (preeminent) {
3811 save_helem_flags(hv, keysv, svp,
3812 (PL_op->op_flags & OPf_SPECIAL)
3813 ? 0 : SAVEf_SETMAGIC);
3814 sv = *svp; /* may have changed */
3817 SAVEHDELETE(hv, keysv);
3822 sv = (svp && *svp ? *svp : &PL_sv_undef);
3823 /* see note in pp_helem() */
3824 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
3833 actions >>= MDEREF_SHIFT;
3851 itersvp = CxITERVAR(cx);
3854 switch (CxTYPE(cx)) {
3856 case CXt_LOOP_LAZYSV: /* string increment */
3858 SV* cur = cx->blk_loop.state_u.lazysv.cur;
3859 SV *end = cx->blk_loop.state_u.lazysv.end;
3860 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
3861 It has SvPVX of "" and SvCUR of 0, which is what we want. */
3863 const char *max = SvPV_const(end, maxlen);
3864 if (DO_UTF8(end) && IN_UNI_8_BIT)
3865 maxlen = sv_len_utf8_nomg(end);
3866 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
3870 /* NB: on the first iteration, oldsv will have a ref count of at
3871 * least 2 (one extra from blk_loop.itersave), so the GV or pad
3872 * slot will get localised; on subsequent iterations the RC==1
3873 * optimisation may kick in and the SV will be reused. */
3874 if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3875 /* safe to reuse old SV */
3876 sv_setsv(oldsv, cur);
3880 /* we need a fresh SV every time so that loop body sees a
3881 * completely new SV for closures/references to work as
3883 *itersvp = newSVsv(cur);
3884 SvREFCNT_dec(oldsv);
3886 if (strEQ(SvPVX_const(cur), max))
3887 sv_setiv(cur, 0); /* terminate next time */
3893 case CXt_LOOP_LAZYIV: /* integer increment */
3895 IV cur = cx->blk_loop.state_u.lazyiv.cur;
3896 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
3900 /* see NB comment above */
3901 if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3902 /* safe to reuse old SV */
3904 if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
3907 /* Cheap SvIOK_only().
3908 * Assert that flags which SvIOK_only() would test or
3909 * clear can't be set, because we're SVt_IV */
3910 assert(!(SvFLAGS(oldsv) &
3911 (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
3912 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
3913 /* SvIV_set() where sv_any points to head */
3914 oldsv->sv_u.svu_iv = cur;
3918 sv_setiv(oldsv, cur);
3922 /* we need a fresh SV every time so that loop body sees a
3923 * completely new SV for closures/references to work as they
3925 *itersvp = newSViv(cur);
3926 SvREFCNT_dec(oldsv);
3929 if (UNLIKELY(cur == IV_MAX)) {
3930 /* Handle end of range at IV_MAX */
3931 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
3933 ++cx->blk_loop.state_u.lazyiv.cur;
3937 case CXt_LOOP_LIST: /* for (1,2,3) */
3939 assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
3940 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
3941 ix = (cx->blk_loop.state_u.stack.ix += inc);
3942 if (UNLIKELY(inc > 0
3943 ? ix > cx->blk_oldsp
3944 : ix <= cx->blk_loop.state_u.stack.basesp)
3948 sv = PL_stack_base[ix];
3950 goto loop_ary_common;
3952 case CXt_LOOP_ARY: /* for (@ary) */
3954 av = cx->blk_loop.state_u.ary.ary;
3955 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
3956 ix = (cx->blk_loop.state_u.ary.ix += inc);
3957 if (UNLIKELY(inc > 0
3963 if (UNLIKELY(SvRMAGICAL(av))) {
3964 SV * const * const svp = av_fetch(av, ix, FALSE);
3965 sv = svp ? *svp : NULL;
3968 sv = AvARRAY(av)[ix];
3973 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
3974 SvSetMagicSV(*itersvp, sv);
3979 if (UNLIKELY(SvIS_FREED(sv))) {
3981 Perl_croak(aTHX_ "Use of freed value in iteration");
3988 SvREFCNT_inc_simple_void_NN(sv);
3992 sv = newSVavdefelem(av, ix, 0);
3999 SvREFCNT_dec(oldsv);
4003 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
4006 /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead
4007 * jump straight to the AND op's op_other */
4008 assert(PL_op->op_next->op_type == OP_AND);
4009 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4010 return cLOGOPx(PL_op->op_next)->op_other;
4013 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4015 /* pp_enteriter should have pre-extended the stack */
4016 EXTEND_SKIP(PL_stack_sp, 1);
4017 *++PL_stack_sp = &PL_sv_yes;
4018 return PL_op->op_next;
4022 /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead
4023 * jump straight to the AND op's op_next */
4024 assert(PL_op->op_next->op_type == OP_AND);
4025 /* pp_enteriter should have pre-extended the stack */
4026 EXTEND_SKIP(PL_stack_sp, 1);
4027 /* we only need this for the rare case where the OP_AND isn't
4028 * in void context, e.g. $x = do { for (..) {...} };
4029 * (or for when an XS module has replaced the op_ppaddr)
4030 * but it's cheaper to just push it rather than testing first
4032 *++PL_stack_sp = &PL_sv_no;
4033 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4034 return PL_op->op_next->op_next;
4037 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4039 return PL_op->op_next;
4045 A description of how taint works in pattern matching and substitution.
4047 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
4048 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
4050 While the pattern is being assembled/concatenated and then compiled,
4051 PL_tainted will get set (via TAINT_set) if any component of the pattern
4052 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
4053 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
4054 TAINT_get). It will also be set if any component of the pattern matches
4055 based on locale-dependent behavior.
4057 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
4058 the pattern is marked as tainted. This means that subsequent usage, such
4059 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
4060 on the new pattern too.
4062 RXf_TAINTED_SEEN is used post-execution by the get magic code
4063 of $1 et al to indicate whether the returned value should be tainted.
4064 It is the responsibility of the caller of the pattern (i.e. pp_match,
4065 pp_subst etc) to set this flag for any other circumstances where $1 needs
4068 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
4070 There are three possible sources of taint
4072 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
4073 * the replacement string (or expression under /e)
4075 There are four destinations of taint and they are affected by the sources
4076 according to the rules below:
4078 * the return value (not including /r):
4079 tainted by the source string and pattern, but only for the
4080 number-of-iterations case; boolean returns aren't tainted;
4081 * the modified string (or modified copy under /r):
4082 tainted by the source string, pattern, and replacement strings;
4084 tainted by the pattern, and under 'use re "taint"', by the source
4086 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
4087 should always be unset before executing subsequent code.
4089 The overall action of pp_subst is:
4091 * at the start, set bits in rxtainted indicating the taint status of
4092 the various sources.
4094 * After each pattern execution, update the SUBST_TAINT_PAT bit in
4095 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
4096 pattern has subsequently become tainted via locale ops.
4098 * If control is being passed to pp_substcont to execute a /e block,
4099 save rxtainted in the CXt_SUBST block, for future use by
4102 * Whenever control is being returned to perl code (either by falling
4103 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
4104 use the flag bits in rxtainted to make all the appropriate types of
4105 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
4106 et al will appear tainted.
4108 pp_match is just a simpler version of the above.
4124 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
4125 See "how taint works" above */
4128 REGEXP *rx = PM_GETRE(pm);
4129 regexp *prog = ReANY(rx);
4131 int force_on_match = 0;
4132 const I32 oldsave = PL_savestack_ix;
4134 bool doutf8 = FALSE; /* whether replacement is in utf8 */
4139 /* known replacement string? */
4140 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
4144 if (PL_op->op_flags & OPf_STACKED)
4155 SvGETMAGIC(TARG); /* must come before cow check */
4157 /* note that a string might get converted to COW during matching */
4158 was_cow = cBOOL(SvIsCOW(TARG));
4160 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4161 #ifndef PERL_ANY_COW
4163 sv_force_normal_flags(TARG,0);
4165 if ((SvREADONLY(TARG)
4166 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
4167 || SvTYPE(TARG) > SVt_PVLV)
4168 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
4169 Perl_croak_no_modify();
4173 orig = SvPV_nomg(TARG, len);
4174 /* note we don't (yet) force the var into being a string; if we fail
4175 * to match, we leave as-is; on successful match however, we *will*
4176 * coerce into a string, then repeat the match */
4177 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
4180 /* only replace once? */
4181 once = !(rpm->op_pmflags & PMf_GLOBAL);
4183 /* See "how taint works" above */
4186 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
4187 | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
4188 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
4189 | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4190 || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0));
4196 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
4198 strend = orig + len;
4199 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
4200 maxiters = 2 * slen + 10; /* We can match twice at each
4201 position, once with zero-length,
4202 second time with non-zero. */
4204 /* handle the empty pattern */
4205 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
4206 if (PL_curpm == PL_reg_curpm) {
4207 if (PL_curpm_under) {
4208 if (PL_curpm_under == PL_reg_curpm) {
4209 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
4211 pm = PL_curpm_under;
4221 #ifdef PERL_SAWAMPERSAND
4222 r_flags = ( RXp_NPARENS(prog)
4224 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
4225 || (rpm->op_pmflags & PMf_KEEPCOPY)
4230 r_flags = REXEC_COPY_STR;
4233 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
4236 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
4237 LEAVE_SCOPE(oldsave);
4242 /* known replacement string? */
4244 /* replacement needing upgrading? */
4245 if (DO_UTF8(TARG) && !doutf8) {
4246 nsv = sv_newmortal();
4248 sv_utf8_upgrade(nsv);
4249 c = SvPV_const(nsv, clen);
4253 c = SvPV_const(dstr, clen);
4254 doutf8 = DO_UTF8(dstr);
4257 if (UNLIKELY(TAINT_get))
4258 rxtainted |= SUBST_TAINT_REPL;
4265 /* can do inplace substitution? */
4270 && (I32)clen <= RXp_MINLENRET(prog)
4272 || !(r_flags & REXEC_COPY_STR)
4273 || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
4275 && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
4276 && (!doutf8 || SvUTF8(TARG))
4277 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4281 /* string might have got converted to COW since we set was_cow */
4282 if (SvIsCOW(TARG)) {
4283 if (!force_on_match)
4285 assert(SvVOK(TARG));
4288 if (force_on_match) {
4289 /* redo the first match, this time with the orig var
4290 * forced into being a string */
4292 orig = SvPV_force_nomg(TARG, len);
4298 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4299 rxtainted |= SUBST_TAINT_PAT;
4300 m = orig + RXp_OFFS(prog)[0].start;
4301 d = orig + RXp_OFFS(prog)[0].end;
4303 if (m - s > strend - d) { /* faster to shorten from end */
4306 Copy(c, m, clen, char);
4311 Move(d, m, i, char);
4315 SvCUR_set(TARG, m - s);
4317 else { /* faster from front */
4321 Move(s, d - i, i, char);
4324 Copy(c, d, clen, char);
4331 d = s = RXp_OFFS(prog)[0].start + orig;
4334 if (UNLIKELY(iters++ > maxiters))
4335 DIE(aTHX_ "Substitution loop");
4336 /* run time pattern taint, eg locale */
4337 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4338 rxtainted |= SUBST_TAINT_PAT;
4339 m = RXp_OFFS(prog)[0].start + orig;
4342 Move(s, d, i, char);
4346 Copy(c, d, clen, char);
4349 s = RXp_OFFS(prog)[0].end + orig;
4350 } while (CALLREGEXEC(rx, s, strend, orig,
4351 s == m, /* don't match same null twice */
4353 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4356 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
4357 Move(s, d, i+1, char); /* include the NUL */
4361 if (PL_op->op_private & OPpTRUEBOOL)
4371 if (force_on_match) {
4372 /* redo the first match, this time with the orig var
4373 * forced into being a string */
4375 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4376 /* I feel that it should be possible to avoid this mortal copy
4377 given that the code below copies into a new destination.
4378 However, I suspect it isn't worth the complexity of
4379 unravelling the C<goto force_it> for the small number of
4380 cases where it would be viable to drop into the copy code. */
4381 TARG = sv_2mortal(newSVsv(TARG));
4383 orig = SvPV_force_nomg(TARG, len);
4389 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4390 rxtainted |= SUBST_TAINT_PAT;
4392 s = RXp_OFFS(prog)[0].start + orig;
4393 dstr = newSVpvn_flags(orig, s-orig,
4394 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
4399 /* note that a whole bunch of local vars are saved here for
4400 * use by pp_substcont: here's a list of them in case you're
4401 * searching for places in this sub that uses a particular var:
4402 * iters maxiters r_flags oldsave rxtainted orig dstr targ
4403 * s m strend rx once */
4405 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
4409 if (UNLIKELY(iters++ > maxiters))
4410 DIE(aTHX_ "Substitution loop");
4411 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4412 rxtainted |= SUBST_TAINT_PAT;
4413 if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
4415 char *old_orig = orig;
4416 assert(RXp_SUBOFFSET(prog) == 0);
4418 orig = RXp_SUBBEG(prog);
4419 s = orig + (old_s - old_orig);
4420 strend = s + (strend - old_s);
4422 m = RXp_OFFS(prog)[0].start + orig;
4423 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
4424 s = RXp_OFFS(prog)[0].end + orig;
4426 /* replacement already stringified */
4428 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
4432 sv_catsv(dstr, repl);
4436 } while (CALLREGEXEC(rx, s, strend, orig,
4437 s == m, /* Yields minend of 0 or 1 */
4439 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4440 assert(strend >= s);
4441 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
4443 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4444 /* From here on down we're using the copy, and leaving the original
4451 /* The match may make the string COW. If so, brilliant, because
4452 that's just saved us one malloc, copy and free - the regexp has
4453 donated the old buffer, and we malloc an entirely new one, rather
4454 than the regexp malloc()ing a buffer and copying our original,
4455 only for us to throw it away here during the substitution. */
4456 if (SvIsCOW(TARG)) {
4457 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
4463 SvPV_set(TARG, SvPVX(dstr));
4464 SvCUR_set(TARG, SvCUR(dstr));
4465 SvLEN_set(TARG, SvLEN(dstr));
4466 SvFLAGS(TARG) |= SvUTF8(dstr);
4467 SvPV_set(dstr, NULL);
4470 if (PL_op->op_private & OPpTRUEBOOL)
4477 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4478 (void)SvPOK_only_UTF8(TARG);
4481 /* See "how taint works" above */
4483 if ((rxtainted & SUBST_TAINT_PAT) ||
4484 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
4485 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
4487 (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
4489 if (!(rxtainted & SUBST_TAINT_BOOLRET)
4490 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
4492 SvTAINTED_on(TOPs); /* taint return value */
4494 SvTAINTED_off(TOPs); /* may have got tainted earlier */
4496 /* needed for mg_set below */
4498 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
4502 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
4504 LEAVE_SCOPE(oldsave);
4514 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
4515 ++*PL_markstack_ptr;
4517 LEAVE_with_name("grep_item"); /* exit inner scope */
4520 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
4522 const U8 gimme = GIMME_V;
4524 LEAVE_with_name("grep"); /* exit outer scope */
4525 (void)POPMARK; /* pop src */
4526 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
4527 (void)POPMARK; /* pop dst */
4528 SP = PL_stack_base + POPMARK; /* pop original mark */
4529 if (gimme == G_SCALAR) {
4530 if (PL_op->op_private & OPpTRUEBOOL)
4531 PUSHs(items ? &PL_sv_yes : &PL_sv_zero);
4537 else if (gimme == G_ARRAY)
4544 ENTER_with_name("grep_item"); /* enter inner scope */
4547 src = PL_stack_base[TOPMARK];
4548 if (SvPADTMP(src)) {
4549 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
4555 RETURNOP(cLOGOP->op_other);
4559 /* leave_adjust_stacks():
4561 * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
4562 * positioning them at to_sp+1 onwards, and do the equivalent of a
4563 * FREEMPS and TAINT_NOT.
4565 * Not intended to be called in void context.
4567 * When leaving a sub, eval, do{} or other scope, the things that need
4568 * doing to process the return args are:
4569 * * in scalar context, only return the last arg (or PL_sv_undef if none);
4570 * * for the types of return that return copies of their args (such
4571 * as rvalue sub return), make a mortal copy of every return arg,
4572 * except where we can optimise the copy away without it being
4573 * semantically visible;
4574 * * make sure that the arg isn't prematurely freed; in the case of an
4575 * arg not copied, this may involve mortalising it. For example, in
4576 * C<sub f { my $x = ...; $x }>, $x would be freed when we do
4577 * CX_LEAVE_SCOPE(cx) unless it's protected or copied.
4579 * What condition to use when deciding whether to pass the arg through
4580 * or make a copy, is determined by the 'pass' arg; its valid values are:
4581 * 0: rvalue sub/eval exit
4582 * 1: other rvalue scope exit
4583 * 2: :lvalue sub exit in rvalue context
4584 * 3: :lvalue sub exit in lvalue context and other lvalue scope exits
4586 * There is a big issue with doing a FREETMPS. We would like to free any
4587 * temps created by the last statement which the sub executed, rather than
4588 * leaving them for the caller. In a situation where a sub call isn't
4589 * soon followed by a nextstate (e.g. nested recursive calls, a la
4590 * fibonacci()), temps can accumulate, causing memory and performance
4593 * On the other hand, we don't want to free any TEMPs which are keeping
4594 * alive any return args that we skipped copying; nor do we wish to undo
4595 * any mortalising done here.
4597 * The solution is to split the temps stack frame into two, with a cut
4598 * point delineating the two halves. We arrange that by the end of this
4599 * function, all the temps stack frame entries we wish to keep are in the
4600 * range PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
4601 * the range tmps_base .. PL_tmps_ix. During the course of this
4602 * function, tmps_base starts off as PL_tmps_floor+1, then increases
4603 * whenever we find or create a temp that we know should be kept. In
4604 * general the stuff above tmps_base is undecided until we reach the end,
4605 * and we may need a sort stage for that.
4607 * To determine whether a TEMP is keeping a return arg alive, every
4608 * arg that is kept rather than copied and which has the SvTEMP flag
4609 * set, has the flag temporarily unset, to mark it. At the end we scan
4610 * the temps stack frame above the cut for entries without SvTEMP and
4611 * keep them, while turning SvTEMP on again. Note that if we die before
4612 * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
4613 * those SVs may be slightly less efficient.
4615 * In practice various optimisations for some common cases mean we can
4616 * avoid most of the scanning and swapping about with the temps stack.
4620 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
4624 SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
4627 PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
4631 if (gimme == G_ARRAY) {
4632 nargs = SP - from_sp;
4636 assert(gimme == G_SCALAR);
4637 if (UNLIKELY(from_sp >= SP)) {
4638 /* no return args */
4639 assert(from_sp == SP);
4641 *++SP = &PL_sv_undef;
4651 /* common code for G_SCALAR and G_ARRAY */
4653 tmps_base = PL_tmps_floor + 1;
4657 /* pointer version of tmps_base. Not safe across temp stack
4661 EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
4662 tmps_basep = PL_tmps_stack + tmps_base;
4664 /* process each return arg */
4667 SV *sv = *from_sp++;
4669 assert(PL_tmps_ix + nargs < PL_tmps_max);
4671 /* PADTMPs with container set magic shouldn't appear in the
4672 * wild. This assert is more important for pp_leavesublv(),
4673 * but by testing for it here, we're more likely to catch
4674 * bad cases (what with :lvalue subs not being widely
4675 * deployed). The two issues are that for something like
4676 * sub :lvalue { $tied{foo} }
4678 * sub :lvalue { substr($foo,1,2) }
4679 * pp_leavesublv() will croak if the sub returns a PADTMP,
4680 * and currently functions like pp_substr() return a mortal
4681 * rather than using their PADTMP when returning a PVLV.
4682 * This is because the PVLV will hold a ref to $foo,
4683 * so $foo would get delayed in being freed while
4684 * the PADTMP SV remained in the PAD.
4685 * So if this assert fails it means either:
4686 * 1) there is pp code similar to pp_substr that is
4687 * returning a PADTMP instead of a mortal, and probably
4689 * 2) pp_leavesublv is making unwarranted assumptions
4690 * about always croaking on a PADTMP
4692 if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
4694 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
4695 assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
4701 pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
4702 : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
4703 : pass == 2 ? (!SvPADTMP(sv))
4706 /* pass through: skip copy for logic or optimisation
4707 * reasons; instead mortalise it, except that ... */
4711 /* ... since this SV is an SvTEMP , we don't need to
4712 * re-mortalise it; instead we just need to ensure
4713 * that its existing entry in the temps stack frame
4714 * ends up below the cut and so avoids being freed
4715 * this time round. We mark it as needing to be kept
4716 * by temporarily unsetting SvTEMP; then at the end,
4717 * we shuffle any !SvTEMP entries on the tmps stack
4718 * back below the cut.
4719 * However, there's a significant chance that there's
4720 * a 1:1 correspondence between the first few (or all)
4721 * elements in the return args stack frame and those
4722 * in the temps stack frame; e,g.:
4723 * sub f { ....; map {...} .... },
4724 * or if we're exiting multiple scopes and one of the
4725 * inner scopes has already made mortal copies of each
4728 * If so, this arg sv will correspond to the next item
4729 * on the tmps stack above the cut, and so can be kept
4730 * merely by moving the cut boundary up one, rather
4731 * than messing with SvTEMP. If all args are 1:1 then
4732 * we can avoid the sorting stage below completely.
4734 * If there are no items above the cut on the tmps
4735 * stack, then the SvTEMP must comne from an item
4736 * below the cut, so there's nothing to do.
4738 if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
4739 if (sv == *tmps_basep)
4745 else if (!SvPADTMP(sv)) {
4746 /* mortalise arg to avoid it being freed during save
4747 * stack unwinding. Pad tmps don't need mortalising as
4748 * they're never freed. This is the equivalent of
4749 * sv_2mortal(SvREFCNT_inc(sv)), except that:
4750 * * it assumes that the temps stack has already been
4752 * * it puts the new item at the cut rather than at
4753 * ++PL_tmps_ix, moving the previous occupant there
4756 if (!SvIMMORTAL(sv)) {
4757 SvREFCNT_inc_simple_void_NN(sv);
4759 /* Note that if there's nothing above the cut,
4760 * this copies the garbage one slot above
4761 * PL_tmps_ix onto itself. This is harmless (the
4762 * stack's already been extended), but might in
4763 * theory trigger warnings from tools like ASan
4765 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
4771 /* Make a mortal copy of the SV.
4772 * The following code is the equivalent of sv_mortalcopy()
4774 * * it assumes the temps stack has already been extended;
4775 * * it optimises the copying for some simple SV types;
4776 * * it puts the new item at the cut rather than at
4777 * ++PL_tmps_ix, moving the previous occupant there
4780 SV *newsv = newSV(0);
4782 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
4783 /* put it on the tmps stack early so it gets freed if we die */
4784 *tmps_basep++ = newsv;
4787 if (SvTYPE(sv) <= SVt_IV) {
4788 /* arg must be one of undef, IV/UV, or RV: skip
4789 * sv_setsv_flags() and do the copy directly */
4791 U32 srcflags = SvFLAGS(sv);
4793 assert(!SvGMAGICAL(sv));
4794 if (srcflags & (SVf_IOK|SVf_ROK)) {
4795 SET_SVANY_FOR_BODYLESS_IV(newsv);
4797 if (srcflags & SVf_ROK) {
4798 newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
4799 /* SV type plus flags */
4800 dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
4803 /* both src and dst are <= SVt_IV, so sv_any
4804 * points to the head; so access the heads
4805 * directly rather than going via sv_any.
4807 assert( &(sv->sv_u.svu_iv)
4808 == &(((XPVIV*) SvANY(sv))->xiv_iv));
4809 assert( &(newsv->sv_u.svu_iv)
4810 == &(((XPVIV*) SvANY(newsv))->xiv_iv));
4811 newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
4812 /* SV type plus flags */
4813 dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
4814 |(srcflags & SVf_IVisUV));
4818 assert(!(srcflags & SVf_OK));
4819 dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
4821 SvFLAGS(newsv) = dstflags;
4825 /* do the full sv_setsv() */
4829 old_base = tmps_basep - PL_tmps_stack;
4831 sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
4832 /* the mg_get or sv_setsv might have created new temps
4833 * or realloced the tmps stack; regrow and reload */
4834 EXTEND_MORTAL(nargs);
4835 tmps_basep = PL_tmps_stack + old_base;
4836 TAINT_NOT; /* Each item is independent */
4842 /* If there are any temps left above the cut, we need to sort
4843 * them into those to keep and those to free. The only ones to
4844 * keep are those for which we've temporarily unset SvTEMP.
4845 * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
4846 * swapping pairs as necessary. Stop when we meet in the middle.
4849 SV **top = PL_tmps_stack + PL_tmps_ix;
4850 while (tmps_basep <= top) {
4863 tmps_base = tmps_basep - PL_tmps_stack;
4866 PL_stack_sp = to_sp;
4868 /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
4869 while (PL_tmps_ix >= tmps_base) {
4870 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
4872 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
4876 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
4882 /* also tail-called by pp_return */
4892 assert(CxTYPE(cx) == CXt_SUB);
4894 if (CxMULTICALL(cx)) {
4895 /* entry zero of a stack is always PL_sv_undef, which
4896 * simplifies converting a '()' return into undef in scalar context */
4897 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
4901 gimme = cx->blk_gimme;
4902 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
4904 if (gimme == G_VOID)
4905 PL_stack_sp = oldsp;
4907 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4910 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
4912 retop = cx->blk_sub.retop;
4919 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
4920 * forces an abandon */
4923 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
4925 const SSize_t fill = AvFILLp(av);
4927 PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
4929 if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
4934 AV *newav = newAV();
4935 av_extend(newav, fill);
4936 AvREIFY_only(newav);
4937 PAD_SVl(0) = MUTABLE_SV(newav);
4938 SvREFCNT_dec_NN(av);
4949 I32 old_savestack_ix;
4954 /* Locate the CV to call:
4955 * - most common case: RV->CV: f(), $ref->():
4956 * note that if a sub is compiled before its caller is compiled,
4957 * the stash entry will be a ref to a CV, rather than being a GV.
4958 * - second most common case: CV: $ref->method()
4961 /* a non-magic-RV -> CV ? */
4962 if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
4963 cv = MUTABLE_CV(SvRV(sv));
4964 if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
4968 cv = MUTABLE_CV(sv);
4971 if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
4972 /* handle all the weird cases */
4973 switch (SvTYPE(sv)) {
4975 if (!isGV_with_GP(sv))
4979 cv = GvCVu((const GV *)sv);
4980 if (UNLIKELY(!cv)) {
4982 cv = sv_2cv(sv, &stash, &gv, 0);
4984 old_savestack_ix = PL_savestack_ix;
4995 if (UNLIKELY(SvAMAGIC(sv))) {
4996 sv = amagic_deref_call(sv, to_cv_amg);
4997 /* Don't SPAGAIN here. */
5003 if (UNLIKELY(!SvOK(sv)))
5004 DIE(aTHX_ PL_no_usym, "a subroutine");
5006 sym = SvPV_nomg_const(sv, len);
5007 if (PL_op->op_private & HINT_STRICT_REFS)
5008 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
5009 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
5012 cv = MUTABLE_CV(SvRV(sv));
5013 if (LIKELY(SvTYPE(cv) == SVt_PVCV))
5019 DIE(aTHX_ "Not a CODE reference");
5023 /* At this point we want to save PL_savestack_ix, either by doing a
5024 * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
5025 * CV we will be using (so we don't know whether its XS, so we can't
5026 * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
5027 * the save stack. So remember where we are currently on the save
5028 * stack, and later update the CX or scopestack entry accordingly. */
5029 old_savestack_ix = PL_savestack_ix;
5031 /* these two fields are in a union. If they ever become separate,
5032 * we have to test for both of them being null below */
5034 assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
5035 while (UNLIKELY(!CvROOT(cv))) {
5039 /* anonymous or undef'd function leaves us no recourse */
5040 if (CvLEXICAL(cv) && CvHASGV(cv))
5041 DIE(aTHX_ "Undefined subroutine &%" SVf " called",
5042 SVfARG(cv_name(cv, NULL, 0)));
5043 if (CvANON(cv) || !CvHASGV(cv)) {
5044 DIE(aTHX_ "Undefined subroutine called");
5047 /* autoloaded stub? */
5048 if (cv != GvCV(gv = CvGV(cv))) {
5051 /* should call AUTOLOAD now? */
5054 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
5055 (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
5056 |(PL_op->op_flags & OPf_REF
5057 ? GV_AUTOLOAD_ISMETHOD
5059 cv = autogv ? GvCV(autogv) : NULL;
5062 sub_name = sv_newmortal();
5063 gv_efullname3(sub_name, gv, NULL);
5064 DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
5068 /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
5069 if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
5070 DIE(aTHX_ "Closure prototype called");
5072 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
5075 Perl_get_db_sub(aTHX_ &sv, cv);
5077 PL_curcopdb = PL_curcop;
5079 /* check for lsub that handles lvalue subroutines */
5080 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
5081 /* if lsub not found then fall back to DB::sub */
5082 if (!cv) cv = GvCV(PL_DBsub);
5084 cv = GvCV(PL_DBsub);
5087 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
5088 DIE(aTHX_ "No DB::sub routine defined");
5091 if (!(CvISXSUB(cv))) {
5092 /* This path taken at least 75% of the time */
5099 /* keep PADTMP args alive throughout the call (we need to do this
5100 * because @_ isn't refcounted). Note that we create the mortals
5101 * in the caller's tmps frame, so they won't be freed until after
5102 * we return from the sub.
5111 *svp = sv = sv_mortalcopy(sv);
5117 cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
5118 hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
5119 cx_pushsub(cx, cv, PL_op->op_next, hasargs);
5121 padlist = CvPADLIST(cv);
5122 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
5123 pad_push(padlist, depth);
5124 PAD_SET_CUR_NOSAVE(padlist, depth);
5125 if (LIKELY(hasargs)) {
5126 AV *const av = MUTABLE_AV(PAD_SVl(0));
5130 defavp = &GvAV(PL_defgv);
5131 cx->blk_sub.savearray = *defavp;
5132 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
5134 /* it's the responsibility of whoever leaves a sub to ensure
5135 * that a clean, empty AV is left in pad[0]. This is normally
5136 * done by cx_popsub() */
5137 assert(!AvREAL(av) && AvFILLp(av) == -1);
5140 if (UNLIKELY(items - 1 > AvMAX(av))) {
5141 SV **ary = AvALLOC(av);
5142 Renew(ary, items, SV*);
5143 AvMAX(av) = items - 1;
5149 Copy(MARK+1,AvARRAY(av),items,SV*);
5150 AvFILLp(av) = items - 1;
5152 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5154 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5155 SVfARG(cv_name(cv, NULL, 0)));
5156 /* warning must come *after* we fully set up the context
5157 * stuff so that __WARN__ handlers can safely dounwind()
5160 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
5161 && ckWARN(WARN_RECURSION)
5162 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
5163 sub_crush_depth(cv);
5164 RETURNOP(CvSTART(cv));
5167 SSize_t markix = TOPMARK;
5171 /* pretend we did the ENTER earlier */
5172 PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
5177 if (UNLIKELY(((PL_op->op_private
5178 & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
5179 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5181 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5182 SVfARG(cv_name(cv, NULL, 0)));
5184 if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
5185 /* Need to copy @_ to stack. Alternative may be to
5186 * switch stack to @_, and copy return values
5187 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
5188 AV * const av = GvAV(PL_defgv);
5189 const SSize_t items = AvFILL(av) + 1;
5193 const bool m = cBOOL(SvRMAGICAL(av));
5194 /* Mark is at the end of the stack. */
5196 for (; i < items; ++i)
5200 SV ** const svp = av_fetch(av, i, 0);
5201 sv = svp ? *svp : NULL;
5203 else sv = AvARRAY(av)[i];
5204 if (sv) SP[i+1] = sv;
5206 SP[i+1] = av_nonelem(av, i);
5214 SV **mark = PL_stack_base + markix;
5215 SSize_t items = SP - mark;
5218 if (*mark && SvPADTMP(*mark)) {
5219 *mark = sv_mortalcopy(*mark);
5223 /* We assume first XSUB in &DB::sub is the called one. */
5224 if (UNLIKELY(PL_curcopdb)) {
5225 SAVEVPTR(PL_curcop);
5226 PL_curcop = PL_curcopdb;
5229 /* Do we need to open block here? XXXX */
5231 /* calculate gimme here as PL_op might get changed and then not
5232 * restored until the LEAVE further down */
5233 is_scalar = (GIMME_V == G_SCALAR);
5235 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
5237 CvXSUB(cv)(aTHX_ cv);
5239 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5240 /* This duplicates the check done in runops_debug(), but provides more
5241 * information in the common case of the fault being with an XSUB.
5243 * It should also catch an XSUB pushing more than it extends
5244 * in scalar context.
5246 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
5247 Perl_croak_nocontext(
5248 "panic: XSUB %s::%s (%s) failed to extend arg stack: "
5249 "base=%p, sp=%p, hwm=%p\n",
5250 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv),
5251 PL_stack_base, PL_stack_sp,
5252 PL_stack_base + PL_curstackinfo->si_stack_hwm);
5254 /* Enforce some sanity in scalar context. */
5256 SV **svp = PL_stack_base + markix + 1;
5257 if (svp != PL_stack_sp) {
5258 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
5268 Perl_sub_crush_depth(pTHX_ CV *cv)
5270 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
5273 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
5275 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
5276 SVfARG(cv_name(cv,NULL,0)));
5282 /* like croak, but report in context of caller */
5285 Perl_croak_caller(const char *pat, ...)
5289 const PERL_CONTEXT *cx = caller_cx(0, NULL);
5291 /* make error appear at call site */
5293 PL_curcop = cx->blk_oldcop;
5295 va_start(args, pat);
5297 NOT_REACHED; /* NOTREACHED */
5306 SV* const elemsv = POPs;
5307 IV elem = SvIV(elemsv);
5308 AV *const av = MUTABLE_AV(POPs);
5309 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
5310 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
5311 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5312 bool preeminent = TRUE;
5315 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
5316 Perl_warner(aTHX_ packWARN(WARN_MISC),
5317 "Use of reference \"%" SVf "\" as array index",
5319 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
5322 if (UNLIKELY(localizing)) {
5326 /* If we can determine whether the element exist,
5327 * Try to preserve the existenceness of a tied array
5328 * element by using EXISTS and DELETE if possible.
5329 * Fallback to FETCH and STORE otherwise. */
5330 if (SvCANEXISTDELETE(av))
5331 preeminent = av_exists(av, elem);
5334 svp = av_fetch(av, elem, lval && !defer);
5336 #ifdef PERL_MALLOC_WRAP
5337 if (SvUOK(elemsv)) {
5338 const UV uv = SvUV(elemsv);
5339 elem = uv > IV_MAX ? IV_MAX : uv;
5341 else if (SvNOK(elemsv))
5342 elem = (IV)SvNV(elemsv);
5344 MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend");
5347 if (!svp || !*svp) {
5350 DIE(aTHX_ PL_no_aelem, elem);
5351 len = av_tindex(av);
5352 /* Resolve a negative index that falls within the array. Leave
5353 it negative it if falls outside the array. */
5354 if (elem < 0 && len + elem >= 0)
5356 if (elem >= 0 && elem <= len)
5357 /* Falls within the array. */
5358 PUSHs(av_nonelem(av,elem));
5360 /* Falls outside the array. If it is negative,
5361 magic_setdefelem will use the index for error reporting.
5363 mPUSHs(newSVavdefelem(av, elem, 1));
5366 if (UNLIKELY(localizing)) {
5368 save_aelem(av, elem, svp);
5370 SAVEADELETE(av, elem);
5372 else if (PL_op->op_private & OPpDEREF) {
5373 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
5377 sv = (svp ? *svp : &PL_sv_undef);
5378 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
5385 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
5387 PERL_ARGS_ASSERT_VIVIFY_REF;
5392 Perl_croak_no_modify();
5393 prepare_SV_for_RV(sv);
5396 SvRV_set(sv, newSV(0));
5399 SvRV_set(sv, MUTABLE_SV(newAV()));
5402 SvRV_set(sv, MUTABLE_SV(newHV()));
5409 if (SvGMAGICAL(sv)) {
5410 /* copy the sv without magic to prevent magic from being
5412 SV* msv = sv_newmortal();
5413 sv_setsv_nomg(msv, sv);
5419 PERL_STATIC_INLINE HV *
5420 S_opmethod_stash(pTHX_ SV* meth)
5425 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
5426 ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
5427 "package or object reference", SVfARG(meth)),
5429 : *(PL_stack_base + TOPMARK + 1);
5431 PERL_ARGS_ASSERT_OPMETHOD_STASH;
5435 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
5438 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
5439 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
5440 stash = gv_stashsv(sv, GV_CACHE_ONLY);
5441 if (stash) return stash;
5445 ob = MUTABLE_SV(SvRV(sv));
5446 else if (!SvOK(sv)) goto undefined;
5447 else if (isGV_with_GP(sv)) {
5449 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
5450 "without a package or object reference",
5453 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
5454 assert(!LvTARGLEN(ob));
5458 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
5461 /* this isn't a reference */
5464 const char * const packname = SvPV_nomg_const(sv, packlen);
5465 const U32 packname_utf8 = SvUTF8(sv);
5466 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
5467 if (stash) return stash;
5469 if (!(iogv = gv_fetchpvn_flags(
5470 packname, packlen, packname_utf8, SVt_PVIO
5472 !(ob=MUTABLE_SV(GvIO(iogv))))
5474 /* this isn't the name of a filehandle either */
5477 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
5478 "without a package or object reference",
5481 /* assume it's a package name */
5482 stash = gv_stashpvn(packname, packlen, packname_utf8);
5483 if (stash) return stash;
5484 else return MUTABLE_HV(sv);
5486 /* it _is_ a filehandle name -- replace with a reference */
5487 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
5490 /* if we got here, ob should be an object or a glob */
5491 if (!ob || !(SvOBJECT(ob)
5492 || (isGV_with_GP(ob)
5493 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
5496 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
5497 SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
5498 ? newSVpvs_flags("DOES", SVs_TEMP)
5510 SV* const meth = TOPs;
5513 SV* const rmeth = SvRV(meth);
5514 if (SvTYPE(rmeth) == SVt_PVCV) {
5520 stash = opmethod_stash(meth);
5522 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
5525 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5529 #define METHOD_CHECK_CACHE(stash,cache,meth) \
5530 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
5532 gv = MUTABLE_GV(HeVAL(he)); \
5533 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
5534 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
5536 XPUSHs(MUTABLE_SV(GvCV(gv))); \
5545 SV* const meth = cMETHOPx_meth(PL_op);
5546 HV* const stash = opmethod_stash(meth);
5548 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
5549 METHOD_CHECK_CACHE(stash, stash, meth);
5552 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
5555 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5564 SV* const meth = cMETHOPx_meth(PL_op);
5565 HV* const stash = CopSTASH(PL_curcop);
5566 /* Actually, SUPER doesn't need real object's (or class') stash at all,
5567 * as it uses CopSTASH. However, we must ensure that object(class) is
5568 * correct (this check is done by S_opmethod_stash) */
5569 opmethod_stash(meth);
5571 if ((cache = HvMROMETA(stash)->super)) {
5572 METHOD_CHECK_CACHE(stash, cache, meth);
5575 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
5578 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5586 SV* const meth = cMETHOPx_meth(PL_op);
5587 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
5588 opmethod_stash(meth); /* not used but needed for error checks */
5590 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
5591 else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
5593 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
5596 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5600 PP(pp_method_redir_super)
5605 SV* const meth = cMETHOPx_meth(PL_op);
5606 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
5607 opmethod_stash(meth); /* not used but needed for error checks */
5609 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
5610 else if ((cache = HvMROMETA(stash)->super)) {
5611 METHOD_CHECK_CACHE(stash, cache, meth);
5614 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
5617 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5622 * ex: set ts=8 sts=4 sw=4 et: