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
44 /* common code for pp_wrap() and xs_wrap():
45 * free any original arguments, and bump and shift down any return
50 S_pp_xs_wrap_return(pTHX_ I32 nargs, I32 old_sp)
52 I32 nret = (I32)(PL_stack_sp - PL_stack_base) - old_sp;
55 /* bump any returned values */
57 SV **svp = PL_stack_sp - nret + 1;
58 while (svp <= PL_stack_sp) {
64 PL_curstackinfo->si_stack_nonrc_base = 0;
66 /* free the original args and shift the returned valued down */
68 SV **svp = PL_stack_sp - nret;
77 Move(PL_stack_sp - nret + 1,
78 PL_stack_sp - nret - nargs + 1,
86 * wrapper function for pp() functions to turn them into functions
87 * that can operate on a reference-counted stack, by taking a non-
88 * reference-counted copy of the current stack frame, calling the real
89 * pp() function, then incrementing the reference count of any returned
92 * nargs or nlists indicate the number of stack arguments or the
93 * number of stack lists (delimited by MARKs) which the function expects.
96 Perl_pp_wrap(pTHX_ Perl_ppaddr_t real_pp_fn, I32 nargs, int nlists)
98 PERL_ARGS_ASSERT_PP_WRAP;
100 if (!rpp_stack_is_rc())
101 /* stack-already non-RC; nothing needing wrapping */
102 return real_pp_fn(aTHX);
105 I32 old_sp = (I32)(PL_stack_sp - PL_stack_base);
109 assert(AvREAL(PL_curstack));
111 PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base + 1;
115 I32 mark = PL_markstack_ptr[-nlists+1];
116 nargs = (PL_stack_sp - PL_stack_base) - mark;
117 assert(nlists <= 2); /* if ever more, make below a loop */
118 PL_markstack_ptr[0] += nargs;
120 PL_markstack_ptr[-1] += nargs;
124 /* duplicate all the arg pointers further up the stack */
126 Copy(PL_stack_sp - nargs + 1, PL_stack_sp + 1, nargs, SV*);
127 PL_stack_sp += nargs;
130 next_op = real_pp_fn(aTHX);
132 /* we should still be a split stack */
133 assert(AvREAL(PL_curstack));
134 assert(PL_curstackinfo->si_stack_nonrc_base);
136 S_pp_xs_wrap_return(aTHX_ nargs, old_sp);
143 * similar in concept to pp_wrap: make a non-referenced-counted copy of
144 * a (not refcount aware) XS sub's args, call the XS subs, then bump any
145 * return values and free the original args */
148 Perl_xs_wrap(pTHX_ XSUBADDR_t xsub, CV *cv)
150 PERL_ARGS_ASSERT_XS_WRAP;
152 I32 old_sp = (I32)(PL_stack_sp - PL_stack_base);
153 I32 mark = PL_markstack_ptr[0];
154 I32 nargs = (PL_stack_sp - PL_stack_base) - mark;
156 /* we should be a fully refcounted stack */
157 assert(AvREAL(PL_curstack));
158 assert(!PL_curstackinfo->si_stack_nonrc_base);
160 PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base + 1;
164 /* duplicate all the arg pointers further up the stack */
166 Copy(PL_stack_sp - nargs + 1, PL_stack_sp + 1, nargs, SV*);
167 PL_stack_sp += nargs;
168 PL_markstack_ptr[0] += nargs;
173 S_pp_xs_wrap_return(aTHX_ nargs, old_sp);
179 /* ----------------------------------------------------------- */
184 rpp_xpush_1(cSVOP_sv);
190 PL_curcop = (COP*)PL_op;
191 TAINT_NOT; /* Each statement is presumed innocent */
192 rpp_popfree_to(PL_stack_base + CX_CUR()->blk_oldsp);
200 assert(SvTYPE(cGVOP_gv) == SVt_PVGV);
202 UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)
203 ? save_scalar(cGVOP_gv)
209 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
216 /* This is sometimes called directly by pp_coreargs, pp_grepstart and
220 PUSHMARK(PL_stack_sp);
224 PP_wrapped(pp_stringify, 1, 0)
227 SV * const sv = TOPs;
231 /* no PUTBACK, SETs doesn't inc/dec SP */
237 /* cGVOP_gv might be a real GV or might be an RV to a CV */
238 assert(SvTYPE(cGVOP_gv) == SVt_PVGV ||
239 (SvTYPE(cGVOP_gv) <= SVt_PVMG && SvROK(cGVOP_gv) && SvTYPE(SvRV(cGVOP_gv)) == SVt_PVCV));
240 rpp_xpush_1(MUTABLE_SV(cGVOP_gv));
245 /* also used for: pp_andassign() */
247 PP_wrapped(pp_and, 2, 0)
251 /* SP is not used to remove a variable that is saved across the
252 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
253 register or load/store vs direct mem ops macro is introduced, this
254 should be a define block between direct PL_stack_sp and dSP operations,
255 presently, using PL_stack_sp is bias towards CISC cpus */
256 SV * const sv = *PL_stack_sp;
260 if (PL_op->op_type == OP_AND)
262 return cLOGOP->op_other;
268 * Mashup of simple padsv + sassign OPs
269 * Doesn't support the following lengthy and unlikely sassign case:
270 * (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV))
271 * These cases have a separate optimization, so are not handled here:
272 * (PL_op->op_private & OPpASSIGN_BACKWARDS) {or,and,dor}assign
275 PP_wrapped(pp_padsv_store,1,0)
278 OP * const op = PL_op;
279 SV** const padentry = &PAD_SVl(op->op_targ);
280 SV* targ = *padentry; /* lvalue to assign into */
281 SV* const val = TOPs; /* RHS value to assign */
283 /* !OPf_STACKED is not handled by this OP */
284 assert(op->op_flags & OPf_STACKED);
286 /* Inlined, simplified pp_padsv here */
287 if ((op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
288 save_clearsv(padentry);
291 /* Inlined, simplified pp_sassign from here */
292 assert(TAINTING_get || !TAINT_get);
293 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
297 UNLIKELY(SvTEMP(targ)) && !SvSMAGICAL(targ) && SvREFCNT(targ) == 1 &&
298 (!isGV_with_GP(targ) || SvFAKE(targ)) && ckWARN(WARN_MISC)
301 packWARN(WARN_MISC), "Useless assignment to a temporary"
303 SvSetMagicSV(targ, val);
309 /* A mashup of simplified AELEMFAST_LEX + SASSIGN OPs */
311 PP_wrapped(pp_aelemfastlex_store, 1, 0)
314 OP * const op = PL_op;
315 SV* const val = TOPs; /* RHS value to assign */
316 AV * const av = MUTABLE_AV(PAD_SV(op->op_targ));
317 const I8 key = (I8)PL_op->op_private;
320 /* !OPf_STACKED is not handled by this OP */
321 assert(op->op_flags & OPf_STACKED);
323 /* Inlined, simplified pp_aelemfast here */
324 assert(SvTYPE(av) == SVt_PVAV);
326 /* inlined av_fetch() for simple cases ... */
327 if (!SvRMAGICAL(av) && key >=0 && key <= AvFILLp(av)) {
328 targ = AvARRAY(av)[key];
330 /* ... else do it the hard way */
332 SV **svp = av_fetch(av, key, 1);
337 DIE(aTHX_ PL_no_aelem, (int)key);
340 /* Inlined, simplified pp_sassign from here */
341 assert(TAINTING_get || !TAINT_get);
342 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
345 /* This assertion is a deviation from pp_sassign, which uses an if()
346 * condition to check for "Useless assignment to a temporary" and
347 * warns if the condition is true. Here, the condition should NEVER
348 * be true when the LHS is the result of an array fetch. The
349 * assertion is here as a final check that this remains the case.
351 assert(!(SvTEMP(targ) && SvREFCNT(targ) == 1 && !SvSMAGICAL(targ)));
353 SvSetMagicSV(targ, val);
359 PP_wrapped(pp_sassign, 2, 0)
362 /* sassign keeps its args in the optree traditionally backwards.
363 So we pop them differently.
365 SV *left = POPs; SV *right = TOPs;
367 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
368 SV * const temp = left;
369 left = right; right = temp;
371 assert(TAINTING_get || !TAINT_get);
372 if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
374 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
376 SV * const cv = SvRV(right);
377 const U32 cv_type = SvTYPE(cv);
378 const bool is_gv = isGV_with_GP(left);
379 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
385 /* Can do the optimisation if left (LVALUE) is not a typeglob,
386 right (RVALUE) is a reference to something, and we're in void
388 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
389 /* Is the target symbol table currently empty? */
390 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
391 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
392 /* Good. Create a new proxy constant subroutine in the target.
393 The gv becomes a(nother) reference to the constant. */
394 SV *const value = SvRV(cv);
396 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
397 SvPCS_IMPORTED_on(gv);
399 SvREFCNT_inc_simple_void(value);
405 /* Need to fix things up. */
407 /* Need to fix GV. */
408 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
412 /* We've been returned a constant rather than a full subroutine,
413 but they expect a subroutine reference to apply. */
415 ENTER_with_name("sassign_coderef");
416 SvREFCNT_inc_void(SvRV(cv));
417 /* newCONSTSUB takes a reference count on the passed in SV
418 from us. We set the name to NULL, otherwise we get into
419 all sorts of fun as the reference to our new sub is
420 donated to the GV that we're about to assign to.
422 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
425 LEAVE_with_name("sassign_coderef");
427 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
429 First: ops for \&{"BONK"}; return us the constant in the
431 Second: ops for *{"BONK"} cause that symbol table entry
432 (and our reference to it) to be upgraded from RV
434 Thirdly: We get here. cv is actually PVGV now, and its
435 GvCV() is actually the subroutine we're looking for
437 So change the reference so that it points to the subroutine
438 of that typeglob, as that's what they were after all along.
440 GV *const upgraded = MUTABLE_GV(cv);
441 CV *const source = GvCV(upgraded);
444 assert(CvFLAGS(source) & CVf_CONST);
446 SvREFCNT_inc_simple_void_NN(source);
447 SvREFCNT_dec_NN(upgraded);
448 SvRV_set(right, MUTABLE_SV(source));
454 rpp_is_lone(left) && !SvSMAGICAL(left) &&
455 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
458 packWARN(WARN_MISC), "Useless assignment to a temporary"
460 SvSetMagicSV(left, right);
465 PP_wrapped(pp_cond_expr, 1, 0)
472 RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
479 TAINT_NOT; /* Each statement is presumed innocent */
481 rpp_popfree_to(PL_stack_base + CX_CUR()->blk_oldsp);
483 if (!(PL_op->op_flags & OPf_SPECIAL)) {
484 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
491 /* The main body of pp_concat, not including the magic/overload and
493 * It does targ = left . right.
494 * Moved into a separate function so that pp_multiconcat() can use it
498 PERL_STATIC_INLINE void
499 S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy)
503 const char *rpv = NULL;
505 bool rcopied = FALSE;
507 if (TARG == right && right != left) { /* $r = $l.$r */
508 rpv = SvPV_nomg_const(right, rlen);
509 rbyte = !DO_UTF8(right);
510 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
511 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
515 if (TARG != left) { /* not $l .= $r */
517 const char* const lpv = SvPV_nomg_const(left, llen);
518 lbyte = !DO_UTF8(left);
519 sv_setpvn(TARG, lpv, llen);
525 else { /* $l .= $r and left == TARG */
527 if ((left == right /* $l .= $l */
528 || targmy) /* $l = $l . $r */
529 && ckWARN(WARN_UNINITIALIZED)
535 SvPV_force_nomg_nolen(left);
537 lbyte = !DO_UTF8(left);
543 rpv = SvPV_nomg_const(right, rlen);
544 rbyte = !DO_UTF8(right);
546 if (lbyte != rbyte) {
548 sv_utf8_upgrade_nomg(TARG);
551 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
552 sv_utf8_upgrade_nomg(right);
553 rpv = SvPV_nomg_const(right, rlen);
556 sv_catpvn_nomg(TARG, rpv, rlen);
561 PP_wrapped(pp_concat, 2, 0)
563 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
566 S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY);
575 Concatenate one or more args, possibly interleaved with constant string
576 segments. The result may be assigned to, or appended to, a variable or
579 Several op_flags and/or op_private bits indicate what the target is, and
580 whether it's appended to. Valid permutations are:
582 - (PADTMP) = (A.B.C....)
583 OPpTARGET_MY $lex = (A.B.C....)
584 OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....)
585 OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....)
586 OPf_STACKED expr = (A.B.C....)
587 OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....)
589 Other combinations like (A.B).(C.D) are not optimised into a multiconcat
590 op, as it's too hard to get the correct ordering of ties, overload etc.
594 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised
595 sprintf "...%s...". Don't call '.'
596 overloading: only use '""' overloading.
598 OPpMULTICONCAT_STRINGIFY: the RHS was of the form
599 "...$a...$b..." rather than
600 "..." . $a . "..." . $b . "..."
602 An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
603 defined with PERL_MULTICONCAT_IX_FOO constants, where:
606 FOO index description
607 -------- ----- ----------------------------------
608 NARGS 0 number of arguments
609 PLAIN_PV 1 non-utf8 constant string
610 PLAIN_LEN 2 non-utf8 constant string length
611 UTF8_PV 3 utf8 constant string
612 UTF8_LEN 4 utf8 constant string length
613 LENGTHS 5 first of nargs+1 const segment lengths
615 The idea is that a general string concatenation will have a fixed (known
616 at compile time) number of variable args, interspersed with constant
617 strings, e.g. "a=$a b=$b\n"
619 All the constant string segments "a=", " b=" and "\n" are stored as a
620 single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
621 with a series of segment lengths: e.g. 2,3,1. In the case where the
622 constant string is plain but has a different utf8 representation, both
623 variants are stored, and two sets of (nargs+1) segments lengths are stored
624 in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
626 A segment length of -1 indicates that there is no constant string at that
627 point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
628 have differing overloading behaviour.
633 /* how many stack arguments a multiconcat op expects */
636 S_multiconcat_argcount(pTHX)
638 UNOP_AUX_item *aux = cUNOP_AUXx(PL_op)->op_aux;
639 SSize_t nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
640 if (PL_op->op_flags & OPf_STACKED)
646 PP_wrapped(pp_multiconcat, S_multiconcat_argcount(aTHX), 0)
649 SV *targ; /* The SV to be assigned or appended to */
650 char *targ_pv; /* where within SvPVX(targ) we're writing to */
651 STRLEN targ_len; /* SvCUR(targ) */
652 SV **toparg; /* the highest arg position on the stack */
653 UNOP_AUX_item *aux; /* PL_op->op_aux buffer */
654 UNOP_AUX_item *const_lens; /* the segment length array part of aux */
655 const char *const_pv; /* the current segment of the const string buf */
656 SSize_t nargs; /* how many args were expected */
657 SSize_t stack_adj; /* how much to adjust SP on return */
658 STRLEN grow; /* final size of destination string (targ) */
659 UV targ_count; /* how many times targ has appeared on the RHS */
660 bool is_append; /* OPpMULTICONCAT_APPEND flag is set */
661 bool slow_concat; /* args too complex for quick concat */
662 U32 dst_utf8; /* the result will be utf8 (indicate this with
663 SVf_UTF8 in a U32, rather than using bool,
664 for ease of testing and setting) */
665 /* for each arg, holds the result of an SvPV() call */
666 struct multiconcat_svpv {
670 *targ_chain, /* chain of slots where targ has appeared on RHS */
671 *svpv_p, /* ptr for looping through svpv_buf */
672 *svpv_base, /* first slot (may be greater than svpv_buf), */
673 *svpv_end, /* and slot after highest result so far, of: */
674 svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
676 aux = cUNOP_AUXx(PL_op)->op_aux;
677 stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
678 is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
680 /* get targ from the stack or pad */
682 if (PL_op->op_flags & OPf_STACKED) {
684 /* for 'expr .= ...', expr is the bottom item on the stack */
689 /* for 'expr = ...', expr is the top item on the stack */
693 SV **svp = &(PAD_SVl(PL_op->op_targ));
695 if (PL_op->op_private & OPpLVAL_INTRO) {
696 assert(PL_op->op_private & OPpTARGET_MY);
700 /* $lex .= "const" doesn't cause anything to be pushed */
706 grow = 1; /* allow for '\0' at minimum */
711 /* only utf8 variants of the const strings? */
712 dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
715 /* --------------------------------------------------------------
718 * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
719 * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
721 * utf8 is indicated by storing a negative length.
723 * Where an arg is actually targ, the stringification is deferred:
724 * the length is set to 0, and the slot is added to targ_chain.
726 * If a magic, overloaded, or otherwise weird arg is found, which
727 * might have side effects when stringified, the loop is abandoned and
728 * we goto a code block where a more basic 'emulate calling
729 * pp_cpncat() on each arg in turn' is done.
732 for (; SP <= toparg; SP++, svpv_end++) {
737 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
741 /* this if/else chain is arranged so that common/simple cases
742 * take few conditionals */
744 if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) {
745 /* common case: sv is a simple non-magical PV */
747 /* targ appears on RHS.
748 * Delay storing PV pointer; instead, add slot to targ_chain
749 * so it can be populated later, after targ has been grown and
750 * we know its final SvPVX() address.
753 svpv_end->len = 0; /* zerojng here means we can skip
754 updating later if targ_len == 0 */
755 svpv_end->pv = (char*)targ_chain;
756 targ_chain = svpv_end;
762 svpv_end->pv = SvPVX(sv);
764 else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK)))
765 /* may have side effects: tie, overload etc.
766 * Abandon 'stringify everything first' and handle
767 * args in strict order. Note that already-stringified args
768 * will be reprocessed, which is safe because the each first
769 * stringification would have been idempotent.
772 else if (SvNIOK(sv)) {
775 /* stringify general valid scalar */
776 svpv_end->pv = sv_2pv_flags(sv, &len, 0);
778 else if (!SvOK(sv)) {
779 if (ckWARN(WARN_UNINITIALIZED))
780 /* an undef value in the presence of warnings may trigger
787 goto do_magical; /* something weird */
789 utf8 = (SvFLAGS(sv) & SVf_UTF8);
791 ASSUME(len < SSize_t_MAX);
792 svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
796 /* --------------------------------------------------------------
801 * if targ appears on the RHS or is appended to, force stringify it;
802 * otherwise set it to "". Then set targ_len.
806 /* abandon quick route if using targ might have side effects */
807 if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK)))
813 SvPV_force_nomg_nolen(targ);
814 targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
815 if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
816 if (LIKELY(!IN_BYTES))
817 sv_utf8_upgrade_nomg(targ);
820 dst_utf8 |= targ_utf8;
822 targ_len = SvCUR(targ);
823 grow += targ_len * (targ_count + is_append);
826 else if (ckWARN(WARN_UNINITIALIZED))
827 /* warning might have side effects */
829 /* the undef targ will be silently SvPVCLEAR()ed below */
831 else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
832 /* Assigning to some weird LHS type. Don't force the LHS to be an
833 * empty string; instead, do things 'long hand' by using the
834 * overload code path, which concats to a TEMP sv and does
835 * sv_catsv() calls rather than COPY()s. This ensures that even
836 * bizarre code like this doesn't break or crash:
838 * (which makes the 'F' typeglob an alias to the
839 * '*main::F*main::F' typeglob).
844 /* targ was found on RHS.
845 * Force stringify it, using the same code as the append branch
846 * above, except that we don't need the magic/overload/undef
847 * checks as these will already have been done in the phase 1
852 /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
853 * those will be done later. */
854 SV_CHECK_THINKFIRST_COW_DROP(targ);
855 SvUPGRADE(targ, SVt_PV);
856 SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
857 SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
861 /* --------------------------------------------------------------
864 * UTF-8 tweaks and grow targ:
866 * Now that we know the length and utf8-ness of both the targ and
867 * args, grow targ to the size needed to accumulate all the args, based
868 * on whether targ appears on the RHS, whether we're appending, and
869 * whether any non-utf8 args expand in size if converted to utf8.
871 * For the latter, if dst_utf8 we scan non-utf8 args looking for
872 * variant chars, and adjust the svpv->len value of those args to the
873 * utf8 size and negate it to flag them. At the same time we un-negate
874 * the lens of any utf8 args since after this phase we no longer care
875 * whether an arg is utf8 or not.
877 * Finally, initialise const_lens and const_pv based on utf8ness.
878 * Note that there are 3 permutations:
880 * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
881 * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
882 * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
885 * * If the string is fully utf8, e.g. "\x{100}", then
886 * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
887 * one set of segment lengths.
889 * * If the string has different plain and utf8 representations
890 * (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
891 * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
892 * holds the utf8 rep, and there are 2 sets of segment lengths,
893 * with the utf8 set following after the plain set.
895 * On entry to this section the (pv,len) pairs in svpv_buf have the
896 * following meanings:
897 * (pv, len) a plain string
898 * (pv, -len) a utf8 string
899 * (NULL, 0) left-most targ \ linked together R-to-L
900 * (next, 0) other targ / in targ_chain
903 /* turn off utf8 handling if 'use bytes' is in scope */
904 if (UNLIKELY(dst_utf8 && IN_BYTES)) {
907 /* undo all the negative lengths which flag utf8-ness */
908 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
909 SSize_t len = svpv_p->len;
915 /* grow += total of lengths of constant string segments */
918 len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
919 : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
920 slow_concat = cBOOL(len);
924 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
927 const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
928 if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
929 && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
930 /* separate sets of lengths for plain and utf8 */
931 const_lens += nargs + 1;
933 /* If the result is utf8 but some of the args aren't,
934 * calculate how much extra growth is needed for all the chars
935 * which will expand to two utf8 bytes.
936 * Also, if the growth is non-zero, negate the length to indicate
937 * that this is a variant string. Conversely, un-negate the
938 * length on utf8 args (which was only needed to flag non-utf8
939 * args in this loop */
940 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
949 extra = variant_under_utf8_count((U8 *) svpv_p->pv,
950 (U8 *) svpv_p->pv + len);
951 if (UNLIKELY(extra)) {
953 /* -ve len indicates special handling */
954 svpv_p->len = -(len + extra);
960 const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
962 /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
963 * already have been dropped */
964 assert(!SvIsCOW(targ));
965 targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ));
968 /* --------------------------------------------------------------
971 * Now that targ has been grown, we know the final address of the targ
972 * PVX, if needed. Preserve / move targ contents if appending or if
973 * targ appears on RHS.
975 * Also update svpv_buf slots in targ_chain.
977 * Don't bother with any of this if the target length is zero:
978 * targ_len is set to zero unless we're appending or targ appears on
979 * RHS. And even if it is, we can optimise by skipping this chunk of
980 * code for zero targ_len. In the latter case, we don't need to update
981 * the slots in targ_chain with the (zero length) target string, since
982 * we set the len in such slots to 0 earlier, and since the Copy() is
983 * skipped on zero length, it doesn't matter what svpv_p->pv contains.
985 * On entry to this section the (pv,len) pairs in svpv_buf have the
986 * following meanings:
987 * (pv, len) a pure-plain or utf8 string
988 * (pv, -(len+extra)) a plain string which will expand by 'extra'
989 * bytes when converted to utf8
990 * (NULL, 0) left-most targ \ linked together R-to-L
991 * (next, 0) other targ / in targ_chain
993 * On exit, the targ contents will have been moved to the
994 * earliest place they are needed (e.g. $x = "abc$x" will shift them
995 * 3 bytes, while $x .= ... will leave them at the beginning);
996 * and dst_pv will point to the location within SvPVX(targ) where the
997 * next arg should be copied.
1000 svpv_base = svpv_buf;
1003 struct multiconcat_svpv *tc_stop;
1004 char *targ_buf = targ_pv; /* ptr to original targ string */
1006 assert(is_append || targ_count);
1009 targ_pv += targ_len;
1013 /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
1014 * Move the current contents of targ to the first
1015 * position where it's needed, and use that as the src buffer
1016 * for any further uses (such as the second RHS $t above).
1017 * In calculating the first position, we need to sum the
1018 * lengths of all consts and args before that.
1021 UNOP_AUX_item *lens = const_lens;
1022 /* length of first const string segment */
1023 STRLEN offset = lens->ssize > 0 ? lens->ssize : 0;
1031 break; /* the first targ argument */
1032 /* add lengths of the next arg and const string segment */
1034 if (len < 0) /* variant args have this */
1036 offset += (STRLEN)len;
1037 len = (++lens)->ssize;
1038 offset += (len >= 0) ? (STRLEN)len : 0;
1040 /* all args and consts so far are empty; update
1041 * the start position for the concat later */
1046 assert(svpv_p < svpv_end);
1051 Move(targ_pv, targ_buf, targ_len, char);
1052 /* a negative length implies don't Copy(), but do increment */
1053 svpv_p->len = -((SSize_t)targ_len);
1057 /* skip the first targ copy */
1060 targ_pv += targ_len;
1063 /* Don't populate the first targ slot in the loop below; it's
1064 * either not used because we advanced svpv_base beyond it, or
1065 * we already stored the special -targ_len value in it
1070 /* populate slots in svpv_buf representing targ on RHS */
1071 while (targ_chain != tc_stop) {
1072 struct multiconcat_svpv *p = targ_chain;
1073 targ_chain = (struct multiconcat_svpv *)(p->pv);
1075 p->len = (SSize_t)targ_len;
1080 /* --------------------------------------------------------------
1083 * Append all the args in svpv_buf, plus the const strings, to targ.
1085 * On entry to this section the (pv,len) pairs in svpv_buf have the
1086 * following meanings:
1087 * (pv, len) a pure-plain or utf8 string (which may be targ)
1088 * (pv, -(len+extra)) a plain string which will expand by 'extra'
1089 * bytes when converted to utf8
1090 * (0, -len) left-most targ, whose content has already
1091 * been copied. Just advance targ_pv by len.
1094 /* If there are no constant strings and no special case args
1095 * (svpv_p->len < 0), use a simpler, more efficient concat loop
1098 for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
1099 SSize_t len = svpv_p->len;
1102 Copy(svpv_p->pv, targ_pv, len, char);
1105 const_lens += (svpv_end - svpv_base + 1);
1108 /* Note that we iterate the loop nargs+1 times: to append nargs
1109 * arguments and nargs+1 constant strings. For example, "-$a-$b-"
1114 SSize_t len = (const_lens++)->ssize;
1116 /* append next const string segment */
1118 Copy(const_pv, targ_pv, len, char);
1123 if (svpv_p == svpv_end)
1126 /* append next arg */
1129 if (LIKELY(len > 0)) {
1130 Copy(svpv_p->pv, targ_pv, len, char);
1133 else if (UNLIKELY(len < 0)) {
1134 /* negative length indicates two special cases */
1135 const char *p = svpv_p->pv;
1138 /* copy plain-but-variant pv to a utf8 targ */
1139 char * end_pv = targ_pv + len;
1141 while (targ_pv < end_pv) {
1143 append_utf8_from_native_byte(c, (U8**)&targ_pv);
1147 /* arg is already-copied targ */
1156 SvCUR_set(targ, targ_pv - SvPVX(targ));
1157 assert(grow >= SvCUR(targ) + 1);
1158 assert(SvLEN(targ) >= SvCUR(targ) + 1);
1160 /* --------------------------------------------------------------
1171 /* --------------------------------------------------------------
1174 * We only get here if any of the args (or targ too in the case of
1175 * append) have something which might cause side effects, such
1176 * as magic, overload, or an undef value in the presence of warnings.
1177 * In that case, any earlier attempt to stringify the args will have
1178 * been abandoned, and we come here instead.
1180 * Here, we concat each arg in turn the old-fashioned way: essentially
1181 * emulating pp_concat() in a loop. This means that all the weird edge
1182 * cases will be handled correctly, if not necessarily speedily.
1184 * Note that some args may already have been stringified - those are
1185 * processed again, which is safe, since only args without side-effects
1186 * were stringified earlier.
1198 const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1199 SV *csv = NULL; /* SV which will hold cpv */
1200 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
1201 Size_t arg_count = 0; /* how many args have been processed */
1204 cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1208 svp = toparg - nargs + 1;
1212 * plus possible nargs+1 consts,
1213 * plus, if appending, a final targ in an extra last iteration
1217 for (i = 0; i <= n; i++) {
1220 /* if necessary, stringify the final RHS result in
1221 * something like $targ .= "$a$b$c" - simulating
1225 && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY)
1227 /* extra conditions for backwards compatibility:
1228 * probably incorrect, but keep the existing behaviour
1229 * for now. The rules are:
1230 * $x = "$ov" single arg: stringify;
1231 * $x = "$ov$y" multiple args: don't stringify,
1232 * $lex = "$ov$y$z" except TARGMY with at least 2 concats
1237 && (PL_op->op_private & OPpTARGET_MY)
1238 && !(PL_op->op_private & OPpLVAL_INTRO)
1243 assert(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset);
1244 SV *tmp = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset);
1245 sv_copypv(tmp, left);
1250 /* do one extra iteration to handle $targ in $targ .= ... */
1251 if (i == n && !is_append)
1254 /* get the next arg SV or regen the next const SV */
1255 len = lens[i >> 1].ssize;
1257 /* handle the final targ .= (....) */
1262 right = svp[(i >> 1)];
1264 continue; /* no const in this position */
1266 /* Use one of our PADTMPs to fake up the SV which would
1267 * have been returned by an OP_CONST. Try to reuse it if
1268 * possible. If the refcount has gone up, something like
1269 * overload code has taken a reference to it, so abandon
1271 if (!csv || SvREFCNT(csv) > 1 || SvLEN(csv) != 0) {
1273 csv = newSV_type_mortal(SVt_PV);
1275 assert(aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset);
1277 aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset);
1278 SvUPGRADE(csv, SVt_PV);
1286 /* use the const string buffer directly with the
1289 /* cast away constness because we think we know it's safe
1291 SvPV_set(csv, (char *)cpv);
1293 SvCUR_set(csv, len);
1301 if (arg_count <= 1) {
1303 continue; /* need at least two SVs to concat together */
1306 if (arg_count == 2 && i < n) {
1307 /* for the first concat, use one of the PADTMPs to emulate
1308 * the PADTMP from OP_CONST. In later iterations this will
1310 nexttarg = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP0].pad_offset);
1318 /* Handle possible overloading.
1319 * This is basically an unrolled
1320 * tryAMAGICbin_MG(concat_amg, AMGf_assign);
1322 * Perl_try_amagic_bin()
1323 * call, but using left and right rather than SP[-1], SP[0],
1324 * and not relying on OPf_STACKED implying .=
1327 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
1332 if ((SvAMAGIC(left) || SvAMAGIC(right))
1333 /* sprintf doesn't do concat overloading,
1334 * but allow for $x .= sprintf(...)
1336 && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
1340 SV * const tmpsv = amagic_call(left, right, concat_amg,
1341 (nextappend ? AMGf_assign: 0));
1343 /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
1344 * here, which isn't needed as any implicit
1345 * assign done under OPpTARGET_MY is done after
1348 sv_setsv(left, tmpsv);
1357 /* if both args are the same magical value, make one a copy */
1358 if (left == right && SvGMAGICAL(left)) {
1359 SV * targetsv = right;
1360 /* Print the uninitialized warning now, so it includes the
1363 if (ckWARN(WARN_UNINITIALIZED))
1364 report_uninit(right);
1365 targetsv = &PL_sv_no;
1367 left = sv_mortalcopy_flags(targetsv, 0);
1372 /* nexttarg = left . right */
1373 S_do_concat(aTHX_ left, right, nexttarg, 0);
1377 SP = toparg - stack_adj + 1;
1379 /* Return the result of all RHS concats, unless this op includes
1380 * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
1381 * to target (which will be $lex or expr).
1382 * If we are appending, targ will already have been appended to in
1385 && ( (PL_op->op_flags & OPf_STACKED)
1386 || (PL_op->op_private & OPpTARGET_MY))
1388 sv_setsv(targ, left);
1399 /* push the elements of av onto the stack.
1400 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
1403 S_pushav(pTHX_ AV* const av)
1405 const SSize_t maxarg = AvFILL(av) + 1;
1407 if (UNLIKELY(SvRMAGICAL(av))) {
1409 for (i=0; i < (PADOFFSET)maxarg; i++) {
1410 SV ** const svp = av_fetch(av, i, FALSE);
1411 rpp_push_1(LIKELY(svp)
1413 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1421 for (i=0; i < (PADOFFSET)maxarg; i++) {
1422 SV *sv = AvARRAY(av)[i];
1423 rpp_push_1(LIKELY(sv)
1425 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1435 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
1439 PADOFFSET base = PL_op->op_targ;
1440 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
1441 if (PL_op->op_flags & OPf_SPECIAL) {
1442 /* fake the RHS of my ($x,$y,..) = @_ */
1443 PUSHMARK(PL_stack_sp);
1444 (void)S_pushav(aTHX_ GvAVn(PL_defgv));
1447 /* note, this is only skipped for compile-time-known void cxt */
1448 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
1452 PUSHMARK(PL_stack_sp);
1453 for (i = 0; i <count; i++)
1454 rpp_push_1(PAD_SV(base+i));
1457 if (PL_op->op_private & OPpLVAL_INTRO) {
1458 SV **svp = &(PAD_SVl(base));
1459 const UV payload = (UV)(
1460 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1461 | (count << SAVE_TIGHT_SHIFT)
1462 | SAVEt_CLEARPADRANGE);
1465 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
1466 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1474 for (i = 0; i <count; i++)
1475 SvPADSTALE_off(*svp++); /* mark lexical as active */
1484 OP * const op = PL_op;
1485 /* access PL_curpad once */
1486 SV ** const padentry = &(PAD_SVl(op->op_targ));
1492 if (op->op_flags & OPf_MOD) {
1493 if (op->op_private & OPpLVAL_INTRO)
1494 if (!(op->op_private & OPpPAD_STATE))
1495 save_clearsv(padentry);
1496 if (op->op_private & OPpDEREF) {
1497 /* *sp is equivalent to TARG here. Using *sp rather
1498 than TARG reduces the scope of TARG, so it does not
1499 span the call to save_clearsv, resulting in smaller
1502 vivify_ref(*PL_stack_sp, op->op_private & OPpDEREF));
1509 PP_wrapped(pp_readline, ((PL_op->op_flags & OPf_STACKED) ? 2 : 1), 0)
1512 /* pp_coreargs pushes a NULL to indicate no args passed to
1513 * CORE::readline() */
1516 tryAMAGICunTARGETlist(iter_amg, 0);
1517 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1519 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
1520 if (!isGV_with_GP(PL_last_in_gv)) {
1521 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
1522 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
1525 XPUSHs(MUTABLE_SV(PL_last_in_gv));
1527 Perl_pp_rv2gv(aTHX);
1528 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1529 assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
1532 return do_readline();
1535 PP_wrapped(pp_eq, 2, 0)
1539 U32 flags_and, flags_or;
1541 tryAMAGICbin_MG(eq_amg, AMGf_numeric);
1544 flags_and = SvFLAGS(left) & SvFLAGS(right);
1545 flags_or = SvFLAGS(left) | SvFLAGS(right);
1548 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
1549 ? (SvIVX(left) == SvIVX(right))
1550 : (flags_and & SVf_NOK)
1551 ? (SvNVX(left) == SvNVX(right))
1552 : ( do_ncmp(left, right) == 0)
1558 /* also used for: pp_i_preinc() */
1560 PP_wrapped(pp_preinc, 1, 0)
1562 SV *sv = *PL_stack_sp;
1564 if (LIKELY(((sv->sv_flags &
1565 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1566 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1568 && SvIVX(sv) != IV_MAX)
1570 SvIV_set(sv, SvIVX(sv) + 1);
1572 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1579 /* also used for: pp_i_predec() */
1581 PP_wrapped(pp_predec, 1, 0)
1583 SV *sv = *PL_stack_sp;
1585 if (LIKELY(((sv->sv_flags &
1586 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1587 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1589 && SvIVX(sv) != IV_MIN)
1591 SvIV_set(sv, SvIVX(sv) - 1);
1593 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
1600 /* also used for: pp_orassign() */
1602 PP_wrapped(pp_or, 1, 0)
1611 if (PL_op->op_type == OP_OR)
1613 RETURNOP(cLOGOP->op_other);
1618 /* also used for: pp_dor() pp_dorassign() */
1620 PP_wrapped(pp_defined, 1, 0)
1624 bool defined = FALSE;
1625 const int op_type = PL_op->op_type;
1626 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
1630 if (UNLIKELY(!sv || !SvANY(sv))) {
1631 if (op_type == OP_DOR)
1633 RETURNOP(cLOGOP->op_other);
1638 if (UNLIKELY(!sv || !SvANY(sv)))
1642 /* Historically what followed was a switch on SvTYPE(sv), handling SVt_PVAV,
1643 * SVt_PVCV, SVt_PVHV and "default". `defined &sub` is still valid syntax,
1644 * hence we still need the special case PVCV code. But AVs and HVs now
1645 * should never arrive here... */
1647 assert(SvTYPE(sv) != SVt_PVAV);
1648 assert(SvTYPE(sv) != SVt_PVHV);
1651 if (UNLIKELY(SvTYPE(sv) == SVt_PVCV)) {
1652 if (CvROOT(sv) || CvXSUB(sv))
1664 if(op_type == OP_DOR)
1666 RETURNOP(cLOGOP->op_other);
1668 /* assuming OP_DEFINED */
1678 bool useleft; SV *svl, *svr;
1679 SV *targ = (PL_op->op_flags & OPf_STACKED)
1681 : PAD_SV(PL_op->op_targ);
1683 if (rpp_try_AMAGIC_2(add_amg, AMGf_assign|AMGf_numeric))
1686 svr = PL_stack_sp[0];
1687 svl = PL_stack_sp[-1];
1689 #ifdef PERL_PRESERVE_IVUV
1691 /* special-case some simple common cases */
1692 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1694 U32 flags = (svl->sv_flags & svr->sv_flags);
1695 if (flags & SVf_IOK) {
1696 /* both args are simple IVs */
1701 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1702 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1704 /* if both are in a range that can't under/overflow, do a
1705 * simple integer add: if the top of both numbers
1706 * are 00 or 11, then it's safe */
1707 if (!( ((topl+1) | (topr+1)) & 2)) {
1708 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1709 rpp_replace_2_1(targ);
1714 else if (flags & SVf_NOK) {
1715 /* both args are NVs */
1719 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1720 /* nothing was lost by converting to IVs */
1723 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1724 rpp_replace_2_1(targ);
1731 useleft = USE_LEFT(svl);
1732 /* We must see if we can perform the addition with integers if possible,
1733 as the integer code detects overflow while the NV code doesn't.
1734 If either argument hasn't had a numeric conversion yet attempt to get
1735 the IV. It's important to do this now, rather than just assuming that
1736 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1737 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1738 integer in case the second argument is IV=9223372036854775806
1739 We can (now) rely on sv_2iv to do the right thing, only setting the
1740 public IOK flag if the value in the NV (or PV) slot is truly integer.
1742 A side effect is that this also aggressively prefers integer maths over
1743 fp maths for integer values.
1745 How to detect overflow?
1747 C 99 section 6.2.6.1 says
1749 The range of nonnegative values of a signed integer type is a subrange
1750 of the corresponding unsigned integer type, and the representation of
1751 the same value in each type is the same. A computation involving
1752 unsigned operands can never overflow, because a result that cannot be
1753 represented by the resulting unsigned integer type is reduced modulo
1754 the number that is one greater than the largest value that can be
1755 represented by the resulting type.
1759 which I read as "unsigned ints wrap."
1761 signed integer overflow seems to be classed as "exception condition"
1763 If an exceptional condition occurs during the evaluation of an
1764 expression (that is, if the result is not mathematically defined or not
1765 in the range of representable values for its type), the behavior is
1768 (6.5, the 5th paragraph)
1770 I had assumed that on 2s complement machines signed arithmetic would
1771 wrap, hence coded pp_add and pp_subtract on the assumption that
1772 everything perl builds on would be happy. After much wailing and
1773 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1774 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1775 unsigned code below is actually shorter than the old code. :-)
1778 if (SvIV_please_nomg(svr)) {
1779 /* Unless the left argument is integer in range we are going to have to
1780 use NV maths. Hence only attempt to coerce the right argument if
1781 we know the left is integer. */
1788 a_valid = auvok = 1;
1789 /* left operand is undef, treat as zero. + 0 is identity,
1790 Could TARGi or TARGu right now, but space optimise by not
1791 adding lots of code to speed up what is probably a rare-ish
1794 /* Left operand is defined, so is it IV? */
1795 if (SvIV_please_nomg(svl)) {
1796 if ((auvok = SvUOK(svl)))
1799 const IV aiv = SvIVX(svl);
1802 auvok = 1; /* Now acting as a sign flag. */
1804 /* Using 0- here and later to silence bogus warning
1806 auv = (UV) (0 - (UV) aiv);
1813 bool result_good = 0;
1816 bool buvok = SvUOK(svr);
1821 const IV biv = SvIVX(svr);
1826 buv = (UV) (0 - (UV) biv);
1828 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1829 else "IV" now, independent of how it came in.
1830 if a, b represents positive, A, B negative, a maps to -A etc
1835 all UV maths. negate result if A negative.
1836 add if signs same, subtract if signs differ. */
1838 if (auvok ^ buvok) {
1842 /* Must get smaller */
1847 if (result <= buv) {
1848 /* result really should be -(auv-buv). as its negation
1849 of true value, need to swap our result flag */
1865 if (result <= (UV)IV_MIN)
1866 TARGi(result == (UV)IV_MIN
1867 ? IV_MIN : -(IV)result, 1);
1869 /* result valid, but out of range for IV. */
1870 TARGn(-(NV)result, 1);
1873 rpp_replace_2_1(targ);
1875 } /* Overflow, drop through to NVs. */
1880 useleft = USE_LEFT(svl);
1884 NV value = SvNV_nomg(svr);
1886 /* left operand is undef, treat as zero. + 0.0 is identity. */
1890 TARGn(value + SvNV_nomg(svl), 1);
1892 rpp_replace_2_1(targ);
1898 /* also used for: pp_aelemfast_lex() */
1902 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
1903 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
1904 const U32 lval = PL_op->op_flags & OPf_MOD;
1905 const I8 key = (I8)PL_op->op_private;
1909 assert(SvTYPE(av) == SVt_PVAV);
1911 /* inlined av_fetch() for simple cases ... */
1912 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1913 sv = AvARRAY(av)[key];
1922 /* ... else do it the hard way */
1923 svp = av_fetch(av, key, lval);
1924 sv = (svp ? *svp : &PL_sv_undef);
1926 if (UNLIKELY(!svp && lval))
1927 DIE(aTHX_ PL_no_aelem, (int)key);
1929 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
1937 PP_wrapped(pp_join, 0, 1)
1939 dSP; dMARK; dTARGET;
1941 do_join(TARG, *MARK, MARK, SP);
1947 /* Oversized hot code. */
1949 /* also used for: pp_say() */
1951 PP_wrapped(pp_print, 0, 1)
1953 dSP; dMARK; dORIGMARK;
1957 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1961 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1964 if (MARK == ORIGMARK) {
1965 /* If using default handle then we need to make space to
1966 * pass object as 1st arg, so move other args up ...
1970 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1973 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
1975 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1976 | (PL_op->op_type == OP_SAY
1977 ? TIED_METHOD_SAY : 0)), sp - mark);
1980 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
1981 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1984 SETERRNO(EBADF,RMS_IFI);
1987 else if (!(fp = IoOFP(io))) {
1989 report_wrongway_fh(gv, '<');
1992 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1996 SV * const ofs = GvSV(PL_ofsgv); /* $, */
1998 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
1999 while (MARK <= SP) {
2000 if (!do_print(*MARK, fp))
2004 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
2005 if (!do_print(GvSV(PL_ofsgv), fp)) {
2013 while (MARK <= SP) {
2014 if (!do_print(*MARK, fp))
2022 if (PL_op->op_type == OP_SAY) {
2023 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
2026 else if (PL_ors_sv && SvOK(PL_ors_sv))
2027 if (!do_print(PL_ors_sv, fp)) /* $\ */
2030 if (IoFLAGS(io) & IOf_FLUSH)
2031 if (PerlIO_flush(fp) == EOF)
2041 XPUSHs(&PL_sv_undef);
2046 /* do the common parts of pp_padhv() and pp_rv2hv()
2047 * It assumes the caller has done rpp_extend(1) or equivalent.
2048 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
2049 * 'has_targ' indicates that the op has a target - this should
2050 * be a compile-time constant so that the code can constant-folded as
2051 * appropriate. has_targ also implies that the caller has left an
2052 * arg on the stack which needs freeing.
2055 PERL_STATIC_INLINE OP*
2056 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
2058 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
2060 if (gimme == G_LIST) {
2061 /* push all (key,value) pairs onto stack */
2062 if (has_targ) { /* i.e. if has arg still on stack */
2063 #ifdef PERL_RC_STACK
2064 SSize_t sp_base = PL_stack_sp - PL_stack_base;
2066 /* Now safe to free the original arg on the stack and shuffle
2067 * down one place anything pushed on top of it */
2068 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
2069 SV *old_sv = PL_stack_sp[-nitems];
2071 Move(PL_stack_sp - nitems + 1,
2072 PL_stack_sp - nitems, nitems, SV*);
2074 SvREFCNT_dec_NN(old_sv);
2086 /* 'keys %h' masquerading as '%h': reset iterator */
2087 (void)hv_iterinit(hv);
2089 if (gimme == G_VOID) {
2095 bool is_bool = ( PL_op->op_private & OPpTRUEBOOL
2096 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
2097 && block_gimme() == G_VOID));
2099 MAGIC *is_tied_mg = SvRMAGICAL(hv)
2100 ? mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied)
2105 if (UNLIKELY(is_tied_mg)) {
2106 if (is_keys && !is_bool) {
2108 while (hv_iternext(hv))
2110 /* hv finished with. Safe to free arg now */
2116 sv = magic_scalarpack(hv, is_tied_mg);
2117 /* hv finished with. Safe to free arg now */
2124 #if defined(DYNAMIC_ENV_FETCH) && defined(VMS)
2125 /* maybe nothing set up %ENV for iteration yet...
2126 do this always (not just if HvUSEDKEYS(hv) is currently 0) because
2127 we ought to give a *consistent* answer to "how many keys?"
2128 whether we ask this op in scalar context, or get the list of all
2129 keys then check its length, and whether we do either with or without
2130 an %ENV lookup first. prime_env_iter() returns quickly if nothing
2132 if (SvRMAGICAL((const SV *)hv)
2133 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2139 /* hv finished with. Safe to free arg now */
2144 sv = i ? &PL_sv_yes : &PL_sv_zero;
2157 /* parent op should be an unused OP_KEYS whose targ we can
2162 assert(!OpHAS_SIBLING(PL_op));
2163 k = PL_op->op_sibparent;
2164 assert(k->op_type == OP_KEYS);
2165 TARG = PAD_SV(k->op_targ);
2170 rpp_push_1_norc(newSViv(i));
2178 /* This is also called directly by pp_lvavref. */
2184 assert(SvTYPE(TARG) == SVt_PVAV);
2185 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
2186 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
2187 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
2190 if (PL_op->op_flags & OPf_REF)
2193 if (PL_op->op_private & OPpMAYBE_LVSUB) {
2194 const I32 flags = is_lvalue_sub();
2195 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2196 if (GIMME_V == G_SCALAR)
2197 /* diag_listed_as: Can't return %s to lvalue scalar context */
2198 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
2204 if (gimme == G_LIST)
2205 return S_pushav(aTHX_ (AV*)TARG);
2207 if (gimme == G_VOID)
2211 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
2214 else if (PL_op->op_private & OPpTRUEBOOL)
2218 rpp_push_1_norc(newSViv(maxarg));
2234 assert(SvTYPE(TARG) == SVt_PVHV);
2235 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
2236 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
2237 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
2241 if (PL_op->op_flags & OPf_REF) {
2245 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
2246 const I32 flags = is_lvalue_sub();
2247 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2248 if (GIMME_V == G_SCALAR)
2249 /* diag_listed_as: Can't return %s to lvalue scalar context */
2250 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
2258 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
2259 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
2264 /* also used for: pp_rv2hv() */
2265 /* also called directly by pp_lvavref */
2269 SV *sv = *PL_stack_sp;
2270 const U8 gimme = GIMME_V;
2271 static const char an_array[] = "an ARRAY";
2272 static const char a_hash[] = "a HASH";
2273 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
2274 || PL_op->op_type == OP_LVAVREF;
2275 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
2279 if (UNLIKELY(SvAMAGIC(sv))) {
2280 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
2283 if (UNLIKELY(SvTYPE(sv) != type))
2284 /* diag_listed_as: Not an ARRAY reference */
2285 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
2286 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
2287 && PL_op->op_private & OPpLVAL_INTRO))
2288 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
2290 else if (UNLIKELY(SvTYPE(sv) != type)) {
2293 if (!isGV_with_GP(sv)) {
2294 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
2300 gv = MUTABLE_GV(sv);
2302 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
2303 if (PL_op->op_private & OPpLVAL_INTRO)
2304 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
2306 if (PL_op->op_flags & OPf_REF) {
2307 rpp_replace_1_1(sv);
2310 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
2311 const I32 flags = is_lvalue_sub();
2312 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2313 if (gimme != G_LIST)
2314 goto croak_cant_return;
2315 rpp_replace_1_1(sv);
2321 AV *const av = MUTABLE_AV(sv);
2323 if (gimme == G_LIST) {
2324 #ifdef PERL_RC_STACK
2325 SSize_t sp_base = PL_stack_sp - PL_stack_base;
2326 (void)S_pushav(aTHX_ av);
2327 /* Now safe to free the original arg on the stack and shuffle
2328 * down one place anything pushed on top of it */
2329 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
2330 SV *old_sv = PL_stack_sp[-nitems];
2332 Move(PL_stack_sp - nitems + 1,
2333 PL_stack_sp - nitems, nitems, SV*);
2335 SvREFCNT_dec_NN(old_sv);
2339 return S_pushav(aTHX_ av);
2343 if (gimme == G_SCALAR) {
2344 const SSize_t maxarg = AvFILL(av) + 1;
2345 if (PL_op->op_private & OPpTRUEBOOL)
2346 rpp_replace_1_1(maxarg ? &PL_sv_yes : &PL_sv_zero);
2350 rpp_replace_1_1(targ);
2355 /* this static function is responsible for popping sv off stack */
2356 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
2357 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2363 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2364 is_pp_rv2av ? "array" : "hash");
2369 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
2371 PERL_ARGS_ASSERT_DO_ODDBALL;
2374 if (ckWARN(WARN_MISC)) {
2376 if (oddkey == firstkey &&
2378 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2379 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
2381 err = "Reference found where even-sized list expected";
2384 err = "Odd number of elements in hash assignment";
2385 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
2392 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2393 * are common to both the LHS and RHS of an aassign, and replace them
2394 * with copies. All these copies are made before the actual list assign is
2397 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2398 * element ($b) to the first LH element ($a), modifies $a; when the
2399 * second assignment is done, the second RH element now has the wrong
2400 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2401 * Note that we don't need to make a mortal copy of $b.
2403 * The algorithm below works by, for every RHS element, mark the
2404 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2405 * element is found with SVf_BREAK set, it means it would have been
2406 * modified, so make a copy.
2407 * Note that by scanning both LHS and RHS in lockstep, we avoid
2408 * unnecessary copies (like $b above) compared with a naive
2409 * "mark all LHS; copy all marked RHS; unmark all LHS".
2411 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2412 * it can't be common and can be skipped.
2414 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2415 * that we thought we didn't need to call S_aassign_copy_common(), but we
2416 * have anyway for sanity checking. If we find we need to copy, then panic.
2419 PERL_STATIC_INLINE void
2420 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
2421 SV **firstrelem, SV **lastrelem
2429 SSize_t lcount = lastlelem - firstlelem + 1;
2430 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2431 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
2432 bool copy_all = FALSE;
2434 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2435 assert(firstlelem < lastlelem); /* at least 2 LH elements */
2436 assert(firstrelem < lastrelem); /* at least 2 RH elements */
2440 /* we never have to copy the first RH element; it can't be corrupted
2441 * by assigning something to the corresponding first LH element.
2442 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2444 relem = firstrelem + 1;
2446 for (; relem <= lastrelem; relem++) {
2449 /* mark next LH element */
2451 if (--lcount >= 0) {
2454 if (UNLIKELY(!svl)) {/* skip AV alias marker */
2455 assert (lelem <= lastlelem);
2461 if (SvSMAGICAL(svl)) {
2464 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2467 /* this LH element will consume all further args;
2468 * no need to mark any further LH elements (if any).
2469 * But we still need to scan any remaining RHS elements;
2470 * set lcount negative to distinguish from lcount == 0,
2471 * so the loop condition continues being true
2474 lelem--; /* no need to unmark this element */
2476 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
2477 SvFLAGS(svl) |= SVf_BREAK;
2481 /* don't check RH element if no SVf_BREAK flags set yet */
2488 /* see if corresponding RH element needs copying */
2494 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
2495 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
2499 /* op_dump(PL_op); */
2501 "panic: aassign skipped needed copy of common RH elem %"
2502 UVuf, (UV)(relem - firstrelem));
2506 TAINT_NOT; /* Each item is independent */
2508 /* Dear TODO test in t/op/sort.t, I love you.
2509 (It's relying on a panic, not a "semi-panic" from newSVsv()
2510 and then an assertion failure below.) */
2511 if (UNLIKELY(SvIS_FREED(svr))) {
2512 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2515 /* avoid break flag while copying; otherwise COW etc
2517 SvFLAGS(svr) &= ~SVf_BREAK;
2518 /* Not newSVsv(), as it does not allow copy-on-write,
2519 resulting in wasteful copies.
2520 Also, we use SV_NOSTEAL in case the SV is used more than
2521 once, e.g. (...) = (f())[0,0]
2522 Where the same SV appears twice on the RHS without a ref
2523 count bump. (Although I suspect that the SV won't be
2524 stealable here anyway - DAPM).
2526 *relem = sv_mortalcopy_flags(svr,
2527 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2528 /* ... but restore afterwards in case it's needed again,
2529 * e.g. ($a,$b,$c) = (1,$a,$a)
2531 SvFLAGS(svr) |= brk;
2543 while (lelem > firstlelem) {
2544 SV * const svl = *(--lelem);
2546 SvFLAGS(svl) &= ~SVf_BREAK;
2552 PP_wrapped(pp_aassign, 0, 2)
2555 SV **lastlelem = PL_stack_sp;
2556 SV **lastrelem = PL_stack_base + POPMARK;
2557 SV **firstrelem = PL_stack_base + POPMARK + 1;
2558 SV **firstlelem = lastrelem + 1;
2563 /* PL_delaymagic is restored by JMPENV_POP on dieing, so we
2564 * only need to save locally, not on the save stack */
2565 U16 old_delaymagic = PL_delaymagic;
2570 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
2572 /* If there's a common identifier on both sides we have to take
2573 * special care that assigning the identifier on the left doesn't
2574 * clobber a value on the right that's used later in the list.
2577 /* at least 2 LH and RH elements, or commonality isn't an issue */
2578 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2579 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2580 if (SvGMAGICAL(*relem))
2583 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2584 if (*lelem && SvSMAGICAL(*lelem))
2587 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2588 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2589 /* skip the scan if all scalars have a ref count of 1 */
2590 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2592 if (!sv || SvREFCNT(sv) == 1)
2594 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2601 S_aassign_copy_common(aTHX_
2602 firstlelem, lastlelem, firstrelem, lastrelem
2612 /* on debugging builds, do the scan even if we've concluded we
2613 * don't need to, then panic if we find commonality. Note that the
2614 * scanner assumes at least 2 elements */
2615 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2626 if (relem > lastrelem)
2629 /* first lelem loop while there are still relems */
2630 while (LIKELY(lelem <= lastlelem)) {
2634 TAINT_NOT; /* Each item stands on its own, taintwise. */
2636 assert(relem <= lastrelem);
2637 if (UNLIKELY(!lsv)) {
2640 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2643 switch (SvTYPE(lsv)) {
2648 SSize_t nelems = lastrelem - relem + 1;
2649 AV *ary = MUTABLE_AV(lsv);
2651 /* Assigning to an aggregate is tricky. First there is the
2652 * issue of commonality, e.g. @a = ($a[0]). Since the
2653 * stack isn't refcounted, clearing @a prior to storing
2654 * elements will free $a[0]. Similarly with
2655 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2657 * The way to avoid these issues is to make the copy of each
2658 * SV (and we normally store a *copy* in the array) *before*
2659 * clearing the array. But this has a problem in that
2660 * if the code croaks during copying, the not-yet-stored copies
2661 * could leak. One way to avoid this is to make all the copies
2662 * mortal, but that's quite expensive.
2664 * The current solution to these issues is to use a chunk
2665 * of the tmps stack as a temporary refcounted-stack. SVs
2666 * will be put on there during processing to avoid leaks,
2667 * but will be removed again before the end of this block,
2668 * so free_tmps() is never normally called. Also, the
2669 * sv_refcnt of the SVs doesn't have to be manipulated, since
2670 * the ownership of 1 reference count is transferred directly
2671 * from the tmps stack to the AV when the SV is stored.
2673 * We disarm slots in the temps stack by storing PL_sv_undef
2674 * there: it doesn't matter if that SV's refcount is
2675 * repeatedly decremented during a croak. But usually this is
2676 * only an interim measure. By the end of this code block
2677 * we try where possible to not leave any PL_sv_undef's on the
2678 * tmps stack e.g. by shuffling newer entries down.
2680 * There is one case where we don't copy: non-magical
2681 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2682 * is on the tmps stack, so its safe to directly steal the SV
2683 * rather than copying. This is common in things like function
2684 * returns, map etc, which all return a list of such SVs.
2686 * Note however something like @a = (f())[0,0], where there is
2687 * a danger of the same SV being shared: this avoided because
2688 * when the SV is stored as $a[0], its ref count gets bumped,
2689 * so the RC==1 test fails and the second element is copied
2692 * We also use one slot in the tmps stack to hold an extra
2693 * ref to the array, to ensure it doesn't get prematurely
2694 * freed. Again, this is removed before the end of this block.
2696 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2697 * @a = ($a[0]) case, but the current implementation uses the
2698 * same algorithm regardless, so ignores that flag. (It *is*
2699 * used in the hash branch below, however).
2702 /* Reserve slots for ary, plus the elems we're about to copy,
2703 * then protect ary and temporarily void the remaining slots
2704 * with &PL_sv_undef */
2705 EXTEND_MORTAL(nelems + 1);
2706 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2707 tmps_base = PL_tmps_ix + 1;
2708 for (i = 0; i < nelems; i++)
2709 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2710 PL_tmps_ix += nelems;
2712 /* Make a copy of each RHS elem and save on the tmps_stack
2713 * (or pass through where we can optimise away the copy) */
2715 if (UNLIKELY(alias)) {
2716 U32 lval = (gimme == G_LIST)
2717 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
2718 for (svp = relem; svp <= lastrelem; svp++) {
2723 DIE(aTHX_ "Assigned value is not a reference");
2724 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2725 /* diag_listed_as: Assigned value is not %s reference */
2727 "Assigned value is not a SCALAR reference");
2729 *svp = rsv = sv_mortalcopy(rsv);
2730 /* XXX else check for weak refs? */
2731 rsv = SvREFCNT_inc_NN(SvRV(rsv));
2732 assert(tmps_base <= PL_tmps_max);
2733 PL_tmps_stack[tmps_base++] = rsv;
2737 for (svp = relem; svp <= lastrelem; svp++) {
2740 if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) {
2741 /* can skip the copy */
2742 SvREFCNT_inc_simple_void_NN(rsv);
2747 /* see comment in S_aassign_copy_common about
2749 nsv = newSVsv_flags(rsv,
2750 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
2754 assert(tmps_base <= PL_tmps_max);
2755 PL_tmps_stack[tmps_base++] = rsv;
2759 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2762 /* store in the array, the SVs that are in the tmps stack */
2764 tmps_base -= nelems;
2766 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
2767 /* for arrays we can't cheat with, use the official API */
2768 av_extend(ary, nelems - 1);
2769 for (i = 0; i < nelems; i++) {
2770 SV **svp = &(PL_tmps_stack[tmps_base + i]);
2772 /* A tied store won't take ownership of rsv, so keep
2773 * the 1 refcnt on the tmps stack; otherwise disarm
2774 * the tmps stack entry */
2775 if (av_store(ary, i, rsv))
2776 *svp = &PL_sv_undef;
2777 /* av_store() may have added set magic to rsv */;
2780 /* disarm ary refcount: see comments below about leak */
2781 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2784 /* directly access/set the guts of the AV */
2785 SSize_t fill = nelems - 1;
2786 if (fill > AvMAX(ary))
2787 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2789 AvFILLp(ary) = fill;
2790 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2791 /* Quietly remove all the SVs from the tmps stack slots,
2792 * since ary has now taken ownership of the refcnt.
2793 * Also remove ary: which will now leak if we die before
2794 * the SvREFCNT_dec_NN(ary) below */
2795 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2796 Move(&PL_tmps_stack[tmps_base + nelems],
2797 &PL_tmps_stack[tmps_base - 1],
2798 PL_tmps_ix - (tmps_base + nelems) + 1,
2800 PL_tmps_ix -= (nelems + 1);
2803 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2804 /* its assumed @ISA set magic can't die and leak ary */
2805 SvSETMAGIC(MUTABLE_SV(ary));
2806 SvREFCNT_dec_NN(ary);
2808 relem = lastrelem + 1;
2812 case SVt_PVHV: { /* normal hash */
2818 SSize_t nelems = lastrelem - relem + 1;
2819 HV *hash = MUTABLE_HV(lsv);
2821 if (UNLIKELY(nelems & 1)) {
2822 do_oddball(lastrelem, relem);
2823 /* we have firstlelem to reuse, it's not needed any more */
2824 *++lastrelem = &PL_sv_undef;
2828 /* See the SVt_PVAV branch above for a long description of
2829 * how the following all works. The main difference for hashes
2830 * is that we treat keys and values separately (and have
2831 * separate loops for them): as for arrays, values are always
2832 * copied (except for the SvTEMP optimisation), since they
2833 * need to be stored in the hash; while keys are only
2834 * processed where they might get prematurely freed or
2837 /* tmps stack slots:
2838 * * reserve a slot for the hash keepalive;
2839 * * reserve slots for the hash values we're about to copy;
2840 * * preallocate for the keys we'll possibly copy or refcount bump
2842 * then protect hash and temporarily void the remaining
2843 * value slots with &PL_sv_undef */
2844 EXTEND_MORTAL(nelems + 1);
2846 /* convert to number of key/value pairs */
2849 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2850 tmps_base = PL_tmps_ix + 1;
2851 for (i = 0; i < nelems; i++)
2852 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2853 PL_tmps_ix += nelems;
2855 /* Make a copy of each RHS hash value and save on the tmps_stack
2856 * (or pass through where we can optimise away the copy) */
2858 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2861 if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) {
2862 /* can skip the copy */
2863 SvREFCNT_inc_simple_void_NN(rsv);
2868 /* see comment in S_aassign_copy_common about
2870 nsv = newSVsv_flags(rsv,
2871 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
2875 assert(tmps_base <= PL_tmps_max);
2876 PL_tmps_stack[tmps_base++] = rsv;
2878 tmps_base -= nelems;
2881 /* possibly protect keys */
2883 if (UNLIKELY(gimme == G_LIST)) {
2885 * @a = ((%h = ($$r, 1)), $r = "x");
2886 * $_++ for %h = (1,2,3,4);
2888 EXTEND_MORTAL(nelems);
2889 for (svp = relem; svp <= lastrelem; svp += 2)
2890 *svp = sv_mortalcopy_flags(*svp,
2891 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2893 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2894 /* for possible commonality, e.g.
2896 * avoid premature freeing RHS keys by mortalising
2898 * For a magic element, make a copy so that its magic is
2899 * called *before* the hash is emptied (which may affect
2900 * a tied value for example).
2901 * In theory we should check for magic keys in all
2902 * cases, not just under OPpASSIGN_COMMON_AGG, but in
2903 * practice, !OPpASSIGN_COMMON_AGG implies only
2904 * constants or padtmps on the RHS.
2906 EXTEND_MORTAL(nelems);
2907 for (svp = relem; svp <= lastrelem; svp += 2) {
2909 if (UNLIKELY(SvGMAGICAL(rsv))) {
2911 *svp = sv_mortalcopy_flags(*svp,
2912 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2913 /* allow other branch to continue pushing
2914 * onto tmps stack without checking each time */
2915 n = (lastrelem - relem) >> 1;
2919 PL_tmps_stack[++PL_tmps_ix] =
2920 SvREFCNT_inc_simple_NN(rsv);
2924 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2927 /* "nelems" was converted to the number of pairs earlier. */
2928 if (nelems > PERL_HASH_DEFAULT_HvMAX) {
2929 hv_ksplit(hash, nelems);
2932 /* now assign the keys and values to the hash */
2936 if (UNLIKELY(gimme == G_LIST)) {
2937 /* @a = (%h = (...)) etc */
2939 SV **topelem = relem;
2941 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2944 /* remove duplicates from list we return */
2945 if (!hv_exists_ent(hash, key, 0)) {
2946 /* copy key back: possibly to an earlier
2947 * stack location if we encountered dups earlier,
2948 * The values will be updated later
2953 /* A tied store won't take ownership of val, so keep
2954 * the 1 refcnt on the tmps stack; otherwise disarm
2955 * the tmps stack entry */
2956 if (hv_store_ent(hash, key, val, 0))
2957 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2960 /* hv_store_ent() may have added set magic to val */;
2963 if (topelem < svp) {
2964 /* at this point we have removed the duplicate key/value
2965 * pairs from the stack, but the remaining values may be
2966 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
2967 * the (a 2), but the stack now probably contains
2968 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
2969 * obliterates the earlier key. So refresh all values. */
2970 lastrelem = topelem - 1;
2971 while (relem < lastrelem) {
2973 he = hv_fetch_ent(hash, *relem++, 0, 0);
2974 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
2980 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2983 if (hv_store_ent(hash, key, val, 0))
2984 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2987 /* hv_store_ent() may have added set magic to val */;
2993 /* there are still some 'live' recounts on the tmps stack
2994 * - usually caused by storing into a tied hash. So let
2995 * free_tmps() do the proper but slow job later.
2996 * Just disarm hash refcount: see comments below about leak
2998 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
3001 /* Quietly remove all the SVs from the tmps stack slots,
3002 * since hash has now taken ownership of the refcnt.
3003 * Also remove hash: which will now leak if we die before
3004 * the SvREFCNT_dec_NN(hash) below */
3005 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
3006 Move(&PL_tmps_stack[tmps_base + nelems],
3007 &PL_tmps_stack[tmps_base - 1],
3008 PL_tmps_ix - (tmps_base + nelems) + 1,
3010 PL_tmps_ix -= (nelems + 1);
3013 SvREFCNT_dec_NN(hash);
3015 relem = lastrelem + 1;
3020 if (!SvIMMORTAL(lsv)) {
3024 rpp_is_lone(lsv) && !SvSMAGICAL(lsv) &&
3025 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
3028 packWARN(WARN_MISC),
3029 "Useless assignment to a temporary"
3032 /* avoid freeing $$lsv if it might be needed for further
3033 * elements, e.g. ($ref, $foo) = (1, $$ref) */
3035 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
3036 && lelem <= lastlelem
3039 SvREFCNT_inc_simple_void_NN(ref);
3040 /* an unrolled sv_2mortal */
3042 if (UNLIKELY(ix >= PL_tmps_max))
3043 /* speculatively grow enough to cover other
3045 (void)tmps_grow_p(ix + (lastlelem - lelem));
3046 PL_tmps_stack[ix] = ref;
3049 sv_setsv(lsv, *relem);
3053 if (++relem > lastrelem)
3062 /* simplified lelem loop for when there are no relems left */
3063 while (LIKELY(lelem <= lastlelem)) {
3066 TAINT_NOT; /* Each item stands on its own, taintwise. */
3068 if (UNLIKELY(!lsv)) {
3070 ASSUME(SvTYPE(lsv) == SVt_PVAV);
3073 switch (SvTYPE(lsv)) {
3075 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
3077 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
3083 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
3088 if (!SvIMMORTAL(lsv)) {
3097 TAINT_NOT; /* result of list assign isn't tainted */
3099 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
3100 /* Will be used to set PL_tainting below */
3101 Uid_t tmp_uid = PerlProc_getuid();
3102 Uid_t tmp_euid = PerlProc_geteuid();
3103 Gid_t tmp_gid = PerlProc_getgid();
3104 Gid_t tmp_egid = PerlProc_getegid();
3106 /* XXX $> et al currently silently ignore failures */
3107 if (PL_delaymagic & DM_UID) {
3108 #ifdef HAS_SETRESUID
3110 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
3111 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
3113 #elif defined(HAS_SETREUID)
3115 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
3116 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
3119 if ((PL_delaymagic & DM_UID) == DM_RUID) {
3120 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
3121 PL_delaymagic &= ~DM_RUID;
3123 # endif /* HAS_SETRUID */
3125 if ((PL_delaymagic & DM_UID) == DM_EUID) {
3126 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
3127 PL_delaymagic &= ~DM_EUID;
3129 # endif /* HAS_SETEUID */
3130 if (PL_delaymagic & DM_UID) {
3131 if (PL_delaymagic_uid != PL_delaymagic_euid)
3132 DIE(aTHX_ "No setreuid available");
3133 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
3135 #endif /* HAS_SETRESUID */
3137 tmp_uid = PerlProc_getuid();
3138 tmp_euid = PerlProc_geteuid();
3140 /* XXX $> et al currently silently ignore failures */
3141 if (PL_delaymagic & DM_GID) {
3142 #ifdef HAS_SETRESGID
3144 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
3145 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
3147 #elif defined(HAS_SETREGID)
3149 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
3150 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
3153 if ((PL_delaymagic & DM_GID) == DM_RGID) {
3154 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
3155 PL_delaymagic &= ~DM_RGID;
3157 # endif /* HAS_SETRGID */
3159 if ((PL_delaymagic & DM_GID) == DM_EGID) {
3160 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
3161 PL_delaymagic &= ~DM_EGID;
3163 # endif /* HAS_SETEGID */
3164 if (PL_delaymagic & DM_GID) {
3165 if (PL_delaymagic_gid != PL_delaymagic_egid)
3166 DIE(aTHX_ "No setregid available");
3167 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
3169 #endif /* HAS_SETRESGID */
3171 tmp_gid = PerlProc_getgid();
3172 tmp_egid = PerlProc_getegid();
3174 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
3175 #ifdef NO_TAINT_SUPPORT
3176 PERL_UNUSED_VAR(tmp_uid);
3177 PERL_UNUSED_VAR(tmp_euid);
3178 PERL_UNUSED_VAR(tmp_gid);
3179 PERL_UNUSED_VAR(tmp_egid);
3182 PL_delaymagic = old_delaymagic;
3184 if (gimme == G_VOID)
3185 SP = firstrelem - 1;
3186 else if (gimme == G_SCALAR) {
3189 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
3190 SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
3193 SETi(firstlelem - firstrelem);
3204 PMOP * const pm = cPMOP;
3205 REGEXP * rx = PM_GETRE(pm);
3206 regexp *prog = ReANY(rx);
3207 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
3208 SV * const rv = newSV_type_mortal(SVt_IV);
3212 SvUPGRADE(rv, SVt_IV);
3213 /* For a subroutine describing itself as "This is a hacky workaround" I'm
3214 loathe to use it here, but it seems to be the right fix. Or close.
3215 The key part appears to be that it's essential for pp_qr to return a new
3216 object (SV), which implies that there needs to be an effective way to
3217 generate a new SV from the existing SV that is pre-compiled in the
3219 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
3222 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
3223 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
3224 *cvp = cv_clone(cv);
3225 SvREFCNT_dec_NN(cv);
3229 HV *const stash = gv_stashsv(pkg, GV_ADD);
3230 SvREFCNT_dec_NN(pkg);
3231 (void)sv_bless(rv, stash);
3234 if (UNLIKELY(RXp_ISTAINTED(prog))) {
3236 SvTAINTED_on(SvRV(rv));
3243 S_are_we_in_Debug_EXECUTE_r(pTHX)
3245 /* Given a 'use re' is in effect, does it ask for outputting execution
3248 * This is separated from the sole place it's called, an inline function,
3249 * because it is the large-ish slow portion of the function */
3251 DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX;
3253 return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK));
3256 PERL_STATIC_INLINE bool
3257 S_should_we_output_Debug_r(pTHX_ regexp *prog)
3259 PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R;
3261 /* pp_match can output regex debugging info. This function returns a
3262 * boolean as to whether or not it should.
3264 * Under -Dr, it should. Any reasonable compiler will optimize this bit of
3265 * code away on non-debugging builds. */
3266 if (UNLIKELY(DEBUG_r_TEST)) {
3270 /* If the regex engine is using the non-debugging execution routine, then
3271 * no debugging should be output. Same if the field is NULL that pluggable
3272 * engines are not supposed to fill. */
3273 if ( LIKELY(prog->engine->exec == &Perl_regexec_flags)
3274 || UNLIKELY(prog->engine->op_comp == NULL))
3279 /* Otherwise have to check */
3280 return S_are_we_in_Debug_EXECUTE_r(aTHX);
3283 PP_wrapped(pp_match, ((PL_op->op_flags & OPf_STACKED) ? 1 : 0), 0)
3290 SSize_t curpos = 0; /* initial pos() or current $+[0] */
3293 const char *truebase; /* Start of string */
3294 REGEXP *rx = PM_GETRE(pm);
3295 regexp *prog = ReANY(rx);
3297 const U8 gimme = GIMME_V;
3299 const I32 oldsave = PL_savestack_ix;
3300 I32 had_zerolen = 0;
3303 if (PL_op->op_flags & OPf_STACKED)
3314 PUTBACK; /* EVAL blocks need stack_sp. */
3315 /* Skip get-magic if this is a qr// clone, because regcomp has
3317 truebase = prog->mother_re
3318 ? SvPV_nomg_const(TARG, len)
3319 : SvPV_const(TARG, len);
3321 DIE(aTHX_ "panic: pp_match");
3322 strend = truebase + len;
3323 rxtainted = (RXp_ISTAINTED(prog) ||
3324 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
3327 /* We need to know this in case we fail out early - pos() must be reset */
3328 global = dynpm->op_pmflags & PMf_GLOBAL;
3330 /* PMdf_USED is set after a ?? matches once */
3333 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
3335 pm->op_pmflags & PMf_USED
3338 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3339 PerlIO_printf(Perl_debug_log, "?? already matched once");
3344 /* handle the empty pattern */
3345 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
3346 if (PL_curpm == PL_reg_curpm) {
3347 if (PL_curpm_under) {
3348 if (PL_curpm_under == PL_reg_curpm) {
3349 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3351 pm = PL_curpm_under;
3361 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
3362 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3363 PerlIO_printf(Perl_debug_log,
3364 "String shorter than min possible regex match (%zd < %zd)\n",
3365 len, RXp_MINLEN(prog));
3370 /* get pos() if //g */
3372 mg = mg_find_mglob(TARG);
3373 if (mg && mg->mg_len >= 0) {
3374 curpos = MgBYTEPOS(mg, TARG, truebase, len);
3375 /* last time pos() was set, it was zero-length match */
3376 if (mg->mg_flags & MGf_MINMATCH)
3381 #ifdef PERL_SAWAMPERSAND
3382 if ( RXp_NPARENS(prog)
3384 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3385 || (dynpm->op_pmflags & PMf_KEEPCOPY)
3389 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
3390 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
3391 * only on the first iteration. Therefore we need to copy $' as well
3392 * as $&, to make the rest of the string available for captures in
3393 * subsequent iterations */
3394 if (! (global && gimme == G_LIST))
3395 r_flags |= REXEC_COPY_SKIP_POST;
3397 #ifdef PERL_SAWAMPERSAND
3398 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3399 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3400 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3407 s = truebase + curpos;
3409 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
3410 had_zerolen, TARG, NULL, r_flags))
3414 if (dynpm->op_pmflags & PMf_ONCE)
3416 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
3418 dynpm->op_pmflags |= PMf_USED;
3422 RXp_MATCH_TAINTED_on(prog);
3423 TAINT_IF(RXp_MATCH_TAINTED(prog));
3427 if (global && (gimme != G_LIST || (dynpm->op_pmflags & PMf_CONTINUE))) {
3429 mg = sv_magicext_mglob(TARG);
3430 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS_END(prog,0));
3431 if (RXp_ZERO_LEN(prog))
3432 mg->mg_flags |= MGf_MINMATCH;
3434 mg->mg_flags &= ~MGf_MINMATCH;
3437 if ((!RXp_NPARENS(prog) && !global) || gimme != G_LIST) {
3438 LEAVE_SCOPE(oldsave);
3442 /* push captures on stack */
3445 const I32 logical_nparens = RXp_LOGICAL_NPARENS(prog);
3446 /* This following statement is *devious* code. If we are in a global
3447 match and the pattern has no parens in it we should return $&
3448 (offset pair 0). So we set logical_paren to 1 when we should return
3449 $&, otherwise we set it to 0.
3451 This allows us to simply add logical_nparens to logical_paren to
3452 compute the number of elements we are going to return.
3454 In the loop intit we "not" it with: logical_paren = !logical_paren
3455 which results in it being 0 inside the loop when we want to return
3456 $&, and results in it being 1 when we want to return the parens.
3457 Thus we either loop over 1..logical_nparens, or just over 0.
3459 This is an elegant way to do this code wise, but is super devious
3460 and potentially confusing. When I first saw this logic I thought
3461 "WTF?". But it makes sense after you poke it a while.
3463 Frankly I probably would have done it differently, but it works so
3464 I am leaving it. - Yves */
3465 I32 logical_paren = (global && !logical_nparens) ? 1 : 0;
3466 I32 *l2p = RXp_LOGICAL_TO_PARNO(prog);
3467 /* this is used to step through the physical parens associated
3468 * with a given logical paren. */
3469 I32 *p2l_next = RXp_PARNO_TO_LOGICAL_NEXT(prog);
3471 SPAGAIN; /* EVAL blocks could move the stack. */
3472 EXTEND(SP, logical_nparens + logical_paren); /* devious code ... */
3473 EXTEND_MORTAL(logical_nparens + logical_paren); /* ... see above */
3475 /* loop over the logical parens in the pattern. This may not
3476 correspond to the actual paren checked, as branch reset may
3477 mean that there is more than one paren "behind" the logical
3478 parens. Eg, in /(?|(a)|(b))/ there are two parens, but one
3480 for (logical_paren = !logical_paren;
3481 logical_paren <= logical_nparens;
3484 /* now convert the logical_paren to the physical parens which
3485 are "behind" it. If branch reset was not used then
3486 physical_paren and logical_paren are the same as each other
3487 and we will only perform one iteration of the loop */
3488 I32 phys_paren = l2p ? l2p[logical_paren] : logical_paren;
3489 SSize_t offs_start, offs_end;
3490 /* We check the loop invariants below and break out of the loop
3491 explicitly if our checks fail, so we use while (1) here to
3492 avoid double testing a conditional. */
3494 /* Check end offset first, as the start might be >=0 even
3495 though the end is -1, so testing the end first helps
3496 use avoid the start check. Really we should be able to
3497 get away with ONLY testing the end, but testing both
3498 doesn't hurt much and preserves sanity. */
3499 if (((offs_end = RXp_OFFS_END(prog, phys_paren)) != -1) &&
3500 ((offs_start = RXp_OFFS_START(prog, phys_paren)) != -1))
3502 const SSize_t len = offs_end - offs_start;
3503 const char * const s = offs_start + truebase;
3504 if ( UNLIKELY( len < 0 || len > strend - s) ) {
3505 DIE(aTHX_ "panic: pp_match start/end pointers, paren=%" I32df ", "
3506 "start=%zd, end=%zd, s=%p, strend=%p, len=%zd",
3507 phys_paren, offs_start, offs_end, s, strend, len);
3509 PUSHs(newSVpvn_flags(s, len,
3515 } else if (!p2l_next || !(phys_paren = p2l_next[phys_paren])) {
3516 /* Either logical_paren and phys_paren are the same and
3517 we won't have a p2l_next, or they aren't the same (and
3518 we do have a p2l_next) but we have exhausted the list
3519 of physical parens associated with this logical paren.
3520 Either way we are done, and we can push undef and break
3522 PUSHs(sv_newmortal());
3528 curpos = (UV)RXp_OFFS_END(prog,0);
3529 had_zerolen = RXp_ZERO_LEN(prog);
3530 PUTBACK; /* EVAL blocks may use stack */
3531 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
3534 LEAVE_SCOPE(oldsave);
3537 NOT_REACHED; /* NOTREACHED */
3540 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
3542 mg = mg_find_mglob(TARG);
3546 LEAVE_SCOPE(oldsave);
3547 if (gimme == G_LIST)
3553 Perl_do_readline(pTHX)
3555 dSP; dTARGETSTACKED;
3560 IO * const io = GvIO(PL_last_in_gv);
3561 const I32 type = PL_op->op_type;
3562 const U8 gimme = GIMME_V;
3565 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
3567 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
3568 if (gimme == G_SCALAR) {
3570 SvSetSV_nosteal(TARG, TOPs);
3580 if (IoFLAGS(io) & IOf_ARGV) {
3581 if (IoFLAGS(io) & IOf_START) {
3583 if (av_count(GvAVn(PL_last_in_gv)) == 0) {
3584 IoFLAGS(io) &= ~IOf_START;
3585 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
3586 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
3587 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3588 SvSETMAGIC(GvSV(PL_last_in_gv));
3593 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3594 if (!fp) { /* Note: fp != IoIFP(io) */
3595 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
3598 else if (type == OP_GLOB)
3599 fp = Perl_start_glob(aTHX_ POPs, io);
3601 else if (type == OP_GLOB)
3603 else if (IoTYPE(io) == IoTYPE_WRONLY) {
3604 report_wrongway_fh(PL_last_in_gv, '>');
3608 if ((!io || !(IoFLAGS(io) & IOf_START))
3609 && ckWARN(WARN_CLOSED)
3612 report_evil_fh(PL_last_in_gv);
3614 if (gimme == G_SCALAR) {
3615 /* undef TARG, and push that undefined value */
3616 if (type != OP_RCATLINE) {
3624 if (gimme == G_SCALAR) {
3626 if (type == OP_RCATLINE && SvGMAGICAL(sv))
3629 if (type == OP_RCATLINE)
3630 SvPV_force_nomg_nolen(sv);
3634 else if (isGV_with_GP(sv)) {
3635 SvPV_force_nomg_nolen(sv);
3637 SvUPGRADE(sv, SVt_PV);
3638 tmplen = SvLEN(sv); /* remember if already alloced */
3639 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
3640 /* try short-buffering it. Please update t/op/readline.t
3641 * if you change the growth length.
3646 if (type == OP_RCATLINE && SvOK(sv)) {
3648 SvPV_force_nomg_nolen(sv);
3654 sv = sv_2mortal(newSV(80));
3658 /* This should not be marked tainted if the fp is marked clean */
3659 #define MAYBE_TAINT_LINE(io, sv) \
3660 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3665 /* delay EOF state for a snarfed empty file */
3666 #define SNARF_EOF(gimme,rs,io,sv) \
3667 (gimme != G_SCALAR || SvCUR(sv) \
3668 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
3672 if (!sv_gets(sv, fp, offset)
3674 || SNARF_EOF(gimme, PL_rs, io, sv)
3675 || PerlIO_error(fp)))
3677 if (IoFLAGS(io) & IOf_ARGV) {
3678 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3682 (void)do_close(PL_last_in_gv, FALSE);
3684 else if (type == OP_GLOB) {
3685 /* clear any errors here so we only fail on the pclose()
3686 failing, which should only happen on the child
3689 PerlIO_clearerr(fp);
3690 if (!do_close(PL_last_in_gv, FALSE)) {
3691 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3692 "glob failed (child exited with status %d%s)",
3693 (int)(STATUS_CURRENT >> 8),
3694 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
3697 if (gimme == G_SCALAR) {
3698 if (type != OP_RCATLINE) {
3699 SV_CHECK_THINKFIRST_COW_DROP(TARG);
3705 MAYBE_TAINT_LINE(io, sv);
3708 MAYBE_TAINT_LINE(io, sv);
3710 IoFLAGS(io) |= IOf_NOLINE;
3714 if (type == OP_GLOB) {
3718 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
3719 char * const tmps = SvEND(sv) - 1;
3720 if (*tmps == *SvPVX_const(PL_rs)) {
3722 SvCUR_set(sv, SvCUR(sv) - 1);
3725 for (t1 = SvPVX_const(sv); *t1; t1++)
3727 if (memCHRs("*%?", *t1))
3729 if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1))
3732 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
3733 (void)POPs; /* Unmatched wildcard? Chuck it... */
3736 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
3737 if (ckWARN(WARN_UTF8)) {
3738 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3739 const STRLEN len = SvCUR(sv) - offset;
3742 if (!is_utf8_string_loc(s, len, &f))
3743 /* Emulate :encoding(utf8) warning in the same case. */
3744 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3745 "utf8 \"\\x%02X\" does not map to Unicode",
3746 f < (U8*)SvEND(sv) ? *f : 0);
3749 if (gimme == G_LIST) {
3750 if (SvLEN(sv) - SvCUR(sv) > 20) {
3751 SvPV_shrink_to_cur(sv);
3753 sv = sv_2mortal(newSV(80));
3756 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
3757 /* try to reclaim a bit of scalar space (only on 1st alloc) */
3758 const STRLEN new_len
3759 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
3760 SvPV_renew(sv, new_len);
3766 PP_wrapped(pp_helem, 2, 0)
3771 SV * const keysv = POPs;
3772 HV * const hv = MUTABLE_HV(POPs);
3773 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3774 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3776 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3777 bool preeminent = TRUE;
3779 if (SvTYPE(hv) != SVt_PVHV)
3786 /* Try to preserve the existence of a tied hash
3787 * element by using EXISTS and DELETE if possible.
3788 * Fall back to FETCH and STORE otherwise. */
3789 if (SvCANEXISTDELETE(hv))
3790 preeminent = hv_exists_ent(hv, keysv, 0);
3793 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3794 svp = he ? &HeVAL(he) : NULL;
3796 if (!svp || !*svp || *svp == &PL_sv_undef) {
3800 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3802 lv = newSV_type_mortal(SVt_PVLV);
3804 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
3805 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
3806 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3812 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
3813 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
3814 else if (preeminent)
3815 save_helem_flags(hv, keysv, svp,
3816 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3818 SAVEHDELETE(hv, keysv);
3820 else if (PL_op->op_private & OPpDEREF) {
3821 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3825 sv = (svp && *svp ? *svp : &PL_sv_undef);
3826 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3827 * was to make C<local $tied{foo} = $tied{foo}> possible.
3828 * However, it seems no longer to be needed for that purpose, and
3829 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3830 * would loop endlessly since the pos magic is getting set on the
3831 * mortal copy and lost. However, the copy has the effect of
3832 * triggering the get magic, and losing it altogether made things like
3833 * c<$tied{foo};> in void context no longer do get magic, which some
3834 * code relied on. Also, delayed triggering of magic on @+ and friends
3835 * meant the original regex may be out of scope by now. So as a
3836 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3837 * being called too many times). */
3838 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
3845 /* a stripped-down version of Perl_softref2xv() for use by
3846 * pp_multideref(), which doesn't use PL_op->op_flags */
3849 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3852 if (PL_op->op_private & HINT_STRICT_REFS) {
3854 Perl_die(aTHX_ PL_no_symref_sv, sv,
3855 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3857 Perl_die(aTHX_ PL_no_usym, what);
3860 Perl_die(aTHX_ PL_no_usym, what);
3861 return gv_fetchsv_nomg(sv, GV_ADD, type);
3865 /* how many stack arguments a multideref op expects */
3866 #ifdef PERL_RC_STACK
3868 S_multideref_argcount(pTHX)
3870 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3871 UV actions = items->uv;
3874 switch (actions & MDEREF_ACTION_MASK) {
3875 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3876 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
3887 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
3888 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
3890 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
3891 * Each of these either contains a set of actions, or an argument, such as
3892 * an IV to use as an array index, or a lexical var to retrieve.
3893 * Several actions are stored per UV; we keep shifting new actions off the
3894 * one UV, and only reload when it becomes zero.
3897 PP_wrapped(pp_multideref, S_multideref_argcount(aTHX), 0)
3899 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3900 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3901 UV actions = items->uv;
3904 /* this tells find_uninit_var() where we're up to */
3905 PL_multideref_pc = items;
3908 /* there are three main classes of action; the first retrieves
3909 * the initial AV or HV from a variable or the stack; the second
3910 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3911 * the third an unrolled (/DREFHV, rv2hv, helem).
3913 switch (actions & MDEREF_ACTION_MASK) {
3916 actions = (++items)->uv;
3919 case MDEREF_AV_padav_aelem: /* $lex[...] */
3920 sv = PAD_SVl((++items)->pad_offset);
3923 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
3924 sv = UNOP_AUX_item_sv(++items);
3925 assert(isGV_with_GP(sv));
3926 sv = (SV*)GvAVn((GV*)sv);
3929 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3934 goto do_AV_rv2av_aelem;
3937 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
3938 sv = UNOP_AUX_item_sv(++items);
3939 assert(isGV_with_GP(sv));
3940 sv = GvSVn((GV*)sv);
3941 goto do_AV_vivify_rv2av_aelem;
3943 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
3944 sv = PAD_SVl((++items)->pad_offset);
3947 do_AV_vivify_rv2av_aelem:
3948 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
3949 /* this is the OPpDEREF action normally found at the end of
3950 * ops like aelem, helem, rv2sv */
3951 sv = vivify_ref(sv, OPpDEREF_AV);
3955 /* this is basically a copy of pp_rv2av when it just has the
3958 if (LIKELY(SvROK(sv))) {
3959 if (UNLIKELY(SvAMAGIC(sv))) {
3960 sv = amagic_deref_call(sv, to_av_amg);
3963 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3964 DIE(aTHX_ "Not an ARRAY reference");
3966 else if (SvTYPE(sv) != SVt_PVAV) {
3967 if (!isGV_with_GP(sv))
3968 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3969 sv = MUTABLE_SV(GvAVn((GV*)sv));
3975 /* retrieve the key; this may be either a lexical or package
3976 * var (whose index/ptr is stored as an item) or a signed
3977 * integer constant stored as an item.
3980 IV elem = 0; /* to shut up stupid compiler warnings */
3983 assert(SvTYPE(sv) == SVt_PVAV);
3985 switch (actions & MDEREF_INDEX_MASK) {
3986 case MDEREF_INDEX_none:
3988 case MDEREF_INDEX_const:
3989 elem = (++items)->iv;
3991 case MDEREF_INDEX_padsv:
3992 elemsv = PAD_SVl((++items)->pad_offset);
3994 case MDEREF_INDEX_gvsv:
3995 elemsv = UNOP_AUX_item_sv(++items);
3996 assert(isGV_with_GP(elemsv));
3997 elemsv = GvSVn((GV*)elemsv);
3999 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
4000 && ckWARN(WARN_MISC)))
4001 Perl_warner(aTHX_ packWARN(WARN_MISC),
4002 "Use of reference \"%" SVf "\" as array index",
4004 /* the only time that S_find_uninit_var() needs this
4005 * is to determine which index value triggered the
4006 * undef warning. So just update it here. Note that
4007 * since we don't save and restore this var (e.g. for
4008 * tie or overload execution), its value will be
4009 * meaningless apart from just here */
4010 PL_multideref_pc = items;
4011 elem = SvIV(elemsv);
4016 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
4018 if (!(actions & MDEREF_FLAG_last)) {
4019 SV** svp = av_fetch((AV*)sv, elem, 1);
4020 if (!svp || ! (sv=*svp))
4021 DIE(aTHX_ PL_no_aelem, elem);
4025 if (PL_op->op_private &
4026 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
4028 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
4029 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
4032 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
4033 sv = av_delete((AV*)sv, elem, discard);
4041 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4042 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4043 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4044 bool preeminent = TRUE;
4045 AV *const av = (AV*)sv;
4048 if (UNLIKELY(localizing)) {
4052 /* Try to preserve the existence of a tied array
4053 * element by using EXISTS and DELETE if possible.
4054 * Fall back to FETCH and STORE otherwise. */
4055 if (SvCANEXISTDELETE(av))
4056 preeminent = av_exists(av, elem);
4059 svp = av_fetch(av, elem, lval && !defer);
4062 if (!svp || !(sv = *svp)) {
4065 DIE(aTHX_ PL_no_aelem, elem);
4066 len = av_top_index(av);
4067 /* Resolve a negative index that falls within
4068 * the array. Leave it negative it if falls
4069 * outside the array. */
4070 if (elem < 0 && len + elem >= 0)
4072 if (elem >= 0 && elem <= len)
4073 /* Falls within the array. */
4074 sv = av_nonelem(av,elem);
4076 /* Falls outside the array. If it is neg-
4077 ative, magic_setdefelem will use the
4078 index for error reporting. */
4079 sv = sv_2mortal(newSVavdefelem(av,elem,1));
4082 if (UNLIKELY(localizing)) {
4084 save_aelem(av, elem, svp);
4085 sv = *svp; /* may have changed */
4088 SAVEADELETE(av, elem);
4093 sv = (svp ? *svp : &PL_sv_undef);
4094 /* see note in pp_helem() */
4095 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
4112 case MDEREF_HV_padhv_helem: /* $lex{...} */
4113 sv = PAD_SVl((++items)->pad_offset);
4116 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
4117 sv = UNOP_AUX_item_sv(++items);
4118 assert(isGV_with_GP(sv));
4119 sv = (SV*)GvHVn((GV*)sv);
4122 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
4127 goto do_HV_rv2hv_helem;
4130 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
4131 sv = UNOP_AUX_item_sv(++items);
4132 assert(isGV_with_GP(sv));
4133 sv = GvSVn((GV*)sv);
4134 goto do_HV_vivify_rv2hv_helem;
4136 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
4137 sv = PAD_SVl((++items)->pad_offset);
4140 do_HV_vivify_rv2hv_helem:
4141 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
4142 /* this is the OPpDEREF action normally found at the end of
4143 * ops like aelem, helem, rv2sv */
4144 sv = vivify_ref(sv, OPpDEREF_HV);
4148 /* this is basically a copy of pp_rv2hv when it just has the
4149 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
4152 if (LIKELY(SvROK(sv))) {
4153 if (UNLIKELY(SvAMAGIC(sv))) {
4154 sv = amagic_deref_call(sv, to_hv_amg);
4157 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
4158 DIE(aTHX_ "Not a HASH reference");
4160 else if (SvTYPE(sv) != SVt_PVHV) {
4161 if (!isGV_with_GP(sv))
4162 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
4163 sv = MUTABLE_SV(GvHVn((GV*)sv));
4169 /* retrieve the key; this may be either a lexical / package
4170 * var or a string constant, whose index/ptr is stored as an
4173 SV *keysv = NULL; /* to shut up stupid compiler warnings */
4175 assert(SvTYPE(sv) == SVt_PVHV);
4177 switch (actions & MDEREF_INDEX_MASK) {
4178 case MDEREF_INDEX_none:
4181 case MDEREF_INDEX_const:
4182 keysv = UNOP_AUX_item_sv(++items);
4185 case MDEREF_INDEX_padsv:
4186 keysv = PAD_SVl((++items)->pad_offset);
4189 case MDEREF_INDEX_gvsv:
4190 keysv = UNOP_AUX_item_sv(++items);
4191 keysv = GvSVn((GV*)keysv);
4195 /* see comment above about setting this var */
4196 PL_multideref_pc = items;
4199 /* ensure that candidate CONSTs have been HEKified */
4200 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
4201 || SvTYPE(keysv) >= SVt_PVMG
4204 || SvIsCOW_shared_hash(keysv));
4206 /* this is basically a copy of pp_helem with OPpDEREF skipped */
4208 if (!(actions & MDEREF_FLAG_last)) {
4209 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
4210 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
4211 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4215 if (PL_op->op_private &
4216 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
4218 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
4219 sv = hv_exists_ent((HV*)sv, keysv, 0)
4220 ? &PL_sv_yes : &PL_sv_no;
4223 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
4224 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
4232 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4233 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4234 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4235 bool preeminent = TRUE;
4237 HV * const hv = (HV*)sv;
4240 if (UNLIKELY(localizing)) {
4244 /* Try to preserve the existence of a tied hash
4245 * element by using EXISTS and DELETE if possible.
4246 * Fall back to FETCH and STORE otherwise. */
4247 if (SvCANEXISTDELETE(hv))
4248 preeminent = hv_exists_ent(hv, keysv, 0);
4251 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
4252 svp = he ? &HeVAL(he) : NULL;
4256 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
4260 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4261 lv = newSV_type_mortal(SVt_PVLV);
4263 sv_magic(lv, key2 = newSVsv(keysv),
4264 PERL_MAGIC_defelem, NULL, 0);
4265 /* sv_magic() increments refcount */
4266 SvREFCNT_dec_NN(key2);
4267 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
4273 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
4274 save_gp(MUTABLE_GV(sv),
4275 !(PL_op->op_flags & OPf_SPECIAL));
4276 else if (preeminent) {
4277 save_helem_flags(hv, keysv, svp,
4278 (PL_op->op_flags & OPf_SPECIAL)
4279 ? 0 : SAVEf_SETMAGIC);
4280 sv = *svp; /* may have changed */
4283 SAVEHDELETE(hv, keysv);
4288 sv = (svp && *svp ? *svp : &PL_sv_undef);
4289 /* see note in pp_helem() */
4290 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
4299 actions >>= MDEREF_SHIFT;
4307 PERL_CONTEXT *cx = CX_CUR();
4308 SV **itersvp = CxITERVAR(cx);
4309 const U8 type = CxTYPE(cx);
4311 /* Classic "for" syntax iterates one-at-a-time.
4312 Many-at-a-time for loops are only for lexicals declared as part of the
4313 for loop, and rely on all the lexicals being in adjacent pad slots.
4315 Curiously, even if the iterator variable is a lexical, the pad offset is
4316 stored in the targ slot of the ENTERITER op, meaning that targ of this OP
4317 has always been zero. Hence we can use this op's targ to hold "how many"
4318 for many-at-a-time. We actually store C<how_many - 1>, so that for the
4319 case of one-at-a-time we have zero (as before), as this makes all the
4320 logic of the for loop below much simpler, with all the other
4321 one-at-a-time cases just falling out of this "naturally". */
4322 PADOFFSET how_many = PL_op->op_targ;
4327 for (; i <= how_many; ++i ) {
4336 case CXt_LOOP_LAZYSV: /* string increment */
4338 SV* cur = cx->blk_loop.state_u.lazysv.cur;
4339 SV *end = cx->blk_loop.state_u.lazysv.end;
4340 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
4341 It has SvPVX of "" and SvCUR of 0, which is what we want. */
4343 const char *max = SvPV_const(end, maxlen);
4344 bool pad_it = FALSE;
4345 if (DO_UTF8(end) && IN_UNI_8_BIT)
4346 maxlen = sv_len_utf8_nomg(end);
4347 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen)) {
4351 /* We are looping n-at-a-time and the range isn't a multiple
4352 of n, so we fill the rest of the lexicals with undef.
4353 This only happens on the last iteration of the loop, and
4354 we will have already set up the "terminate next time"
4355 condition earlier in this for loop for this call of the
4356 ITER op when we set up the lexical corresponding to the
4357 last value in the range. Hence we don't goto retno (yet),
4358 and just below we don't repeat the setup for "terminate
4364 /* NB: on the first iteration, oldsv will have a ref count of at
4365 * least 2 (one extra from blk_loop.itersave), so the GV or pad
4366 * slot will get localised; on subsequent iterations the RC==1
4367 * optimisation may kick in and the SV will be reused. */
4368 if (UNLIKELY(pad_it)) {
4369 *itersvp = &PL_sv_undef;
4370 SvREFCNT_dec(oldsv);
4372 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
4373 /* safe to reuse old SV */
4374 sv_setsv(oldsv, cur);
4377 /* we need a fresh SV every time so that loop body sees a
4378 * completely new SV for closures/references to work as
4380 *itersvp = newSVsv(cur);
4381 SvREFCNT_dec(oldsv);
4384 if (UNLIKELY(pad_it)) {
4385 /* We're "beyond the end" of the iterator here, filling the
4386 extra lexicals with undef, so we mustn't do anything
4387 (further) to the iterator itself at this point.
4388 (Observe how the other two blocks modify the iterator's
4391 else if (strEQ(SvPVX_const(cur), max))
4392 sv_setiv(cur, 0); /* terminate next time */
4398 case CXt_LOOP_LAZYIV: /* integer increment */
4400 IV cur = cx->blk_loop.state_u.lazyiv.cur;
4401 bool pad_it = FALSE;
4402 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) {
4410 /* see NB comment above */
4411 if (UNLIKELY(pad_it)) {
4412 *itersvp = &PL_sv_undef;
4413 SvREFCNT_dec(oldsv);
4415 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
4416 /* safe to reuse old SV */
4418 if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
4420 /* Cheap SvIOK_only().
4421 * Assert that flags which SvIOK_only() would test or
4422 * clear can't be set, because we're SVt_IV */
4423 assert(!(SvFLAGS(oldsv) &
4424 (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
4425 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
4426 /* SvIV_set() where sv_any points to head */
4427 oldsv->sv_u.svu_iv = cur;
4431 sv_setiv(oldsv, cur);
4434 /* we need a fresh SV every time so that loop body sees a
4435 * completely new SV for closures/references to work as they
4437 *itersvp = newSViv(cur);
4438 SvREFCNT_dec(oldsv);
4441 if (UNLIKELY(pad_it)) {
4442 /* We're good (see "We are looping n-at-a-time" comment
4445 else if (UNLIKELY(cur == IV_MAX)) {
4446 /* Handle end of range at IV_MAX */
4447 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
4449 ++cx->blk_loop.state_u.lazyiv.cur;
4453 case CXt_LOOP_LIST: /* for (1,2,3) */
4455 assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
4456 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
4457 ix = (cx->blk_loop.state_u.stack.ix += inc);
4458 if (UNLIKELY(inc > 0
4459 ? ix > cx->blk_oldsp
4460 : ix <= cx->blk_loop.state_u.stack.basesp)
4469 sv = PL_stack_base[ix];
4473 goto loop_ary_common;
4475 case CXt_LOOP_ARY: /* for (@ary) */
4477 av = cx->blk_loop.state_u.ary.ary;
4478 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
4479 ix = (cx->blk_loop.state_u.ary.ix += inc);
4480 if (UNLIKELY(inc > 0
4489 } else if (UNLIKELY(SvRMAGICAL(av))) {
4490 SV * const * const svp = av_fetch(av, ix, FALSE);
4491 sv = svp ? *svp : NULL;
4494 sv = AvARRAY(av)[ix];
4499 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
4500 SvSetMagicSV(*itersvp, sv);
4505 if (UNLIKELY(SvIS_FREED(sv))) {
4507 Perl_croak(aTHX_ "Use of freed value in iteration");
4514 SvREFCNT_inc_simple_void_NN(sv);
4518 sv = newSVavdefelem(av, ix, 0);
4525 SvREFCNT_dec(oldsv);
4529 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
4532 /* Only relevant for a many-at-a-time loop: */
4536 /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead
4537 * jump straight to the AND op's op_other */
4538 assert(PL_op->op_next->op_type == OP_AND);
4539 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4540 return cLOGOPx(PL_op->op_next)->op_other;
4543 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4545 /* pp_enteriter should have pre-extended the stack */
4546 EXTEND_SKIP(PL_stack_sp, 1);
4547 *++PL_stack_sp = &PL_sv_yes;
4548 return PL_op->op_next;
4552 /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead
4553 * jump straight to the AND op's op_next */
4554 assert(PL_op->op_next->op_type == OP_AND);
4555 /* pp_enteriter should have pre-extended the stack */
4556 EXTEND_SKIP(PL_stack_sp, 1);
4557 /* we only need this for the rare case where the OP_AND isn't
4558 * in void context, e.g. $x = do { for (..) {...} };
4559 * (or for when an XS module has replaced the op_ppaddr)
4560 * but it's cheaper to just push it rather than testing first
4562 *++PL_stack_sp = &PL_sv_no;
4563 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4564 return PL_op->op_next->op_next;
4567 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4569 return PL_op->op_next;
4575 A description of how taint works in pattern matching and substitution.
4577 This is all conditional on NO_TAINT_SUPPORT remaining undefined (the default).
4578 Under NO_TAINT_SUPPORT, taint-related operations should become no-ops.
4580 While the pattern is being assembled/concatenated and then compiled,
4581 PL_tainted will get set (via TAINT_set) if any component of the pattern
4582 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
4583 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
4584 TAINT_get). It will also be set if any component of the pattern matches
4585 based on locale-dependent behavior.
4587 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
4588 the pattern is marked as tainted. This means that subsequent usage, such
4589 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
4590 on the new pattern too.
4592 RXf_TAINTED_SEEN is used post-execution by the get magic code
4593 of $1 et al to indicate whether the returned value should be tainted.
4594 It is the responsibility of the caller of the pattern (i.e. pp_match,
4595 pp_subst etc) to set this flag for any other circumstances where $1 needs
4598 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
4600 There are three possible sources of taint
4602 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
4603 * the replacement string (or expression under /e)
4605 There are four destinations of taint and they are affected by the sources
4606 according to the rules below:
4608 * the return value (not including /r):
4609 tainted by the source string and pattern, but only for the
4610 number-of-iterations case; boolean returns aren't tainted;
4611 * the modified string (or modified copy under /r):
4612 tainted by the source string, pattern, and replacement strings;
4614 tainted by the pattern, and under 'use re "taint"', by the source
4616 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
4617 should always be unset before executing subsequent code.
4619 The overall action of pp_subst is:
4621 * at the start, set bits in rxtainted indicating the taint status of
4622 the various sources.
4624 * After each pattern execution, update the SUBST_TAINT_PAT bit in
4625 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
4626 pattern has subsequently become tainted via locale ops.
4628 * If control is being passed to pp_substcont to execute a /e block,
4629 save rxtainted in the CXt_SUBST block, for future use by
4632 * Whenever control is being returned to perl code (either by falling
4633 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
4634 use the flag bits in rxtainted to make all the appropriate types of
4635 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
4636 et al will appear tainted.
4638 pp_match is just a simpler version of the above.
4642 PP_wrapped(pp_subst, ((PL_op->op_flags & OPf_STACKED) ? 2 : 1), 0)
4654 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
4655 See "how taint works" above */
4658 REGEXP *rx = PM_GETRE(pm);
4659 regexp *prog = ReANY(rx);
4661 int force_on_match = 0;
4662 const I32 oldsave = PL_savestack_ix;
4663 bool doutf8 = FALSE; /* whether replacement is in utf8 */
4668 /* known replacement string? */
4669 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
4673 if (PL_op->op_flags & OPf_STACKED)
4684 SvGETMAGIC(TARG); /* must come before cow check */
4686 /* note that a string might get converted to COW during matching */
4687 was_cow = cBOOL(SvIsCOW(TARG));
4689 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4690 #ifndef PERL_ANY_COW
4692 sv_force_normal_flags(TARG,0);
4694 if ((SvREADONLY(TARG)
4695 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
4696 || SvTYPE(TARG) > SVt_PVLV)
4697 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
4698 Perl_croak_no_modify();
4702 orig = SvPV_nomg(TARG, len);
4703 /* note we don't (yet) force the var into being a string; if we fail
4704 * to match, we leave as-is; on successful match however, we *will*
4705 * coerce into a string, then repeat the match */
4706 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
4709 /* only replace once? */
4710 once = !(rpm->op_pmflags & PMf_GLOBAL);
4712 /* See "how taint works" above */
4715 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
4716 | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
4717 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
4718 | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4719 || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0));
4725 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
4727 strend = orig + len;
4728 /* We can match twice at each position, once with zero-length,
4729 * second time with non-zero.
4730 * Don't handle utf8 specially; we can use length-in-bytes as an
4731 * upper bound on length-in-characters, and avoid the cpu-cost of
4732 * computing a tighter bound. */
4733 maxiters = 2 * len + 10;
4735 /* handle the empty pattern */
4736 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
4737 if (PL_curpm == PL_reg_curpm) {
4738 if (PL_curpm_under) {
4739 if (PL_curpm_under == PL_reg_curpm) {
4740 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
4742 pm = PL_curpm_under;
4752 #ifdef PERL_SAWAMPERSAND
4753 r_flags = ( RXp_NPARENS(prog)
4755 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
4756 || (rpm->op_pmflags & PMf_KEEPCOPY)
4761 r_flags = REXEC_COPY_STR;
4764 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
4767 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
4768 LEAVE_SCOPE(oldsave);
4773 /* known replacement string? */
4775 /* replacement needing upgrading? */
4776 if (DO_UTF8(TARG) && !doutf8) {
4777 nsv = sv_newmortal();
4779 sv_utf8_upgrade(nsv);
4780 c = SvPV_const(nsv, clen);
4784 c = SvPV_const(dstr, clen);
4785 doutf8 = DO_UTF8(dstr);
4788 if (UNLIKELY(TAINT_get))
4789 rxtainted |= SUBST_TAINT_REPL;
4796 /* can do inplace substitution? */
4801 && (SSize_t)clen <= RXp_MINLENRET(prog)
4803 || !(r_flags & REXEC_COPY_STR)
4804 || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
4806 && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
4807 && (!doutf8 || SvUTF8(TARG))
4808 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4812 /* string might have got converted to COW since we set was_cow */
4813 if (SvIsCOW(TARG)) {
4814 if (!force_on_match)
4816 assert(SvVOK(TARG));
4819 if (force_on_match) {
4820 /* redo the first match, this time with the orig var
4821 * forced into being a string */
4823 orig = SvPV_force_nomg(TARG, len);
4829 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4830 rxtainted |= SUBST_TAINT_PAT;
4831 m = orig + RXp_OFFS_START(prog,0);
4832 d = orig + RXp_OFFS_END(prog,0);
4834 if (m - s > strend - d) { /* faster to shorten from end */
4837 Copy(c, m, clen, char);
4842 Move(d, m, i, char);
4846 SvCUR_set(TARG, m - s);
4848 else { /* faster from front */
4852 Move(s, d - i, i, char);
4855 Copy(c, d, clen, char);
4862 d = s = RXp_OFFS_START(prog,0) + orig;
4865 if (UNLIKELY(iters++ > maxiters))
4866 DIE(aTHX_ "Substitution loop");
4867 /* run time pattern taint, eg locale */
4868 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4869 rxtainted |= SUBST_TAINT_PAT;
4870 m = RXp_OFFS_START(prog,0) + orig;
4873 Move(s, d, i, char);
4877 Copy(c, d, clen, char);
4880 s = RXp_OFFS_END(prog,0) + orig;
4881 } while (CALLREGEXEC(rx, s, strend, orig,
4882 s == m, /* don't match same null twice */
4884 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4886 SSize_t i = strend - s;
4887 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
4888 Move(s, d, i+1, char); /* include the NUL */
4892 if (PL_op->op_private & OPpTRUEBOOL)
4902 if (force_on_match) {
4903 /* redo the first match, this time with the orig var
4904 * forced into being a string */
4906 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4907 /* I feel that it should be possible to avoid this mortal copy
4908 given that the code below copies into a new destination.
4909 However, I suspect it isn't worth the complexity of
4910 unravelling the C<goto force_it> for the small number of
4911 cases where it would be viable to drop into the copy code. */
4912 TARG = sv_2mortal(newSVsv(TARG));
4914 orig = SvPV_force_nomg(TARG, len);
4920 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4921 rxtainted |= SUBST_TAINT_PAT;
4923 s = RXp_OFFS_START(prog,0) + orig;
4924 dstr = newSVpvn_flags(orig, s-orig,
4925 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
4930 /* note that a whole bunch of local vars are saved here for
4931 * use by pp_substcont: here's a list of them in case you're
4932 * searching for places in this sub that uses a particular var:
4933 * iters maxiters r_flags oldsave rxtainted orig dstr targ
4934 * s m strend rx once */
4936 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
4940 if (UNLIKELY(iters++ > maxiters))
4941 DIE(aTHX_ "Substitution loop");
4942 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4943 rxtainted |= SUBST_TAINT_PAT;
4944 if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
4946 char *old_orig = orig;
4947 assert(RXp_SUBOFFSET(prog) == 0);
4949 orig = RXp_SUBBEG(prog);
4950 s = orig + (old_s - old_orig);
4951 strend = s + (strend - old_s);
4953 m = RXp_OFFS_START(prog,0) + orig;
4954 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
4955 s = RXp_OFFS_END(prog,0) + orig;
4957 /* replacement already stringified */
4959 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
4963 sv_catsv(dstr, repl);
4967 } while (CALLREGEXEC(rx, s, strend, orig,
4968 s == m, /* Yields minend of 0 or 1 */
4970 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4971 assert(strend >= s);
4972 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
4974 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4975 /* From here on down we're using the copy, and leaving the original
4982 /* The match may make the string COW. If so, brilliant, because
4983 that's just saved us one malloc, copy and free - the regexp has
4984 donated the old buffer, and we malloc an entirely new one, rather
4985 than the regexp malloc()ing a buffer and copying our original,
4986 only for us to throw it away here during the substitution. */
4987 if (SvIsCOW(TARG)) {
4988 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
4994 SvPV_set(TARG, SvPVX(dstr));
4995 SvCUR_set(TARG, SvCUR(dstr));
4996 SvLEN_set(TARG, SvLEN(dstr));
4997 SvFLAGS(TARG) |= SvUTF8(dstr);
4998 SvPV_set(dstr, NULL);
5001 if (PL_op->op_private & OPpTRUEBOOL)
5008 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
5009 (void)SvPOK_only_UTF8(TARG);
5012 /* See "how taint works" above */
5014 if ((rxtainted & SUBST_TAINT_PAT) ||
5015 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
5016 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
5018 (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
5020 if (!(rxtainted & SUBST_TAINT_BOOLRET)
5021 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
5023 SvTAINTED_on(TOPs); /* taint return value */
5025 SvTAINTED_off(TOPs); /* may have got tainted earlier */
5027 /* needed for mg_set below */
5029 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
5033 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
5035 LEAVE_SCOPE(oldsave);
5042 /* Understanding the stack during a grep.
5044 * 'grep expr, args' is implemented in the form of
5051 * The stack examples below are in the form of 'perl -Ds' output,
5052 * where any stack element indexed by PL_markstack_ptr[i] has a star
5053 * just to the right of it. In addition, the corresponding i value
5054 * is displayed under the indexed stack element.
5056 * On entry to grepwhile, the stack looks like this:
5058 * => * M1..Mn X1 * X2..Xn C * R1..Rn BOOL
5062 * M1..Mn Accumulated args which have been matched so far.
5063 * X1..Xn Random discardable elements from previous iterations.
5064 * C The current (just processed) arg, still aliased to $_.
5065 * R1..Rn The args remaining to be processed.
5066 * BOOL the result of the just-executed grep expression.
5068 * Note that it is easiest to think of the top two stack marks as both
5069 * being one too high, and so it would make more sense to have had the
5072 * => * M1..Mn * X1..Xn * C R1..Rn BOOL
5075 * where the stack is divided neatly into 3 groups:
5078 * - being, or yet to be, processed.
5079 * But off-by-one is the way it is currently, and it works as long as
5080 * we keep it consistent and bear it in mind.
5082 * pp_grepwhile() does the following:
5084 * - for a match, replace the X1 pointer with a pointer to C and bump
5085 * PL_markstack_ptr[-1]
5086 * - if more args to process, bump PL_markstack_ptr[0] and update the
5088 * - remove top 3 MARKs and return M1..Mn, or a scalar,
5089 * or void as appropriate.
5093 bool match = SvTRUE_NN(*PL_stack_sp);
5097 SV **from_p = PL_stack_base + PL_markstack_ptr[0];
5098 SV **to_p = PL_stack_base + PL_markstack_ptr[-1]++;
5104 #ifdef PERL_RC_STACK
5105 SvREFCNT_inc_simple_void_NN(from);
5111 ++*PL_markstack_ptr;
5113 LEAVE_with_name("grep_item"); /* exit inner scope */
5116 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > PL_stack_sp)) {
5118 const U8 gimme = GIMME_V;
5120 LEAVE_with_name("grep"); /* exit outer scope */
5121 (void)POPMARK; /* pop src */
5122 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
5123 (void)POPMARK; /* pop dst */
5124 SV **base = PL_stack_base + POPMARK; /* pop original mark */
5126 if (gimme == G_LIST)
5127 rpp_popfree_to(base + items);
5129 rpp_popfree_to(base);
5130 if (gimme == G_SCALAR) {
5131 if (PL_op->op_private & OPpTRUEBOOL)
5132 rpp_push_1(items ? &PL_sv_yes : &PL_sv_zero);
5146 ENTER_with_name("grep_item"); /* enter inner scope */
5149 src = PL_stack_base[TOPMARK];
5150 if (SvPADTMP(src)) {
5151 SV *newsrc = sv_mortalcopy(src);
5152 PL_stack_base[TOPMARK] = newsrc;
5153 #ifdef PERL_RC_STACK
5154 SvREFCNT_inc_simple_void_NN(newsrc);
5163 return cLOGOP->op_other;
5168 /* leave_adjust_stacks():
5170 * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
5171 * positioning them at to_sp+1 onwards, and do the equivalent of a
5172 * FREEMPS and TAINT_NOT.
5174 * Not intended to be called in void context.
5176 * When leaving a sub, eval, do{} or other scope, the things that need
5177 * doing to process the return args are:
5178 * * in scalar context, only return the last arg (or PL_sv_undef if none);
5179 * * for the types of return that return copies of their args (such
5180 * as rvalue sub return), make a mortal copy of every return arg,
5181 * except where we can optimise the copy away without it being
5182 * semantically visible;
5183 * * make sure that the arg isn't prematurely freed; in the case of an
5184 * arg not copied, this may involve mortalising it. For example, in
5185 * C<sub f { my $x = ...; $x }>, $x would be freed when we do
5186 * CX_LEAVE_SCOPE(cx) unless it's protected or copied.
5188 * What condition to use when deciding whether to pass the arg through
5189 * or make a copy, is determined by the 'pass' arg; its valid values are:
5190 * 0: rvalue sub/eval exit
5191 * 1: other rvalue scope exit
5192 * 2: :lvalue sub exit in rvalue context
5193 * 3: :lvalue sub exit in lvalue context and other lvalue scope exits
5195 * There is a big issue with doing a FREETMPS. We would like to free any
5196 * temps created by the last statement which the sub executed, rather than
5197 * leaving them for the caller. In a situation where a sub call isn't
5198 * soon followed by a nextstate (e.g. nested recursive calls, a la
5199 * fibonacci()), temps can accumulate, causing memory and performance
5202 * On the other hand, we don't want to free any TEMPs which are keeping
5203 * alive any return args that we skipped copying; nor do we wish to undo
5204 * any mortalising done here.
5206 * The solution is to split the temps stack frame into two, with a cut
5207 * point delineating the two halves. We arrange that by the end of this
5208 * function, all the temps stack frame entries we wish to keep are in the
5209 * range PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
5210 * the range tmps_base .. PL_tmps_ix. During the course of this
5211 * function, tmps_base starts off as PL_tmps_floor+1, then increases
5212 * whenever we find or create a temp that we know should be kept. In
5213 * general the stuff above tmps_base is undecided until we reach the end,
5214 * and we may need a sort stage for that.
5216 * To determine whether a TEMP is keeping a return arg alive, every
5217 * arg that is kept rather than copied and which has the SvTEMP flag
5218 * set, has the flag temporarily unset, to mark it. At the end we scan
5219 * the temps stack frame above the cut for entries without SvTEMP and
5220 * keep them, while turning SvTEMP on again. Note that if we die before
5221 * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
5222 * those SVs may be slightly less efficient.
5224 * In practice various optimisations for some common cases mean we can
5225 * avoid most of the scanning and swapping about with the temps stack.
5229 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
5231 SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
5234 PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
5238 if (gimme == G_LIST) {
5239 nargs = PL_stack_sp - from_sp;
5243 assert(gimme == G_SCALAR);
5244 if (UNLIKELY(from_sp >= PL_stack_sp)) {
5245 /* no return args */
5246 assert(from_sp == PL_stack_sp);
5248 *++PL_stack_sp = &PL_sv_undef;
5250 from_sp = PL_stack_sp;
5254 /* common code for G_SCALAR and G_LIST */
5256 #ifdef PERL_RC_STACK
5258 /* free any items from the stack which are about to get
5260 SV **p = from_sp - 1;
5271 tmps_base = PL_tmps_floor + 1;
5275 /* pointer version of tmps_base. Not safe across temp stack
5279 EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
5280 tmps_basep = PL_tmps_stack + tmps_base;
5282 /* process each return arg */
5285 SV *sv = *from_sp++;
5287 assert(PL_tmps_ix + nargs < PL_tmps_max);
5289 /* PADTMPs with container set magic shouldn't appear in the
5290 * wild. This assert is more important for pp_leavesublv(),
5291 * but by testing for it here, we're more likely to catch
5292 * bad cases (what with :lvalue subs not being widely
5293 * deployed). The two issues are that for something like
5294 * sub :lvalue { $tied{foo} }
5296 * sub :lvalue { substr($foo,1,2) }
5297 * pp_leavesublv() will croak if the sub returns a PADTMP,
5298 * and currently functions like pp_substr() return a mortal
5299 * rather than using their PADTMP when returning a PVLV.
5300 * This is because the PVLV will hold a ref to $foo,
5301 * so $foo would get delayed in being freed while
5302 * the PADTMP SV remained in the PAD.
5303 * So if this assert fails it means either:
5304 * 1) there is pp code similar to pp_substr that is
5305 * returning a PADTMP instead of a mortal, and probably
5307 * 2) pp_leavesublv is making unwarranted assumptions
5308 * about always croaking on a PADTMP
5310 if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
5312 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
5313 assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
5319 pass == 0 ? (rpp_is_lone(sv) && !SvMAGICAL(sv))
5320 : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
5321 : pass == 2 ? (!SvPADTMP(sv))
5324 /* pass through: skip copy for logic or optimisation
5325 * reasons; instead mortalise it, except that ... */
5327 #ifdef PERL_RC_STACK
5333 /* ... since this SV is an SvTEMP , we don't need to
5334 * re-mortalise it; instead we just need to ensure
5335 * that its existing entry in the temps stack frame
5336 * ends up below the cut and so avoids being freed
5337 * this time round. We mark it as needing to be kept
5338 * by temporarily unsetting SvTEMP; then at the end,
5339 * we shuffle any !SvTEMP entries on the tmps stack
5340 * back below the cut.
5341 * However, there's a significant chance that there's
5342 * a 1:1 correspondence between the first few (or all)
5343 * elements in the return args stack frame and those
5344 * in the temps stack frame; e,g.:
5345 * sub f { ....; map {...} .... },
5346 * or if we're exiting multiple scopes and one of the
5347 * inner scopes has already made mortal copies of each
5350 * If so, this arg sv will correspond to the next item
5351 * on the tmps stack above the cut, and so can be kept
5352 * merely by moving the cut boundary up one, rather
5353 * than messing with SvTEMP. If all args are 1:1 then
5354 * we can avoid the sorting stage below completely.
5356 * If there are no items above the cut on the tmps
5357 * stack, then the SvTEMP must comne from an item
5358 * below the cut, so there's nothing to do.
5360 if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
5361 if (sv == *tmps_basep)
5367 else if (!SvPADTMP(sv)) {
5368 /* mortalise arg to avoid it being freed during save
5369 * stack unwinding. Pad tmps don't need mortalising as
5370 * they're never freed. This is the equivalent of
5371 * sv_2mortal(SvREFCNT_inc(sv)), except that:
5372 * * it assumes that the temps stack has already been
5374 * * it puts the new item at the cut rather than at
5375 * ++PL_tmps_ix, moving the previous occupant there
5378 if (!SvIMMORTAL(sv)) {
5379 SvREFCNT_inc_simple_void_NN(sv);
5381 /* Note that if there's nothing above the cut,
5382 * this copies the garbage one slot above
5383 * PL_tmps_ix onto itself. This is harmless (the
5384 * stack's already been extended), but might in
5385 * theory trigger warnings from tools like ASan
5387 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
5393 /* Make a mortal copy of the SV.
5394 * The following code is the equivalent of sv_mortalcopy()
5396 * * it assumes the temps stack has already been extended;
5397 * * it optimises the copying for some simple SV types;
5398 * * it puts the new item at the cut rather than at
5399 * ++PL_tmps_ix, moving the previous occupant there
5402 SV *newsv = newSV_type(SVt_NULL);
5404 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
5405 /* put it on the tmps stack early so it gets freed if we die */
5406 *tmps_basep++ = newsv;
5408 if (SvTYPE(sv) <= SVt_IV) {
5409 /* arg must be one of undef, IV/UV, or RV: skip
5410 * sv_setsv_flags() and do the copy directly */
5412 U32 srcflags = SvFLAGS(sv);
5414 assert(!SvGMAGICAL(sv));
5415 if (srcflags & (SVf_IOK|SVf_ROK)) {
5416 SET_SVANY_FOR_BODYLESS_IV(newsv);
5418 if (srcflags & SVf_ROK) {
5419 newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
5420 /* SV type plus flags */
5421 dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
5424 /* both src and dst are <= SVt_IV, so sv_any
5425 * points to the head; so access the heads
5426 * directly rather than going via sv_any.
5428 assert( &(sv->sv_u.svu_iv)
5429 == &(((XPVIV*) SvANY(sv))->xiv_iv));
5430 assert( &(newsv->sv_u.svu_iv)
5431 == &(((XPVIV*) SvANY(newsv))->xiv_iv));
5432 newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
5433 /* SV type plus flags */
5434 dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
5435 |(srcflags & SVf_IVisUV));
5439 assert(!(srcflags & SVf_OK));
5440 dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
5442 SvFLAGS(newsv) = dstflags;
5446 /* do the full sv_setsv() */
5450 old_base = tmps_basep - PL_tmps_stack;
5452 sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
5453 /* the mg_get or sv_setsv might have created new temps
5454 * or realloced the tmps stack; regrow and reload */
5455 EXTEND_MORTAL(nargs);
5456 tmps_basep = PL_tmps_stack + old_base;
5457 TAINT_NOT; /* Each item is independent */
5461 #ifdef PERL_RC_STACK
5463 SvREFCNT_dec_NN(sv);
5466 SvREFCNT_inc_simple_void_NN(newsv);
5474 /* If there are any temps left above the cut, we need to sort
5475 * them into those to keep and those to free. The only ones to
5476 * keep are those for which we've temporarily unset SvTEMP.
5477 * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
5478 * swapping pairs as necessary. Stop when we meet in the middle.
5481 SV **top = PL_tmps_stack + PL_tmps_ix;
5482 while (tmps_basep <= top) {
5495 tmps_base = tmps_basep - PL_tmps_stack;
5498 PL_stack_sp = to_sp;
5500 /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
5501 while (PL_tmps_ix >= tmps_base) {
5502 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
5504 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
5508 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
5514 /* also tail-called by pp_return */
5524 assert(CxTYPE(cx) == CXt_SUB);
5526 if (CxMULTICALL(cx)) {
5527 /* entry zero of a stack is always PL_sv_undef, which
5528 * simplifies converting a '()' return into undef in scalar context */
5529 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
5533 gimme = cx->blk_gimme;
5534 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
5536 if (gimme == G_VOID)
5537 rpp_popfree_to(oldsp);
5539 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
5542 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
5544 retop = cx->blk_sub.retop;
5551 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
5552 * forces an abandon */
5555 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
5557 PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
5559 if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))
5560 #ifndef PERL_RC_STACK
5564 clear_defarray_simple(av);
5565 #ifndef PERL_RC_STACK
5571 const SSize_t size = AvFILLp(av) + 1;
5572 /* The ternary gives consistency with av_extend() */
5573 AV *newav = newAV_alloc_xz(size < PERL_ARRAY_NEW_MIN_KEY ?
5574 PERL_ARRAY_NEW_MIN_KEY : size);
5575 #ifndef PERL_RC_STACK
5576 AvREIFY_only(newav);
5578 PAD_SVl(0) = MUTABLE_SV(newav);
5579 SvREFCNT_dec_NN(av);
5589 I32 old_savestack_ix;
5590 SV *sv = *PL_stack_sp;
5595 /* Locate the CV to call:
5596 * - most common case: RV->CV: f(), $ref->():
5597 * note that if a sub is compiled before its caller is compiled,
5598 * the stash entry will be a ref to a CV, rather than being a GV.
5599 * - second most common case: CV: $ref->method()
5602 /* a non-magic-RV -> CV ? */
5603 if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
5604 cv = MUTABLE_CV(SvRV(sv));
5605 if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
5609 cv = MUTABLE_CV(sv);
5612 if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
5613 /* handle all the weird cases */
5614 switch (SvTYPE(sv)) {
5616 if (!isGV_with_GP(sv))
5620 cv = GvCVu((const GV *)sv);
5621 if (UNLIKELY(!cv)) {
5623 cv = sv_2cv(sv, &stash, &gv, 0);
5625 old_savestack_ix = PL_savestack_ix;
5636 if (UNLIKELY(SvAMAGIC(sv))) {
5637 sv = amagic_deref_call(sv, to_cv_amg);
5643 if (UNLIKELY(!SvOK(sv)))
5644 DIE(aTHX_ PL_no_usym, "a subroutine");
5646 sym = SvPV_nomg_const(sv, len);
5647 if (PL_op->op_private & HINT_STRICT_REFS)
5648 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
5649 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
5652 cv = MUTABLE_CV(SvRV(sv));
5653 if (LIKELY(SvTYPE(cv) == SVt_PVCV))
5659 DIE(aTHX_ "Not a CODE reference");
5663 /* At this point we want to save PL_savestack_ix, either by doing a
5664 * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
5665 * CV we will be using (so we don't know whether its XS, so we can't
5666 * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
5667 * the save stack. So remember where we are currently on the save
5668 * stack, and later update the CX or scopestack entry accordingly. */
5669 old_savestack_ix = PL_savestack_ix;
5671 /* these two fields are in a union. If they ever become separate,
5672 * we have to test for both of them being null below */
5674 assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
5675 while (UNLIKELY(!CvROOT(cv))) {
5679 /* anonymous or undef'd function leaves us no recourse */
5680 if (CvLEXICAL(cv) && CvHASGV(cv))
5681 DIE(aTHX_ "Undefined subroutine &%" SVf " called",
5682 SVfARG(cv_name(cv, NULL, 0)));
5683 if (CvANON(cv) || !CvHASGV(cv)) {
5684 DIE(aTHX_ "Undefined subroutine called");
5687 /* autoloaded stub? */
5688 if (cv != GvCV(gv = CvGV(cv))) {
5691 /* should call AUTOLOAD now? */
5694 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
5695 (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
5696 |(PL_op->op_flags & OPf_REF
5697 ? GV_AUTOLOAD_ISMETHOD
5699 cv = autogv ? GvCV(autogv) : NULL;
5702 sub_name = sv_newmortal();
5703 gv_efullname3(sub_name, gv, NULL);
5704 DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
5708 /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
5709 if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
5710 DIE(aTHX_ "Closure prototype called");
5712 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
5715 Perl_get_db_sub(aTHX_ &sv, cv);
5717 PL_curcopdb = PL_curcop;
5719 /* check for lsub that handles lvalue subroutines */
5720 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
5721 /* if lsub not found then fall back to DB::sub */
5722 if (!cv) cv = GvCV(PL_DBsub);
5724 cv = GvCV(PL_DBsub);
5727 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
5728 DIE(aTHX_ "No DB::sub routine defined");
5731 rpp_popfree_1(); /* finished with sv now */
5733 if (!(CvISXSUB(cv))) {
5734 /* This path taken at least 75% of the time */
5741 /* keep PADTMP args alive throughout the call (we need to do this
5742 * because @_ isn't refcounted). Note that we create the mortals
5743 * in the caller's tmps frame, so they won't be freed until after
5744 * we return from the sub.
5748 while (svp < PL_stack_sp) {
5753 SV *newsv = sv_mortalcopy(sv);
5755 #ifdef PERL_RC_STACK
5756 /* should just skip the mortalisation instead */
5757 SvREFCNT_inc_simple_void_NN(newsv);
5758 SvREFCNT_dec_NN(sv);
5767 cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
5768 hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
5769 cx_pushsub(cx, cv, PL_op->op_next, hasargs);
5771 padlist = CvPADLIST(cv);
5772 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
5773 pad_push(padlist, depth);
5774 PAD_SET_CUR_NOSAVE(padlist, depth);
5775 if (LIKELY(hasargs)) {
5776 AV *const av = MUTABLE_AV(PAD_SVl(0));
5780 defavp = &GvAV(PL_defgv);
5781 cx->blk_sub.savearray = *defavp;
5782 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
5784 /* it's the responsibility of whoever leaves a sub to ensure
5785 * that a clean, empty AV is left in pad[0]. This is normally
5786 * done by cx_popsub() */
5788 #ifdef PERL_RC_STACK
5791 assert(!AvREAL(av));
5793 assert(AvFILLp(av) == -1);
5795 items = PL_stack_sp - MARK;
5796 if (UNLIKELY(items - 1 > AvMAX(av))) {
5797 SV **ary = AvALLOC(av);
5798 Renew(ary, items, SV*);
5799 AvMAX(av) = items - 1;
5805 Copy(MARK+1,AvARRAY(av),items,SV*);
5806 AvFILLp(av) = items - 1;
5807 #ifdef PERL_RC_STACK
5808 /* transfer ownership of the arguments' refcounts to av */
5812 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5814 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5815 SVfARG(cv_name(cv, NULL, 0)));
5816 /* warning must come *after* we fully set up the context
5817 * stuff so that __WARN__ handlers can safely dounwind()
5820 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
5821 && ckWARN(WARN_RECURSION)
5822 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
5823 sub_crush_depth(cv);
5827 SSize_t markix = TOPMARK;
5831 /* pretend we did the ENTER earlier */
5832 PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
5836 if (UNLIKELY(((PL_op->op_private
5837 & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
5838 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5840 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5841 SVfARG(cv_name(cv, NULL, 0)));
5843 if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
5844 /* Need to copy @_ to stack. Alternative may be to
5845 * switch stack to @_, and copy return values
5846 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
5847 AV * const av = GvAV(PL_defgv);
5848 const SSize_t items = AvFILL(av) + 1;
5852 const bool m = cBOOL(SvRMAGICAL(av));
5853 /* Mark is at the end of the stack. */
5855 for (; i < items; ++i)
5859 SV ** const svp = av_fetch(av, i, 0);
5860 sv = svp ? *svp : NULL;
5863 sv = AvARRAY(av)[i];
5865 rpp_push_1(sv ? sv : av_nonelem(av, i));
5870 SV **mark = PL_stack_base + markix;
5871 SSize_t items = PL_stack_sp - mark;
5874 if (*mark && SvPADTMP(*mark)) {
5876 SV *newsv = sv_mortalcopy(oldsv);
5878 #ifdef PERL_RC_STACK
5879 /* should just skip the mortalisation instead */
5880 SvREFCNT_inc_simple_void_NN(newsv);
5881 SvREFCNT_dec_NN(oldsv);
5887 /* We assume first XSUB in &DB::sub is the called one. */
5888 if (UNLIKELY(PL_curcopdb)) {
5889 SAVEVPTR(PL_curcop);
5890 PL_curcop = PL_curcopdb;
5893 /* Do we need to open block here? XXXX */
5895 /* calculate gimme here as PL_op might get changed and then not
5896 * restored until the LEAVE further down */
5897 is_scalar = (GIMME_V == G_SCALAR);
5899 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
5904 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5905 /* This duplicates the check done in runops_debug(), but provides more
5906 * information in the common case of the fault being with an XSUB.
5908 * It should also catch an XSUB pushing more than it extends
5909 * in scalar context.
5911 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
5912 Perl_croak_nocontext(
5913 "panic: XSUB %s::%s (%s) failed to extend arg stack: "
5914 "base=%p, sp=%p, hwm=%p\n",
5915 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv),
5916 PL_stack_base, PL_stack_sp,
5917 PL_stack_base + PL_curstackinfo->si_stack_hwm);
5919 /* Enforce some sanity in scalar context. */
5921 SV **svp = PL_stack_base + markix + 1;
5922 if (svp != PL_stack_sp) {
5923 #ifdef PERL_RC_STACK
5924 if (svp < PL_stack_sp) {
5925 /* move return value to bottom of stack frame
5926 * and free everything else */
5927 SV* retsv = *PL_stack_sp;
5928 *PL_stack_sp = *svp;
5930 rpp_popfree_to(svp);
5933 *++PL_stack_sp = &PL_sv_undef;
5935 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
5946 Perl_sub_crush_depth(pTHX_ CV *cv)
5948 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
5951 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
5953 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
5954 SVfARG(cv_name(cv,NULL,0)));
5960 /* like croak, but report in context of caller */
5963 Perl_croak_caller(const char *pat, ...)
5967 const PERL_CONTEXT *cx = caller_cx(0, NULL);
5969 /* make error appear at call site */
5971 PL_curcop = cx->blk_oldcop;
5973 va_start(args, pat);
5975 NOT_REACHED; /* NOTREACHED */
5980 PP_wrapped(pp_aelem, 2, 0)
5984 SV* const elemsv = POPs;
5985 IV elem = SvIV(elemsv);
5986 AV *const av = MUTABLE_AV(POPs);
5987 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
5988 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
5989 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5990 bool preeminent = TRUE;
5993 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
5994 Perl_warner(aTHX_ packWARN(WARN_MISC),
5995 "Use of reference \"%" SVf "\" as array index",
5997 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
6000 if (UNLIKELY(localizing)) {
6004 /* Try to preserve the existence of a tied array
6005 * element by using EXISTS and DELETE if possible.
6006 * Fall back to FETCH and STORE otherwise. */
6007 if (SvCANEXISTDELETE(av))
6008 preeminent = av_exists(av, elem);
6011 svp = av_fetch(av, elem, lval && !defer);
6013 #ifdef PERL_MALLOC_WRAP
6014 if (SvUOK(elemsv)) {
6015 const UV uv = SvUV(elemsv);
6016 elem = uv > IV_MAX ? IV_MAX : uv;
6018 else if (SvNOK(elemsv))
6019 elem = (IV)SvNV(elemsv);
6021 MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend");
6024 if (!svp || !*svp) {
6027 DIE(aTHX_ PL_no_aelem, elem);
6028 len = av_top_index(av);
6029 /* Resolve a negative index that falls within the array. Leave
6030 it negative it if falls outside the array. */
6031 if (elem < 0 && len + elem >= 0)
6033 if (elem >= 0 && elem <= len)
6034 /* Falls within the array. */
6035 PUSHs(av_nonelem(av,elem));
6037 /* Falls outside the array. If it is negative,
6038 magic_setdefelem will use the index for error reporting.
6040 mPUSHs(newSVavdefelem(av, elem, 1));
6043 if (UNLIKELY(localizing)) {
6045 save_aelem(av, elem, svp);
6047 SAVEADELETE(av, elem);
6049 else if (PL_op->op_private & OPpDEREF) {
6050 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
6054 sv = (svp ? *svp : &PL_sv_undef);
6055 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
6062 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
6064 PERL_ARGS_ASSERT_VIVIFY_REF;
6069 Perl_croak_no_modify();
6070 prepare_SV_for_RV(sv);
6073 SvRV_set(sv, newSV_type(SVt_NULL));
6076 SvRV_set(sv, MUTABLE_SV(newAV()));
6079 SvRV_set(sv, MUTABLE_SV(newHV()));
6086 if (SvGMAGICAL(sv)) {
6087 /* copy the sv without magic to prevent magic from being
6089 SV* msv = sv_newmortal();
6090 sv_setsv_nomg(msv, sv);
6096 PERL_STATIC_INLINE HV *
6097 S_opmethod_stash(pTHX_ SV* meth)
6102 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
6103 ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
6104 "package or object reference", SVfARG(meth)),
6106 : *(PL_stack_base + TOPMARK + 1);
6108 PERL_ARGS_ASSERT_OPMETHOD_STASH;
6112 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
6115 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
6116 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
6117 stash = gv_stashsv(sv, GV_CACHE_ONLY);
6118 if (stash) return stash;
6122 ob = MUTABLE_SV(SvRV(sv));
6123 else if (!SvOK(sv)) goto undefined;
6124 else if (isGV_with_GP(sv)) {
6126 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
6127 "without a package or object reference",
6130 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
6131 assert(!LvTARGLEN(ob));
6135 /* Replace the object at the base of the stack frame.
6136 * This is "below" whatever pp_wrap has wrapped, so needs freeing.
6138 SV *newsv = sv_2mortal(newRV(ob));
6139 SV **svp = (PL_stack_base + TOPMARK + 1);
6140 #ifdef PERL_RC_STACK
6144 #ifdef PERL_RC_STACK
6145 SvREFCNT_inc_simple_void_NN(newsv);
6146 SvREFCNT_dec_NN(oldsv);
6150 /* this isn't a reference */
6153 const char * const packname = SvPV_nomg_const(sv, packlen);
6154 const U32 packname_utf8 = SvUTF8(sv);
6155 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
6156 if (stash) return stash;
6158 if (!(iogv = gv_fetchpvn_flags(
6159 packname, packlen, packname_utf8, SVt_PVIO
6161 !(ob=MUTABLE_SV(GvIO(iogv))))
6163 /* this isn't the name of a filehandle either */
6166 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
6167 "without a package or object reference",
6170 /* assume it's a package name */
6171 stash = gv_stashpvn(packname, packlen, packname_utf8);
6172 if (stash) return stash;
6173 else return MUTABLE_HV(sv);
6175 /* it _is_ a filehandle name -- replace with a reference.
6176 * Replace the object at the base of the stack frame.
6177 * This is "below" whatever pp_wrap has wrapped, so needs freeing.
6179 SV *newsv = sv_2mortal(newRV(MUTABLE_SV(iogv)));
6180 SV **svp = (PL_stack_base + TOPMARK + 1);
6181 #ifdef PERL_RC_STACK
6185 #ifdef PERL_RC_STACK
6186 SvREFCNT_inc_simple_void_NN(newsv);
6187 SvREFCNT_dec_NN(oldsv);
6191 /* if we got here, ob should be an object or a glob */
6192 if (!ob || !(SvOBJECT(ob)
6193 || (isGV_with_GP(ob)
6194 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
6197 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
6198 SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
6199 ? newSVpvs_flags("DOES", SVs_TEMP)
6206 PP_wrapped(pp_method, 1, 0)
6211 SV* const meth = TOPs;
6214 SV* const rmeth = SvRV(meth);
6215 if (SvTYPE(rmeth) == SVt_PVCV) {
6221 stash = opmethod_stash(meth);
6223 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
6226 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6230 #define METHOD_CHECK_CACHE(stash,cache,meth) \
6231 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
6233 gv = MUTABLE_GV(HeVAL(he)); \
6234 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
6235 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
6237 rpp_xpush_1(MUTABLE_SV(GvCV(gv))); \
6245 SV* const meth = cMETHOP_meth;
6246 HV* const stash = opmethod_stash(meth);
6248 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
6249 METHOD_CHECK_CACHE(stash, stash, meth);
6252 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
6255 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6263 SV* const meth = cMETHOP_meth;
6264 HV* const stash = CopSTASH(PL_curcop);
6265 /* Actually, SUPER doesn't need real object's (or class') stash at all,
6266 * as it uses CopSTASH. However, we must ensure that object(class) is
6267 * correct (this check is done by S_opmethod_stash) */
6268 opmethod_stash(meth);
6270 if ((cache = HvMROMETA(stash)->super)) {
6271 METHOD_CHECK_CACHE(stash, cache, meth);
6274 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
6277 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6284 SV* const meth = cMETHOP_meth;
6285 HV* stash = gv_stashsv(cMETHOP_rclass, 0);
6286 opmethod_stash(meth); /* not used but needed for error checks */
6288 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
6289 else stash = MUTABLE_HV(cMETHOP_rclass);
6291 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
6294 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6298 PP(pp_method_redir_super)
6302 SV* const meth = cMETHOP_meth;
6303 HV* stash = gv_stashsv(cMETHOP_rclass, 0);
6304 opmethod_stash(meth); /* not used but needed for error checks */
6306 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOP_rclass);
6307 else if ((cache = HvMROMETA(stash)->super)) {
6308 METHOD_CHECK_CACHE(stash, cache, meth);
6311 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
6314 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6319 * ex: set ts=8 sts=4 sw=4 et: