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);
227 sv_copypv(TARG, *PL_stack_sp);
229 rpp_replace_1_1(TARG);
235 /* cGVOP_gv might be a real GV or might be an RV to a CV */
236 assert(SvTYPE(cGVOP_gv) == SVt_PVGV ||
237 (SvTYPE(cGVOP_gv) <= SVt_PVMG && SvROK(cGVOP_gv) && SvTYPE(SvRV(cGVOP_gv)) == SVt_PVCV));
238 rpp_xpush_1(MUTABLE_SV(cGVOP_gv));
243 /* also used for: pp_andassign() */
249 SV * const sv = *PL_stack_sp;
253 if (PL_op->op_type == OP_AND)
255 return cLOGOP->op_other;
261 * Mashup of simple padsv + sassign OPs
262 * Doesn't support the following lengthy and unlikely sassign case:
263 * (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV))
264 * These cases have a separate optimization, so are not handled here:
265 * (PL_op->op_private & OPpASSIGN_BACKWARDS) {or,and,dor}assign
270 OP * const op = PL_op;
271 SV** const padentry = &PAD_SVl(op->op_targ);
272 SV* targ = *padentry; /* lvalue to assign into */
273 SV* const val = *PL_stack_sp; /* RHS value to assign */
275 /* !OPf_STACKED is not handled by this OP */
276 assert(op->op_flags & OPf_STACKED);
278 /* Inlined, simplified pp_padsv here */
279 if ((op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
280 save_clearsv(padentry);
283 /* Inlined, simplified pp_sassign from here */
284 assert(TAINTING_get || !TAINT_get);
285 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
289 UNLIKELY(SvTEMP(targ)) && !SvSMAGICAL(targ) && SvREFCNT(targ) == 1 &&
290 (!isGV_with_GP(targ) || SvFAKE(targ)) && ckWARN(WARN_MISC)
293 packWARN(WARN_MISC), "Useless assignment to a temporary"
295 SvSetMagicSV(targ, val);
297 rpp_replace_1_1(targ);
302 /* A mashup of simplified AELEMFAST_LEX + SASSIGN OPs */
304 PP(pp_aelemfastlex_store)
306 OP * const op = PL_op;
307 SV* const val = *PL_stack_sp; /* RHS value to assign */
308 AV * const av = MUTABLE_AV(PAD_SV(op->op_targ));
309 const I8 key = (I8)PL_op->op_private;
312 /* !OPf_STACKED is not handled by this OP */
313 assert(op->op_flags & OPf_STACKED);
315 /* Inlined, simplified pp_aelemfast here */
316 assert(SvTYPE(av) == SVt_PVAV);
318 /* inlined av_fetch() for simple cases ... */
319 if (!SvRMAGICAL(av) && key >=0 && key <= AvFILLp(av)) {
320 targ = AvARRAY(av)[key];
322 /* ... else do it the hard way */
324 SV **svp = av_fetch(av, key, 1);
329 DIE(aTHX_ PL_no_aelem, (int)key);
332 /* Inlined, simplified pp_sassign from here */
333 assert(TAINTING_get || !TAINT_get);
334 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
337 /* This assertion is a deviation from pp_sassign, which uses an if()
338 * condition to check for "Useless assignment to a temporary" and
339 * warns if the condition is true. Here, the condition should NEVER
340 * be true when the LHS is the result of an array fetch. The
341 * assertion is here as a final check that this remains the case.
343 assert(!(SvTEMP(targ) && SvREFCNT(targ) == 1 && !SvSMAGICAL(targ)));
345 SvSetMagicSV(targ, val);
347 rpp_replace_1_1(targ);
353 /* sassign keeps its args in the optree traditionally backwards.
354 So we pop them differently.
356 SV *left = PL_stack_sp[0];
357 SV *right = PL_stack_sp[-1];
359 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
360 SV * const temp = left;
361 left = right; right = temp;
363 assert(TAINTING_get || !TAINT_get);
364 if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
367 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
369 SV * const cv = SvRV(right);
370 const U32 cv_type = SvTYPE(cv);
371 const bool is_gv = isGV_with_GP(left);
372 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
378 /* Can do the optimisation if left (LVALUE) is not a typeglob,
379 right (RVALUE) is a reference to something, and we're in void
381 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
382 /* Is the target symbol table currently empty? */
383 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
384 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
385 /* Good. Create a new proxy constant subroutine in the target.
386 The gv becomes a(nother) reference to the constant. */
387 SV *const value = SvRV(cv);
389 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
390 SvPCS_IMPORTED_on(gv);
392 SvREFCNT_inc_simple_void(value);
393 rpp_replace_2_1(left);
398 /* Need to fix things up. */
400 /* Need to fix GV. */
401 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
405 /* We've been returned a constant rather than a full subroutine,
406 but they expect a subroutine reference to apply. */
408 ENTER_with_name("sassign_coderef");
409 SvREFCNT_inc_void(SvRV(cv));
410 /* newCONSTSUB takes a reference count on the passed in SV
411 from us. We set the name to NULL, otherwise we get into
412 all sorts of fun as the reference to our new sub is
413 donated to the GV that we're about to assign to.
415 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
418 LEAVE_with_name("sassign_coderef");
420 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
422 First: ops for \&{"BONK"}; return us the constant in the
424 Second: ops for *{"BONK"} cause that symbol table entry
425 (and our reference to it) to be upgraded from RV
427 Thirdly: We get here. cv is actually PVGV now, and its
428 GvCV() is actually the subroutine we're looking for
430 So change the reference so that it points to the subroutine
431 of that typeglob, as that's what they were after all along.
433 GV *const upgraded = MUTABLE_GV(cv);
434 CV *const source = GvCV(upgraded);
437 assert(CvFLAGS(source) & CVf_CONST);
439 SvREFCNT_inc_simple_void_NN(source);
440 SvREFCNT_dec_NN(upgraded);
441 SvRV_set(right, MUTABLE_SV(source));
447 rpp_is_lone(left) && !SvSMAGICAL(left) &&
448 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
451 packWARN(WARN_MISC), "Useless assignment to a temporary"
453 SvSetMagicSV(left, right);
454 rpp_replace_2_1(left);
461 bool ok = SvTRUE_NN(*PL_stack_sp);
463 return (ok ? cLOGOP->op_other : cLOGOP->op_next);
470 TAINT_NOT; /* Each statement is presumed innocent */
472 rpp_popfree_to(PL_stack_base + CX_CUR()->blk_oldsp);
474 if (!(PL_op->op_flags & OPf_SPECIAL)) {
475 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
482 /* The main body of pp_concat, not including the magic/overload and
484 * It does targ = left . right.
485 * Moved into a separate function so that pp_multiconcat() can use it
489 PERL_STATIC_INLINE void
490 S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy)
494 const char *rpv = NULL;
496 bool rcopied = FALSE;
498 if (TARG == right && right != left) { /* $r = $l.$r */
499 rpv = SvPV_nomg_const(right, rlen);
500 rbyte = !DO_UTF8(right);
501 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
502 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
506 if (TARG != left) { /* not $l .= $r */
508 const char* const lpv = SvPV_nomg_const(left, llen);
509 lbyte = !DO_UTF8(left);
510 sv_setpvn(TARG, lpv, llen);
516 else { /* $l .= $r and left == TARG */
518 if ((left == right /* $l .= $l */
519 || targmy) /* $l = $l . $r */
520 && ckWARN(WARN_UNINITIALIZED)
526 SvPV_force_nomg_nolen(left);
528 lbyte = !DO_UTF8(left);
534 rpv = SvPV_nomg_const(right, rlen);
535 rbyte = !DO_UTF8(right);
537 if (lbyte != rbyte) {
539 sv_utf8_upgrade_nomg(TARG);
542 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
543 sv_utf8_upgrade_nomg(right);
544 rpv = SvPV_nomg_const(right, rlen);
547 sv_catpvn_nomg(TARG, rpv, rlen);
554 SV *targ = (PL_op->op_flags & OPf_STACKED)
556 : PAD_SV(PL_op->op_targ);
558 if (rpp_try_AMAGIC_2(concat_amg, AMGf_assign))
561 SV *right = PL_stack_sp[0];
562 SV *left = PL_stack_sp[-1];
563 S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY);
564 rpp_replace_2_1(targ);
571 Concatenate one or more args, possibly interleaved with constant string
572 segments. The result may be assigned to, or appended to, a variable or
575 Several op_flags and/or op_private bits indicate what the target is, and
576 whether it's appended to. Valid permutations are:
578 - (PADTMP) = (A.B.C....)
579 OPpTARGET_MY $lex = (A.B.C....)
580 OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....)
581 OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....)
582 OPf_STACKED expr = (A.B.C....)
583 OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....)
585 Other combinations like (A.B).(C.D) are not optimised into a multiconcat
586 op, as it's too hard to get the correct ordering of ties, overload etc.
590 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised
591 sprintf "...%s...". Don't call '.'
592 overloading: only use '""' overloading.
594 OPpMULTICONCAT_STRINGIFY: the RHS was of the form
595 "...$a...$b..." rather than
596 "..." . $a . "..." . $b . "..."
598 An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
599 defined with PERL_MULTICONCAT_IX_FOO constants, where:
602 FOO index description
603 -------- ----- ----------------------------------
604 NARGS 0 number of arguments
605 PLAIN_PV 1 non-utf8 constant string
606 PLAIN_LEN 2 non-utf8 constant string length
607 UTF8_PV 3 utf8 constant string
608 UTF8_LEN 4 utf8 constant string length
609 LENGTHS 5 first of nargs+1 const segment lengths
611 The idea is that a general string concatenation will have a fixed (known
612 at compile time) number of variable args, interspersed with constant
613 strings, e.g. "a=$a b=$b\n"
615 All the constant string segments "a=", " b=" and "\n" are stored as a
616 single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
617 with a series of segment lengths: e.g. 2,3,1. In the case where the
618 constant string is plain but has a different utf8 representation, both
619 variants are stored, and two sets of (nargs+1) segments lengths are stored
620 in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
622 A segment length of -1 indicates that there is no constant string at that
623 point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
624 have differing overloading behaviour.
630 SV *targ; /* The SV to be assigned or appended to */
631 char *targ_pv; /* where within SvPVX(targ) we're writing to */
632 STRLEN targ_len; /* SvCUR(targ) */
633 SV **toparg; /* the highest arg position on the stack */
634 UNOP_AUX_item *aux; /* PL_op->op_aux buffer */
635 UNOP_AUX_item *const_lens; /* the segment length array part of aux */
636 const char *const_pv; /* the current segment of the const string buf */
637 SSize_t nargs; /* how many args were expected */
638 SSize_t stack_adj; /* how much to adjust PL_stack_sp on return */
639 STRLEN grow; /* final size of destination string (targ) */
640 UV targ_count; /* how many times targ has appeared on the RHS */
641 bool is_append; /* OPpMULTICONCAT_APPEND flag is set */
642 bool slow_concat; /* args too complex for quick concat */
643 U32 dst_utf8; /* the result will be utf8 (indicate this with
644 SVf_UTF8 in a U32, rather than using bool,
645 for ease of testing and setting) */
646 /* for each arg, holds the result of an SvPV() call */
647 struct multiconcat_svpv {
651 *targ_chain, /* chain of slots where targ has appeared on RHS */
652 *svpv_p, /* ptr for looping through svpv_buf */
653 *svpv_base, /* first slot (may be greater than svpv_buf), */
654 *svpv_end, /* and slot after highest result so far, of: */
655 svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
657 aux = cUNOP_AUXx(PL_op)->op_aux;
658 stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
659 is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
661 /* get targ from the stack or pad */
663 toparg = PL_stack_sp;
664 if (PL_op->op_flags & OPf_STACKED) {
667 /* for 'expr .= ...', expr is the bottom item on the stack */
668 targ = PL_stack_sp[-nargs];
671 /* for 'expr = ...', expr is the top item on the stack */
677 SV **svp = &(PAD_SVl(PL_op->op_targ));
679 if (PL_op->op_private & OPpLVAL_INTRO) {
680 assert(PL_op->op_private & OPpTARGET_MY);
684 /* $lex .= "const" doesn't cause anything to be pushed */
688 grow = 1; /* allow for '\0' at minimum */
693 /* only utf8 variants of the const strings? */
694 dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
697 /* --------------------------------------------------------------
700 * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
701 * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
703 * utf8 is indicated by storing a negative length.
705 * Where an arg is actually targ, the stringification is deferred:
706 * the length is set to 0, and the slot is added to targ_chain.
708 * If a magic, overloaded, or otherwise weird arg is found, which
709 * might have side effects when stringified, the loop is abandoned and
710 * we goto a code block where a more basic 'emulate calling
711 * pp_cpncat() on each arg in turn' is done.
714 for (SV **svp = toparg - (nargs - 1); svp <= toparg; svp++, svpv_end++) {
719 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
723 /* this if/else chain is arranged so that common/simple cases
724 * take few conditionals */
726 if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) {
727 /* common case: sv is a simple non-magical PV */
729 /* targ appears on RHS.
730 * Delay storing PV pointer; instead, add slot to targ_chain
731 * so it can be populated later, after targ has been grown and
732 * we know its final SvPVX() address.
735 svpv_end->len = 0; /* zerojng here means we can skip
736 updating later if targ_len == 0 */
737 svpv_end->pv = (char*)targ_chain;
738 targ_chain = svpv_end;
744 svpv_end->pv = SvPVX(sv);
746 else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK)))
747 /* may have side effects: tie, overload etc.
748 * Abandon 'stringify everything first' and handle
749 * args in strict order. Note that already-stringified args
750 * will be reprocessed, which is safe because the each first
751 * stringification would have been idempotent.
754 else if (SvNIOK(sv)) {
757 /* stringify general valid scalar */
758 svpv_end->pv = sv_2pv_flags(sv, &len, 0);
760 else if (!SvOK(sv)) {
761 if (ckWARN(WARN_UNINITIALIZED))
762 /* an undef value in the presence of warnings may trigger
769 goto do_magical; /* something weird */
771 utf8 = (SvFLAGS(sv) & SVf_UTF8);
773 ASSUME(len < SSize_t_MAX);
774 svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
778 /* --------------------------------------------------------------
783 * if targ appears on the RHS or is appended to, force stringify it;
784 * otherwise set it to "". Then set targ_len.
788 /* abandon quick route if using targ might have side effects */
789 if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK)))
795 SvPV_force_nomg_nolen(targ);
796 targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
797 if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
798 if (LIKELY(!IN_BYTES))
799 sv_utf8_upgrade_nomg(targ);
802 dst_utf8 |= targ_utf8;
804 targ_len = SvCUR(targ);
805 grow += targ_len * (targ_count + is_append);
808 else if (ckWARN(WARN_UNINITIALIZED))
809 /* warning might have side effects */
811 /* the undef targ will be silently SvPVCLEAR()ed below */
813 else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
814 /* Assigning to some weird LHS type. Don't force the LHS to be an
815 * empty string; instead, do things 'long hand' by using the
816 * overload code path, which concats to a TEMP sv and does
817 * sv_catsv() calls rather than COPY()s. This ensures that even
818 * bizarre code like this doesn't break or crash:
820 * (which makes the 'F' typeglob an alias to the
821 * '*main::F*main::F' typeglob).
826 /* targ was found on RHS.
827 * Force stringify it, using the same code as the append branch
828 * above, except that we don't need the magic/overload/undef
829 * checks as these will already have been done in the phase 1
834 /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
835 * those will be done later. */
836 SV_CHECK_THINKFIRST_COW_DROP(targ);
837 SvUPGRADE(targ, SVt_PV);
838 SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
839 SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
843 /* --------------------------------------------------------------
846 * UTF-8 tweaks and grow targ:
848 * Now that we know the length and utf8-ness of both the targ and
849 * args, grow targ to the size needed to accumulate all the args, based
850 * on whether targ appears on the RHS, whether we're appending, and
851 * whether any non-utf8 args expand in size if converted to utf8.
853 * For the latter, if dst_utf8 we scan non-utf8 args looking for
854 * variant chars, and adjust the svpv->len value of those args to the
855 * utf8 size and negate it to flag them. At the same time we un-negate
856 * the lens of any utf8 args since after this phase we no longer care
857 * whether an arg is utf8 or not.
859 * Finally, initialise const_lens and const_pv based on utf8ness.
860 * Note that there are 3 permutations:
862 * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
863 * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
864 * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
867 * * If the string is fully utf8, e.g. "\x{100}", then
868 * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
869 * one set of segment lengths.
871 * * If the string has different plain and utf8 representations
872 * (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
873 * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
874 * holds the utf8 rep, and there are 2 sets of segment lengths,
875 * with the utf8 set following after the plain set.
877 * On entry to this section the (pv,len) pairs in svpv_buf have the
878 * following meanings:
879 * (pv, len) a plain string
880 * (pv, -len) a utf8 string
881 * (NULL, 0) left-most targ \ linked together R-to-L
882 * (next, 0) other targ / in targ_chain
885 /* turn off utf8 handling if 'use bytes' is in scope */
886 if (UNLIKELY(dst_utf8 && IN_BYTES)) {
889 /* undo all the negative lengths which flag utf8-ness */
890 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
891 SSize_t len = svpv_p->len;
897 /* grow += total of lengths of constant string segments */
900 len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
901 : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
902 slow_concat = cBOOL(len);
906 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
909 const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
910 if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
911 && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
912 /* separate sets of lengths for plain and utf8 */
913 const_lens += nargs + 1;
915 /* If the result is utf8 but some of the args aren't,
916 * calculate how much extra growth is needed for all the chars
917 * which will expand to two utf8 bytes.
918 * Also, if the growth is non-zero, negate the length to indicate
919 * that this is a variant string. Conversely, un-negate the
920 * length on utf8 args (which was only needed to flag non-utf8
921 * args in this loop */
922 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
931 extra = variant_under_utf8_count((U8 *) svpv_p->pv,
932 (U8 *) svpv_p->pv + len);
933 if (UNLIKELY(extra)) {
935 /* -ve len indicates special handling */
936 svpv_p->len = -(len + extra);
942 const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
944 /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
945 * already have been dropped */
946 assert(!SvIsCOW(targ));
947 targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ));
950 /* --------------------------------------------------------------
953 * Now that targ has been grown, we know the final address of the targ
954 * PVX, if needed. Preserve / move targ contents if appending or if
955 * targ appears on RHS.
957 * Also update svpv_buf slots in targ_chain.
959 * Don't bother with any of this if the target length is zero:
960 * targ_len is set to zero unless we're appending or targ appears on
961 * RHS. And even if it is, we can optimise by skipping this chunk of
962 * code for zero targ_len. In the latter case, we don't need to update
963 * the slots in targ_chain with the (zero length) target string, since
964 * we set the len in such slots to 0 earlier, and since the Copy() is
965 * skipped on zero length, it doesn't matter what svpv_p->pv contains.
967 * On entry to this section the (pv,len) pairs in svpv_buf have the
968 * following meanings:
969 * (pv, len) a pure-plain or utf8 string
970 * (pv, -(len+extra)) a plain string which will expand by 'extra'
971 * bytes when converted to utf8
972 * (NULL, 0) left-most targ \ linked together R-to-L
973 * (next, 0) other targ / in targ_chain
975 * On exit, the targ contents will have been moved to the
976 * earliest place they are needed (e.g. $x = "abc$x" will shift them
977 * 3 bytes, while $x .= ... will leave them at the beginning);
978 * and dst_pv will point to the location within SvPVX(targ) where the
979 * next arg should be copied.
982 svpv_base = svpv_buf;
985 struct multiconcat_svpv *tc_stop;
986 char *targ_buf = targ_pv; /* ptr to original targ string */
988 assert(is_append || targ_count);
995 /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
996 * Move the current contents of targ to the first
997 * position where it's needed, and use that as the src buffer
998 * for any further uses (such as the second RHS $t above).
999 * In calculating the first position, we need to sum the
1000 * lengths of all consts and args before that.
1003 UNOP_AUX_item *lens = const_lens;
1004 /* length of first const string segment */
1005 STRLEN offset = lens->ssize > 0 ? lens->ssize : 0;
1013 break; /* the first targ argument */
1014 /* add lengths of the next arg and const string segment */
1016 if (len < 0) /* variant args have this */
1018 offset += (STRLEN)len;
1019 len = (++lens)->ssize;
1020 offset += (len >= 0) ? (STRLEN)len : 0;
1022 /* all args and consts so far are empty; update
1023 * the start position for the concat later */
1028 assert(svpv_p < svpv_end);
1033 Move(targ_pv, targ_buf, targ_len, char);
1034 /* a negative length implies don't Copy(), but do increment */
1035 svpv_p->len = -((SSize_t)targ_len);
1039 /* skip the first targ copy */
1042 targ_pv += targ_len;
1045 /* Don't populate the first targ slot in the loop below; it's
1046 * either not used because we advanced svpv_base beyond it, or
1047 * we already stored the special -targ_len value in it
1052 /* populate slots in svpv_buf representing targ on RHS */
1053 while (targ_chain != tc_stop) {
1054 struct multiconcat_svpv *p = targ_chain;
1055 targ_chain = (struct multiconcat_svpv *)(p->pv);
1057 p->len = (SSize_t)targ_len;
1062 /* --------------------------------------------------------------
1065 * Append all the args in svpv_buf, plus the const strings, to targ.
1067 * On entry to this section the (pv,len) pairs in svpv_buf have the
1068 * following meanings:
1069 * (pv, len) a pure-plain or utf8 string (which may be targ)
1070 * (pv, -(len+extra)) a plain string which will expand by 'extra'
1071 * bytes when converted to utf8
1072 * (0, -len) left-most targ, whose content has already
1073 * been copied. Just advance targ_pv by len.
1076 /* If there are no constant strings and no special case args
1077 * (svpv_p->len < 0), use a simpler, more efficient concat loop
1080 for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
1081 SSize_t len = svpv_p->len;
1084 Copy(svpv_p->pv, targ_pv, len, char);
1087 const_lens += (svpv_end - svpv_base + 1);
1090 /* Note that we iterate the loop nargs+1 times: to append nargs
1091 * arguments and nargs+1 constant strings. For example, "-$a-$b-"
1096 SSize_t len = (const_lens++)->ssize;
1098 /* append next const string segment */
1100 Copy(const_pv, targ_pv, len, char);
1105 if (svpv_p == svpv_end)
1108 /* append next arg */
1111 if (LIKELY(len > 0)) {
1112 Copy(svpv_p->pv, targ_pv, len, char);
1115 else if (UNLIKELY(len < 0)) {
1116 /* negative length indicates two special cases */
1117 const char *p = svpv_p->pv;
1120 /* copy plain-but-variant pv to a utf8 targ */
1121 char * end_pv = targ_pv + len;
1123 while (targ_pv < end_pv) {
1125 append_utf8_from_native_byte(c, (U8**)&targ_pv);
1129 /* arg is already-copied targ */
1138 SvCUR_set(targ, targ_pv - SvPVX(targ));
1139 assert(grow >= SvCUR(targ) + 1);
1140 assert(SvLEN(targ) >= SvCUR(targ) + 1);
1142 /* --------------------------------------------------------------
1148 rpp_popfree_to(PL_stack_sp - stack_adj);
1154 /* --------------------------------------------------------------
1157 * We only get here if any of the args (or targ too in the case of
1158 * append) have something which might cause side effects, such
1159 * as magic, overload, or an undef value in the presence of warnings.
1160 * In that case, any earlier attempt to stringify the args will have
1161 * been abandoned, and we come here instead.
1163 * Here, we concat each arg in turn the old-fashioned way: essentially
1164 * emulating pp_concat() in a loop. This means that all the weird edge
1165 * cases will be handled correctly, if not necessarily speedily.
1167 * Note that some args may already have been stringified - those are
1168 * processed again, which is safe, since only args without side-effects
1169 * were stringified earlier.
1181 const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1182 SV *csv = NULL; /* SV which will hold cpv */
1183 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
1184 Size_t arg_count = 0; /* how many args have been processed */
1187 cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1191 svp = toparg - nargs + 1;
1195 * plus possible nargs+1 consts,
1196 * plus, if appending, a final targ in an extra last iteration
1200 for (i = 0; i <= n; i++) {
1203 /* if necessary, stringify the final RHS result in
1204 * something like $targ .= "$a$b$c" - simulating
1208 && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY)
1210 /* extra conditions for backwards compatibility:
1211 * probably incorrect, but keep the existing behaviour
1212 * for now. The rules are:
1213 * $x = "$ov" single arg: stringify;
1214 * $x = "$ov$y" multiple args: don't stringify,
1215 * $lex = "$ov$y$z" except TARGMY with at least 2 concats
1220 && (PL_op->op_private & OPpTARGET_MY)
1221 && !(PL_op->op_private & OPpLVAL_INTRO)
1226 assert(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset);
1227 SV *tmp = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset);
1228 sv_copypv(tmp, left);
1233 /* do one extra iteration to handle $targ in $targ .= ... */
1234 if (i == n && !is_append)
1237 /* get the next arg SV or regen the next const SV */
1238 len = lens[i >> 1].ssize;
1240 /* handle the final targ .= (....) */
1245 right = svp[(i >> 1)];
1247 continue; /* no const in this position */
1249 /* Use one of our PADTMPs to fake up the SV which would
1250 * have been returned by an OP_CONST. Try to reuse it if
1251 * possible. If the refcount has gone up, something like
1252 * overload code has taken a reference to it, so abandon
1254 if (!csv || SvREFCNT(csv) > 1 || SvLEN(csv) != 0) {
1256 csv = newSV_type_mortal(SVt_PV);
1258 assert(aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset);
1260 aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset);
1261 SvUPGRADE(csv, SVt_PV);
1269 /* use the const string buffer directly with the
1272 /* cast away constness because we think we know it's safe
1274 SvPV_set(csv, (char *)cpv);
1276 SvCUR_set(csv, len);
1284 if (arg_count <= 1) {
1286 continue; /* need at least two SVs to concat together */
1289 if (arg_count == 2 && i < n) {
1290 /* for the first concat, use one of the PADTMPs to emulate
1291 * the PADTMP from OP_CONST. In later iterations this will
1293 nexttarg = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP0].pad_offset);
1301 /* Handle possible overloading.
1302 * This is basically an unrolled
1303 * tryAMAGICbin_MG(concat_amg, AMGf_assign);
1305 * Perl_try_amagic_bin()
1306 * call, but using left and right rather than
1307 * PL_stack_sp[-1], PL_stack_sp[0],
1308 * and not relying on OPf_STACKED implying .=
1311 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
1316 if ((SvAMAGIC(left) || SvAMAGIC(right))
1317 /* sprintf doesn't do concat overloading,
1318 * but allow for $x .= sprintf(...)
1320 && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
1324 SV * const tmpsv = amagic_call(left, right, concat_amg,
1325 (nextappend ? AMGf_assign: 0));
1327 /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
1328 * here, which isn't needed as any implicit
1329 * assign done under OPpTARGET_MY is done after
1332 sv_setsv(left, tmpsv);
1341 /* if both args are the same magical value, make one a copy */
1342 if (left == right && SvGMAGICAL(left)) {
1343 SV * targetsv = right;
1344 /* Print the uninitialized warning now, so it includes the
1347 if (ckWARN(WARN_UNINITIALIZED))
1348 report_uninit(right);
1349 targetsv = &PL_sv_no;
1351 left = sv_mortalcopy_flags(targetsv, 0);
1356 /* nexttarg = left . right */
1357 S_do_concat(aTHX_ left, right, nexttarg, 0);
1361 /* Return the result of all RHS concats, unless this op includes
1362 * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
1363 * to target (which will be $lex or expr).
1364 * If we are appending, targ will already have been appended to in
1367 && ( (PL_op->op_flags & OPf_STACKED)
1368 || (PL_op->op_private & OPpTARGET_MY))
1370 sv_setsv(targ, left);
1376 rpp_popfree_to(PL_stack_sp - stack_adj);
1383 /* push the elements of av onto the stack.
1384 * Returns PL_op->op_next to allow tail-call optimisation of its callers */
1387 S_pushav(pTHX_ AV* const av)
1389 const SSize_t maxarg = AvFILL(av) + 1;
1391 if (UNLIKELY(SvRMAGICAL(av))) {
1393 for (i=0; i < (PADOFFSET)maxarg; i++) {
1394 SV ** const svp = av_fetch(av, i, FALSE);
1395 rpp_push_1(LIKELY(svp)
1397 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1405 for (i=0; i < (PADOFFSET)maxarg; i++) {
1406 SV *sv = AvARRAY(av)[i];
1407 rpp_push_1(LIKELY(sv)
1409 : UNLIKELY(PL_op->op_flags & OPf_MOD)
1419 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
1423 PADOFFSET base = PL_op->op_targ;
1424 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
1425 if (PL_op->op_flags & OPf_SPECIAL) {
1426 /* fake the RHS of my ($x,$y,..) = @_ */
1427 PUSHMARK(PL_stack_sp);
1428 (void)S_pushav(aTHX_ GvAVn(PL_defgv));
1431 /* note, this is only skipped for compile-time-known void cxt */
1432 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
1436 PUSHMARK(PL_stack_sp);
1437 for (i = 0; i <count; i++)
1438 rpp_push_1(PAD_SV(base+i));
1441 if (PL_op->op_private & OPpLVAL_INTRO) {
1442 SV **svp = &(PAD_SVl(base));
1443 const UV payload = (UV)(
1444 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1445 | (count << SAVE_TIGHT_SHIFT)
1446 | SAVEt_CLEARPADRANGE);
1449 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
1450 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1458 for (i = 0; i <count; i++)
1459 SvPADSTALE_off(*svp++); /* mark lexical as active */
1468 OP * const op = PL_op;
1469 /* access PL_curpad once */
1470 SV ** const padentry = &(PAD_SVl(op->op_targ));
1476 if (op->op_flags & OPf_MOD) {
1477 if (op->op_private & OPpLVAL_INTRO)
1478 if (!(op->op_private & OPpPAD_STATE))
1479 save_clearsv(padentry);
1480 if (op->op_private & OPpDEREF) {
1481 /* *sp is equivalent to TARG here. Using *sp rather
1482 than TARG reduces the scope of TARG, so it does not
1483 span the call to save_clearsv, resulting in smaller
1486 vivify_ref(*PL_stack_sp, op->op_private & OPpDEREF));
1493 PP_wrapped(pp_readline, ((PL_op->op_flags & OPf_STACKED) ? 2 : 1), 0)
1496 /* pp_coreargs pushes a NULL to indicate no args passed to
1497 * CORE::readline() */
1500 tryAMAGICunTARGETlist(iter_amg, 0);
1501 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1503 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
1504 if (!isGV_with_GP(PL_last_in_gv)) {
1505 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
1506 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
1509 XPUSHs(MUTABLE_SV(PL_last_in_gv));
1511 Perl_pp_rv2gv(aTHX);
1512 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1513 assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
1516 return do_readline();
1522 if (rpp_try_AMAGIC_2(eq_amg, AMGf_numeric))
1525 SV *right = PL_stack_sp[0];
1526 SV *left = PL_stack_sp[-1];
1528 U32 flags_and = SvFLAGS(left) & SvFLAGS(right);
1529 U32 flags_or = SvFLAGS(left) | SvFLAGS(right);
1531 rpp_replace_2_1(boolSV(
1532 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
1533 ? (SvIVX(left) == SvIVX(right))
1534 : (flags_and & SVf_NOK)
1535 ? (SvNVX(left) == SvNVX(right))
1536 : ( do_ncmp(left, right) == 0)
1542 /* also used for: pp_i_preinc() */
1546 SV *sv = *PL_stack_sp;
1548 if (LIKELY(((sv->sv_flags &
1549 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1550 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1552 && SvIVX(sv) != IV_MAX)
1554 SvIV_set(sv, SvIVX(sv) + 1);
1556 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1563 /* also used for: pp_i_predec() */
1567 SV *sv = *PL_stack_sp;
1569 if (LIKELY(((sv->sv_flags &
1570 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1571 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1573 && SvIVX(sv) != IV_MIN)
1575 SvIV_set(sv, SvIVX(sv) - 1);
1577 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
1584 /* also used for: pp_orassign() */
1594 if (PL_op->op_type == OP_OR)
1596 return cLOGOP->op_other;
1601 /* also used for: pp_dor() pp_dorassign() */
1605 SV* sv = *PL_stack_sp;
1606 bool defined = FALSE;
1607 const int op_type = PL_op->op_type;
1608 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
1612 if (UNLIKELY(!sv || !SvANY(sv))) {
1613 if (op_type == OP_DOR)
1615 return cLOGOP->op_other;
1620 if (UNLIKELY(!sv || !SvANY(sv))) {
1621 rpp_replace_1_1(&PL_sv_no);
1626 /* Historically what followed was a switch on SvTYPE(sv), handling SVt_PVAV,
1627 * SVt_PVCV, SVt_PVHV and "default". `defined &sub` is still valid syntax,
1628 * hence we still need the special case PVCV code. But AVs and HVs now
1629 * should never arrive here... */
1631 assert(SvTYPE(sv) != SVt_PVAV);
1632 assert(SvTYPE(sv) != SVt_PVHV);
1635 if (UNLIKELY(SvTYPE(sv) == SVt_PVCV)) {
1636 if (CvROOT(sv) || CvXSUB(sv))
1648 if(op_type == OP_DOR)
1650 return cLOGOP->op_other;
1652 /* assuming OP_DEFINED */
1653 rpp_replace_1_1(defined ? &PL_sv_yes : &PL_sv_no);
1661 bool useleft; SV *svl, *svr;
1662 SV *targ = (PL_op->op_flags & OPf_STACKED)
1664 : PAD_SV(PL_op->op_targ);
1666 if (rpp_try_AMAGIC_2(add_amg, AMGf_assign|AMGf_numeric))
1669 svr = PL_stack_sp[0];
1670 svl = PL_stack_sp[-1];
1672 #ifdef PERL_PRESERVE_IVUV
1674 /* special-case some simple common cases */
1675 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1677 U32 flags = (svl->sv_flags & svr->sv_flags);
1678 if (flags & SVf_IOK) {
1679 /* both args are simple IVs */
1684 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1685 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1687 /* if both are in a range that can't under/overflow, do a
1688 * simple integer add: if the top of both numbers
1689 * are 00 or 11, then it's safe */
1690 if (!( ((topl+1) | (topr+1)) & 2)) {
1691 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1692 rpp_replace_2_1(targ);
1697 else if (flags & SVf_NOK) {
1698 /* both args are NVs */
1702 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1703 /* nothing was lost by converting to IVs */
1706 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1707 rpp_replace_2_1(targ);
1714 useleft = USE_LEFT(svl);
1715 /* We must see if we can perform the addition with integers if possible,
1716 as the integer code detects overflow while the NV code doesn't.
1717 If either argument hasn't had a numeric conversion yet attempt to get
1718 the IV. It's important to do this now, rather than just assuming that
1719 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1720 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1721 integer in case the second argument is IV=9223372036854775806
1722 We can (now) rely on sv_2iv to do the right thing, only setting the
1723 public IOK flag if the value in the NV (or PV) slot is truly integer.
1725 A side effect is that this also aggressively prefers integer maths over
1726 fp maths for integer values.
1728 How to detect overflow?
1730 C 99 section 6.2.6.1 says
1732 The range of nonnegative values of a signed integer type is a subrange
1733 of the corresponding unsigned integer type, and the representation of
1734 the same value in each type is the same. A computation involving
1735 unsigned operands can never overflow, because a result that cannot be
1736 represented by the resulting unsigned integer type is reduced modulo
1737 the number that is one greater than the largest value that can be
1738 represented by the resulting type.
1742 which I read as "unsigned ints wrap."
1744 signed integer overflow seems to be classed as "exception condition"
1746 If an exceptional condition occurs during the evaluation of an
1747 expression (that is, if the result is not mathematically defined or not
1748 in the range of representable values for its type), the behavior is
1751 (6.5, the 5th paragraph)
1753 I had assumed that on 2s complement machines signed arithmetic would
1754 wrap, hence coded pp_add and pp_subtract on the assumption that
1755 everything perl builds on would be happy. After much wailing and
1756 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1757 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
1758 unsigned code below is actually shorter than the old code. :-)
1761 if (SvIV_please_nomg(svr)) {
1762 /* Unless the left argument is integer in range we are going to have to
1763 use NV maths. Hence only attempt to coerce the right argument if
1764 we know the left is integer. */
1771 a_valid = auvok = 1;
1772 /* left operand is undef, treat as zero. + 0 is identity,
1773 Could TARGi or TARGu right now, but space optimise by not
1774 adding lots of code to speed up what is probably a rare-ish
1777 /* Left operand is defined, so is it IV? */
1778 if (SvIV_please_nomg(svl)) {
1779 if ((auvok = SvUOK(svl)))
1782 const IV aiv = SvIVX(svl);
1785 auvok = 1; /* Now acting as a sign flag. */
1787 /* Using 0- here and later to silence bogus warning
1789 auv = (UV) (0 - (UV) aiv);
1796 bool result_good = 0;
1799 bool buvok = SvUOK(svr);
1804 const IV biv = SvIVX(svr);
1809 buv = (UV) (0 - (UV) biv);
1811 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1812 else "IV" now, independent of how it came in.
1813 if a, b represents positive, A, B negative, a maps to -A etc
1818 all UV maths. negate result if A negative.
1819 add if signs same, subtract if signs differ. */
1821 if (auvok ^ buvok) {
1825 /* Must get smaller */
1830 if (result <= buv) {
1831 /* result really should be -(auv-buv). as its negation
1832 of true value, need to swap our result flag */
1848 if (result <= (UV)IV_MIN)
1849 TARGi(result == (UV)IV_MIN
1850 ? IV_MIN : -(IV)result, 1);
1852 /* result valid, but out of range for IV. */
1853 TARGn(-(NV)result, 1);
1856 rpp_replace_2_1(targ);
1858 } /* Overflow, drop through to NVs. */
1863 useleft = USE_LEFT(svl);
1867 NV value = SvNV_nomg(svr);
1869 /* left operand is undef, treat as zero. + 0.0 is identity. */
1873 TARGn(value + SvNV_nomg(svl), 1);
1875 rpp_replace_2_1(targ);
1881 /* also used for: pp_aelemfast_lex() */
1885 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
1886 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
1887 const U32 lval = PL_op->op_flags & OPf_MOD;
1888 const I8 key = (I8)PL_op->op_private;
1892 assert(SvTYPE(av) == SVt_PVAV);
1894 /* inlined av_fetch() for simple cases ... */
1895 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1896 sv = AvARRAY(av)[key];
1905 /* ... else do it the hard way */
1906 svp = av_fetch(av, key, lval);
1907 sv = (svp ? *svp : &PL_sv_undef);
1909 if (UNLIKELY(!svp && lval))
1910 DIE(aTHX_ PL_no_aelem, (int)key);
1912 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
1924 do_join(TARG, *MARK, MARK, PL_stack_sp);
1925 rpp_popfree_to(MARK - 1);
1931 /* Oversized hot code. */
1933 /* also used for: pp_say() */
1941 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1945 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1948 if (MARK == ORIGMARK) {
1949 /* If using default handle then we need to make space to
1950 * pass object as 1st arg, so move other args up ...
1953 MARK = ORIGMARK; /* stack may have been realloced */
1955 Move(MARK, MARK + 1, (PL_stack_sp - MARK) + 1, SV*);
1959 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
1961 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1962 | (PL_op->op_type == OP_SAY
1963 ? TIED_METHOD_SAY : 0)),
1964 PL_stack_sp - mark);
1968 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
1969 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1972 SETERRNO(EBADF,RMS_IFI);
1975 else if (!(fp = IoOFP(io))) {
1977 report_wrongway_fh(gv, '<');
1980 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1984 SV * const ofs = GvSV(PL_ofsgv); /* $, */
1986 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
1987 while (MARK <= PL_stack_sp) {
1988 if (!do_print(*MARK, fp))
1991 if (MARK <= PL_stack_sp) {
1992 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1993 if (!do_print(GvSV(PL_ofsgv), fp)) {
2001 while (MARK <= PL_stack_sp) {
2002 if (!do_print(*MARK, fp))
2007 if (MARK <= PL_stack_sp)
2010 if (PL_op->op_type == OP_SAY) {
2011 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
2014 else if (PL_ors_sv && SvOK(PL_ors_sv))
2015 if (!do_print(PL_ors_sv, fp)) /* $\ */
2018 if (IoFLAGS(io) & IOf_FLUSH)
2019 if (PerlIO_flush(fp) == EOF)
2023 rpp_popfree_to(ORIGMARK);
2024 rpp_xpush_1(&PL_sv_yes);
2028 rpp_popfree_to(ORIGMARK);
2029 rpp_xpush_1(&PL_sv_undef);
2034 /* do the common parts of pp_padhv() and pp_rv2hv()
2035 * It assumes the caller has done rpp_extend(1) or equivalent.
2036 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
2037 * 'has_targ' indicates that the op has a target - this should
2038 * be a compile-time constant so that the code can constant-folded as
2039 * appropriate. has_targ also implies that the caller has left an
2040 * arg on the stack which needs freeing.
2043 PERL_STATIC_INLINE OP*
2044 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
2046 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
2048 if (gimme == G_LIST) {
2049 /* push all (key,value) pairs onto stack */
2050 if (has_targ) { /* i.e. if has arg still on stack */
2051 #ifdef PERL_RC_STACK
2052 SSize_t sp_base = PL_stack_sp - PL_stack_base;
2054 /* Now safe to free the original arg on the stack and shuffle
2055 * down one place anything pushed on top of it */
2056 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
2057 SV *old_sv = PL_stack_sp[-nitems];
2059 Move(PL_stack_sp - nitems + 1,
2060 PL_stack_sp - nitems, nitems, SV*);
2062 SvREFCNT_dec_NN(old_sv);
2074 /* 'keys %h' masquerading as '%h': reset iterator */
2075 (void)hv_iterinit(hv);
2077 if (gimme == G_VOID) {
2083 bool is_bool = ( PL_op->op_private & OPpTRUEBOOL
2084 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
2085 && block_gimme() == G_VOID));
2087 MAGIC *is_tied_mg = SvRMAGICAL(hv)
2088 ? mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied)
2093 if (UNLIKELY(is_tied_mg)) {
2094 if (is_keys && !is_bool) {
2096 while (hv_iternext(hv))
2098 /* hv finished with. Safe to free arg now */
2104 sv = magic_scalarpack(hv, is_tied_mg);
2105 /* hv finished with. Safe to free arg now */
2112 #if defined(DYNAMIC_ENV_FETCH) && defined(VMS)
2113 /* maybe nothing set up %ENV for iteration yet...
2114 do this always (not just if HvUSEDKEYS(hv) is currently 0) because
2115 we ought to give a *consistent* answer to "how many keys?"
2116 whether we ask this op in scalar context, or get the list of all
2117 keys then check its length, and whether we do either with or without
2118 an %ENV lookup first. prime_env_iter() returns quickly if nothing
2120 if (SvRMAGICAL((const SV *)hv)
2121 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2127 /* hv finished with. Safe to free arg now */
2132 sv = i ? &PL_sv_yes : &PL_sv_zero;
2145 /* parent op should be an unused OP_KEYS whose targ we can
2150 assert(!OpHAS_SIBLING(PL_op));
2151 k = PL_op->op_sibparent;
2152 assert(k->op_type == OP_KEYS);
2153 TARG = PAD_SV(k->op_targ);
2158 rpp_push_1_norc(newSViv(i));
2166 /* This is also called directly by pp_lvavref. */
2172 assert(SvTYPE(TARG) == SVt_PVAV);
2173 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
2174 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
2175 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
2178 if (PL_op->op_flags & OPf_REF)
2181 if (PL_op->op_private & OPpMAYBE_LVSUB) {
2182 const I32 flags = is_lvalue_sub();
2183 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2184 if (GIMME_V == G_SCALAR)
2185 /* diag_listed_as: Can't return %s to lvalue scalar context */
2186 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
2192 if (gimme == G_LIST)
2193 return S_pushav(aTHX_ (AV*)TARG);
2195 if (gimme == G_VOID)
2199 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
2202 else if (PL_op->op_private & OPpTRUEBOOL)
2206 rpp_push_1_norc(newSViv(maxarg));
2222 assert(SvTYPE(TARG) == SVt_PVHV);
2223 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
2224 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
2225 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
2229 if (PL_op->op_flags & OPf_REF) {
2233 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
2234 const I32 flags = is_lvalue_sub();
2235 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2236 if (GIMME_V == G_SCALAR)
2237 /* diag_listed_as: Can't return %s to lvalue scalar context */
2238 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
2246 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
2247 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
2252 /* also used for: pp_rv2hv() */
2253 /* also called directly by pp_lvavref */
2257 SV *sv = *PL_stack_sp;
2258 const U8 gimme = GIMME_V;
2259 static const char an_array[] = "an ARRAY";
2260 static const char a_hash[] = "a HASH";
2261 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
2262 || PL_op->op_type == OP_LVAVREF;
2263 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
2267 if (UNLIKELY(SvAMAGIC(sv))) {
2268 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
2271 if (UNLIKELY(SvTYPE(sv) != type))
2272 /* diag_listed_as: Not an ARRAY reference */
2273 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
2274 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
2275 && PL_op->op_private & OPpLVAL_INTRO))
2276 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
2278 else if (UNLIKELY(SvTYPE(sv) != type)) {
2281 if (!isGV_with_GP(sv)) {
2282 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
2288 gv = MUTABLE_GV(sv);
2290 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
2291 if (PL_op->op_private & OPpLVAL_INTRO)
2292 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
2294 if (PL_op->op_flags & OPf_REF) {
2295 rpp_replace_1_1(sv);
2298 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
2299 const I32 flags = is_lvalue_sub();
2300 if (flags && !(flags & OPpENTERSUB_INARGS)) {
2301 if (gimme != G_LIST)
2302 goto croak_cant_return;
2303 rpp_replace_1_1(sv);
2309 AV *const av = MUTABLE_AV(sv);
2311 if (gimme == G_LIST) {
2312 #ifdef PERL_RC_STACK
2313 SSize_t sp_base = PL_stack_sp - PL_stack_base;
2314 (void)S_pushav(aTHX_ av);
2315 /* Now safe to free the original arg on the stack and shuffle
2316 * down one place anything pushed on top of it */
2317 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
2318 SV *old_sv = PL_stack_sp[-nitems];
2320 Move(PL_stack_sp - nitems + 1,
2321 PL_stack_sp - nitems, nitems, SV*);
2323 SvREFCNT_dec_NN(old_sv);
2327 return S_pushav(aTHX_ av);
2331 if (gimme == G_SCALAR) {
2332 const SSize_t maxarg = AvFILL(av) + 1;
2333 if (PL_op->op_private & OPpTRUEBOOL)
2334 rpp_replace_1_1(maxarg ? &PL_sv_yes : &PL_sv_zero);
2338 rpp_replace_1_1(targ);
2343 /* this static function is responsible for popping sv off stack */
2344 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
2345 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2351 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2352 is_pp_rv2av ? "array" : "hash");
2357 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
2359 PERL_ARGS_ASSERT_DO_ODDBALL;
2362 if (ckWARN(WARN_MISC)) {
2364 if (oddkey == firstkey &&
2366 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2367 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
2369 err = "Reference found where even-sized list expected";
2372 err = "Odd number of elements in hash assignment";
2373 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
2380 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2381 * are common to both the LHS and RHS of an aassign, and replace them
2382 * with copies. All these copies are made before the actual list assign is
2385 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2386 * element ($b) to the first LH element ($a), modifies $a; when the
2387 * second assignment is done, the second RH element now has the wrong
2388 * value. So we initially replace the RHS with ($b, copy($a)).
2389 * Note that we don't need to make a copy of $b.
2391 * The algorithm below works by, for every RHS element, mark the
2392 * corresponding LHS target element with SVf_BREAK. Then if the RHS
2393 * element is found with SVf_BREAK set, it means it would have been
2394 * modified, so make a copy.
2395 * Note that by scanning both LHS and RHS in lockstep, we avoid
2396 * unnecessary copies (like $b above) compared with a naive
2397 * "mark all LHS; copy all marked RHS; unmark all LHS".
2399 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2400 * it can't be common and can be skipped.
2402 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2403 * that we thought we didn't need to call S_aassign_copy_common(), but we
2404 * have anyway for sanity checking. If we find we need to copy, then panic.
2407 PERL_STATIC_INLINE void
2408 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
2409 SV **firstrelem, SV **lastrelem
2417 SSize_t lcount = lastlelem - firstlelem + 1;
2418 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2419 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
2420 bool copy_all = FALSE;
2422 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2423 assert(firstlelem < lastlelem); /* at least 2 LH elements */
2424 assert(firstrelem < lastrelem); /* at least 2 RH elements */
2428 /* we never have to copy the first RH element; it can't be corrupted
2429 * by assigning something to the corresponding first LH element.
2430 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2432 relem = firstrelem + 1;
2434 for (; relem <= lastrelem; relem++) {
2437 /* mark next LH element */
2439 if (--lcount >= 0) {
2442 if (UNLIKELY(!svl)) {/* skip AV alias marker */
2443 assert (lelem <= lastlelem);
2449 if (SvSMAGICAL(svl)) {
2452 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2455 /* this LH element will consume all further args;
2456 * no need to mark any further LH elements (if any).
2457 * But we still need to scan any remaining RHS elements;
2458 * set lcount negative to distinguish from lcount == 0,
2459 * so the loop condition continues being true
2462 lelem--; /* no need to unmark this element */
2464 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
2465 SvFLAGS(svl) |= SVf_BREAK;
2469 /* don't check RH element if no SVf_BREAK flags set yet */
2476 /* see if corresponding RH element needs copying */
2482 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
2483 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
2487 /* op_dump(PL_op); */
2489 "panic: aassign skipped needed copy of common RH elem %"
2490 UVuf, (UV)(relem - firstrelem));
2494 TAINT_NOT; /* Each item is independent */
2496 /* Dear TODO test in t/op/sort.t, I love you.
2497 (It's relying on a panic, not a "semi-panic" from newSVsv()
2498 and then an assertion failure below.) */
2499 if (UNLIKELY(SvIS_FREED(svr))) {
2500 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2503 /* avoid break flag while copying; otherwise COW etc
2505 SvFLAGS(svr) &= ~SVf_BREAK;
2506 /* Not newSVsv(), as it does not allow copy-on-write,
2507 resulting in wasteful copies.
2508 Also, we use SV_NOSTEAL in case the SV is used more than
2509 once, e.g. (...) = (f())[0,0]
2510 Where the same SV appears twice on the RHS without a ref
2511 count bump. (Although I suspect that the SV won't be
2512 stealable here anyway - DAPM).
2514 #ifdef PERL_RC_STACK
2515 *relem = newSVsv_flags(svr,
2516 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2517 SvREFCNT_dec_NN(svr);
2519 *relem = sv_mortalcopy_flags(svr,
2520 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2522 /* ... but restore afterwards in case it's needed again,
2523 * e.g. ($a,$b,$c) = (1,$a,$a)
2525 SvFLAGS(svr) |= brk;
2537 while (lelem > firstlelem) {
2538 SV * const svl = *(--lelem);
2540 SvFLAGS(svl) &= ~SVf_BREAK;
2548 SV **lastlelem = PL_stack_sp;
2549 SV **lastrelem = PL_stack_base + POPMARK;
2550 SV **firstrelem = PL_stack_base + POPMARK + 1;
2551 SV **firstlelem = lastrelem + 1;
2556 /* PL_delaymagic is restored by JMPENV_POP on dieing, so we
2557 * only need to save locally, not on the save stack */
2558 U16 old_delaymagic = PL_delaymagic;
2563 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
2565 /* If there's a common identifier on both sides we have to take
2566 * special care that assigning the identifier on the left doesn't
2567 * clobber a value on the right that's used later in the list.
2570 /* at least 2 LH and RH elements, or commonality isn't an issue */
2571 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2572 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2573 if (SvGMAGICAL(*relem))
2576 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2577 if (*lelem && SvSMAGICAL(*lelem))
2580 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2581 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2582 /* skip the scan if all scalars have a ref count of 1 */
2583 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2585 if (!sv || SvREFCNT(sv) == 1)
2587 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2594 S_aassign_copy_common(aTHX_
2595 firstlelem, lastlelem, firstrelem, lastrelem
2605 /* on debugging builds, do the scan even if we've concluded we
2606 * don't need to, then panic if we find commonality. Note that the
2607 * scanner assumes at least 2 elements */
2608 if (firstlelem < lastlelem && firstrelem < lastrelem) {
2619 if (relem > lastrelem)
2622 /* first lelem loop while there are still relems */
2623 while (LIKELY(lelem <= lastlelem)) {
2627 TAINT_NOT; /* Each item stands on its own, taintwise. */
2629 assert(relem <= lastrelem);
2630 if (UNLIKELY(!lsv)) {
2633 ASSUME(SvTYPE(lsv) == SVt_PVAV);
2636 switch (SvTYPE(lsv)) {
2641 SSize_t nelems = lastrelem - relem + 1;
2642 AV *ary = MUTABLE_AV(lsv);
2644 /* Assigning to an aggregate is tricky. First there is the
2645 * issue of commonality, e.g. @a = ($a[0]). Since the
2646 * stack isn't refcounted, clearing @a prior to storing
2647 * elements will free $a[0]. Similarly with
2648 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2650 * The way to avoid these issues is to make the copy of each
2651 * SV (and we normally store a *copy* in the array) *before*
2652 * clearing the array. But this has a problem in that
2653 * if the code croaks during copying, the not-yet-stored copies
2654 * could leak. One way to avoid this is to make all the copies
2655 * mortal, but that's quite expensive.
2657 * The current solution to these issues is to use a chunk
2658 * of the tmps stack as a temporary refcounted-stack. SVs
2659 * will be put on there during processing to avoid leaks,
2660 * but will be removed again before the end of this block,
2661 * so free_tmps() is never normally called. Also, the
2662 * sv_refcnt of the SVs doesn't have to be manipulated, since
2663 * the ownership of 1 reference count is transferred directly
2664 * from the tmps stack to the AV when the SV is stored.
2666 * We disarm slots in the temps stack by storing PL_sv_undef
2667 * there: it doesn't matter if that SV's refcount is
2668 * repeatedly decremented during a croak. But usually this is
2669 * only an interim measure. By the end of this code block
2670 * we try where possible to not leave any PL_sv_undef's on the
2671 * tmps stack e.g. by shuffling newer entries down.
2673 * There is one case where we don't copy: non-magical
2674 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2675 * is on the tmps stack, so its safe to directly steal the SV
2676 * rather than copying. This is common in things like function
2677 * returns, map etc, which all return a list of such SVs.
2679 * Note however something like @a = (f())[0,0], where there is
2680 * a danger of the same SV being shared: this avoided because
2681 * when the SV is stored as $a[0], its ref count gets bumped,
2682 * so the RC==1 test fails and the second element is copied
2685 * We also use one slot in the tmps stack to hold an extra
2686 * ref to the array, to ensure it doesn't get prematurely
2687 * freed. Again, this is removed before the end of this block.
2689 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2690 * @a = ($a[0]) case, but the current implementation uses the
2691 * same algorithm regardless, so ignores that flag. (It *is*
2692 * used in the hash branch below, however).
2695 /* Reserve slots for ary, plus the elems we're about to copy,
2696 * then protect ary and temporarily void the remaining slots
2697 * with &PL_sv_undef */
2698 EXTEND_MORTAL(nelems + 1);
2699 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2700 tmps_base = PL_tmps_ix + 1;
2701 for (i = 0; i < nelems; i++)
2702 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2703 PL_tmps_ix += nelems;
2705 /* Make a copy of each RHS elem and save on the tmps_stack
2706 * (or pass through where we can optimise away the copy) */
2708 if (UNLIKELY(alias)) {
2709 U32 lval = (gimme == G_LIST)
2710 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
2711 for (svp = relem; svp <= lastrelem; svp++) {
2716 DIE(aTHX_ "Assigned value is not a reference");
2717 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2718 /* diag_listed_as: Assigned value is not %s reference */
2720 "Assigned value is not a SCALAR reference");
2722 rsv = sv_mortalcopy(rsv);
2723 rpp_replace_at(svp, rsv);
2725 /* XXX else check for weak refs? */
2726 rsv = SvREFCNT_inc_NN(SvRV(rsv));
2727 assert(tmps_base <= PL_tmps_max);
2728 PL_tmps_stack[tmps_base++] = rsv;
2732 for (svp = relem; svp <= lastrelem; svp++) {
2735 if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) {
2736 /* can skip the copy */
2737 SvREFCNT_inc_simple_void_NN(rsv);
2742 /* see comment in S_aassign_copy_common about
2744 nsv = newSVsv_flags(rsv,
2745 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
2746 rpp_replace_at(svp, nsv);
2750 assert(tmps_base <= PL_tmps_max);
2751 PL_tmps_stack[tmps_base++] = rsv;
2755 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2758 /* store in the array, the SVs that are in the tmps stack */
2760 tmps_base -= nelems;
2762 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
2763 /* for arrays we can't cheat with, use the official API */
2764 av_extend(ary, nelems - 1);
2765 for (i = 0; i < nelems; i++) {
2766 SV **svp = &(PL_tmps_stack[tmps_base + i]);
2768 /* A tied store won't take ownership of rsv, so keep
2769 * the 1 refcnt on the tmps stack; otherwise disarm
2770 * the tmps stack entry */
2771 if (av_store(ary, i, rsv))
2772 *svp = &PL_sv_undef;
2773 /* av_store() may have added set magic to rsv */;
2776 /* disarm ary refcount: see comments below about leak */
2777 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2780 /* directly access/set the guts of the AV */
2781 SSize_t fill = nelems - 1;
2782 if (fill > AvMAX(ary))
2783 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2785 AvFILLp(ary) = fill;
2786 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2787 /* Quietly remove all the SVs from the tmps stack slots,
2788 * since ary has now taken ownership of the refcnt.
2789 * Also remove ary: which will now leak if we die before
2790 * the SvREFCNT_dec_NN(ary) below */
2791 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2792 Move(&PL_tmps_stack[tmps_base + nelems],
2793 &PL_tmps_stack[tmps_base - 1],
2794 PL_tmps_ix - (tmps_base + nelems) + 1,
2796 PL_tmps_ix -= (nelems + 1);
2799 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2800 /* its assumed @ISA set magic can't die and leak ary */
2801 SvSETMAGIC(MUTABLE_SV(ary));
2802 SvREFCNT_dec_NN(ary);
2804 relem = lastrelem + 1;
2808 case SVt_PVHV: { /* normal hash */
2814 SSize_t nelems = lastrelem - relem + 1;
2815 HV *hash = MUTABLE_HV(lsv);
2817 if (UNLIKELY(nelems & 1)) {
2818 do_oddball(lastrelem, relem);
2819 /* we have firstlelem to reuse, it's not needed any more */
2820 *++lastrelem = &PL_sv_undef;
2824 /* See the SVt_PVAV branch above for a long description of
2825 * how the following all works. The main difference for hashes
2826 * is that we treat keys and values separately (and have
2827 * separate loops for them): as for arrays, values are always
2828 * copied (except for the SvTEMP optimisation), since they
2829 * need to be stored in the hash; while keys are only
2830 * processed where they might get prematurely freed or
2833 /* tmps stack slots:
2834 * * reserve a slot for the hash keepalive;
2835 * * reserve slots for the hash values we're about to copy;
2836 * * preallocate for the keys we'll possibly copy or refcount bump
2838 * then protect hash and temporarily void the remaining
2839 * value slots with &PL_sv_undef */
2840 EXTEND_MORTAL(nelems + 1);
2842 /* convert to number of key/value pairs */
2845 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2846 tmps_base = PL_tmps_ix + 1;
2847 for (i = 0; i < nelems; i++)
2848 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2849 PL_tmps_ix += nelems;
2851 /* Make a copy of each RHS hash value and save on the tmps_stack
2852 * (or pass through where we can optimise away the copy) */
2854 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2857 if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) {
2858 /* can skip the copy */
2859 SvREFCNT_inc_simple_void_NN(rsv);
2864 /* see comment in S_aassign_copy_common about
2866 nsv = newSVsv_flags(rsv,
2867 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
2868 rpp_replace_at(svp, nsv);
2872 assert(tmps_base <= PL_tmps_max);
2873 PL_tmps_stack[tmps_base++] = rsv;
2875 tmps_base -= nelems;
2878 /* possibly protect keys */
2880 if (UNLIKELY(gimme == G_LIST)) {
2882 * @a = ((%h = ($$r, 1)), $r = "x");
2883 * $_++ for %h = (1,2,3,4);
2885 EXTEND_MORTAL(nelems);
2886 for (svp = relem; svp <= lastrelem; svp += 2)
2888 sv_mortalcopy_flags(*svp,
2889 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
2891 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2892 /* for possible commonality, e.g.
2894 * avoid premature freeing RHS keys by mortalising
2896 * For a magic element, make a copy so that its magic is
2897 * called *before* the hash is emptied (which may affect
2898 * a tied value for example).
2899 * In theory we should check for magic keys in all
2900 * cases, not just under OPpASSIGN_COMMON_AGG, but in
2901 * practice, !OPpASSIGN_COMMON_AGG implies only
2902 * constants or padtmps on the RHS.
2904 EXTEND_MORTAL(nelems);
2905 for (svp = relem; svp <= lastrelem; svp += 2) {
2907 if (UNLIKELY(SvGMAGICAL(rsv))) {
2910 sv_mortalcopy_flags(*svp,
2911 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
2912 /* allow other branch to continue pushing
2913 * onto tmps stack without checking each time */
2914 n = (lastrelem - relem) >> 1;
2918 PL_tmps_stack[++PL_tmps_ix] =
2919 SvREFCNT_inc_simple_NN(rsv);
2923 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2926 /* "nelems" was converted to the number of pairs earlier. */
2927 if (nelems > PERL_HASH_DEFAULT_HvMAX) {
2928 hv_ksplit(hash, nelems);
2931 /* now assign the keys and values to the hash */
2935 if (UNLIKELY(gimme == G_LIST)) {
2936 /* @a = (%h = (...)) etc */
2938 SV **topelem = relem;
2940 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2943 /* remove duplicates from list we return */
2944 if (!hv_exists_ent(hash, key, 0)) {
2945 /* copy key back: possibly to an earlier
2946 * stack location if we encountered dups earlier,
2947 * The values will be updated later
2949 rpp_replace_at(topelem, key);
2952 /* A tied store won't take ownership of val, so keep
2953 * the 1 refcnt on the tmps stack; otherwise disarm
2954 * the tmps stack entry */
2955 if (hv_store_ent(hash, key, val, 0))
2956 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2959 /* 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 rpp_replace_at(relem++,
2975 (he ? HeVAL(he) : &PL_sv_undef));
2981 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2984 if (hv_store_ent(hash, key, val, 0))
2985 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2988 /* hv_store_ent() may have added set magic to val */;
2994 /* there are still some 'live' recounts on the tmps stack
2995 * - usually caused by storing into a tied hash. So let
2996 * free_tmps() do the proper but slow job later.
2997 * Just disarm hash refcount: see comments below about leak
2999 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
3002 /* Quietly remove all the SVs from the tmps stack slots,
3003 * since hash has now taken ownership of the refcnt.
3004 * Also remove hash: which will now leak if we die before
3005 * the SvREFCNT_dec_NN(hash) below */
3006 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
3007 Move(&PL_tmps_stack[tmps_base + nelems],
3008 &PL_tmps_stack[tmps_base - 1],
3009 PL_tmps_ix - (tmps_base + nelems) + 1,
3011 PL_tmps_ix -= (nelems + 1);
3014 SvREFCNT_dec_NN(hash);
3016 relem = lastrelem + 1;
3021 if (!SvIMMORTAL(lsv)) {
3025 rpp_is_lone(lsv) && !SvSMAGICAL(lsv) &&
3026 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
3029 packWARN(WARN_MISC),
3030 "Useless assignment to a temporary"
3033 /* avoid freeing $$lsv if it might be needed for further
3034 * elements, e.g. ($ref, $foo) = (1, $$ref) */
3036 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
3037 && lelem <= lastlelem
3040 SvREFCNT_inc_simple_void_NN(ref);
3041 /* an unrolled sv_2mortal */
3043 if (UNLIKELY(ix >= PL_tmps_max))
3044 /* speculatively grow enough to cover other
3046 (void)tmps_grow_p(ix + (lastlelem - lelem));
3047 PL_tmps_stack[ix] = ref;
3050 sv_setsv(lsv, *relem);
3051 rpp_replace_at(relem, lsv);
3054 if (++relem > lastrelem)
3063 /* simplified lelem loop for when there are no relems left */
3064 while (LIKELY(lelem <= lastlelem)) {
3067 TAINT_NOT; /* Each item stands on its own, taintwise. */
3069 if (UNLIKELY(!lsv)) {
3071 ASSUME(SvTYPE(lsv) == SVt_PVAV);
3074 switch (SvTYPE(lsv)) {
3076 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
3078 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
3084 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
3089 if (!SvIMMORTAL(lsv)) {
3093 rpp_replace_at(relem++, lsv);
3098 TAINT_NOT; /* result of list assign isn't tainted */
3100 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
3101 /* Will be used to set PL_tainting below */
3102 Uid_t tmp_uid = PerlProc_getuid();
3103 Uid_t tmp_euid = PerlProc_geteuid();
3104 Gid_t tmp_gid = PerlProc_getgid();
3105 Gid_t tmp_egid = PerlProc_getegid();
3107 /* XXX $> et al currently silently ignore failures */
3108 if (PL_delaymagic & DM_UID) {
3109 #ifdef HAS_SETRESUID
3111 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
3112 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
3114 #elif defined(HAS_SETREUID)
3116 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
3117 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
3120 if ((PL_delaymagic & DM_UID) == DM_RUID) {
3121 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
3122 PL_delaymagic &= ~DM_RUID;
3124 # endif /* HAS_SETRUID */
3126 if ((PL_delaymagic & DM_UID) == DM_EUID) {
3127 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
3128 PL_delaymagic &= ~DM_EUID;
3130 # endif /* HAS_SETEUID */
3131 if (PL_delaymagic & DM_UID) {
3132 if (PL_delaymagic_uid != PL_delaymagic_euid)
3133 DIE(aTHX_ "No setreuid available");
3134 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
3136 #endif /* HAS_SETRESUID */
3138 tmp_uid = PerlProc_getuid();
3139 tmp_euid = PerlProc_geteuid();
3141 /* XXX $> et al currently silently ignore failures */
3142 if (PL_delaymagic & DM_GID) {
3143 #ifdef HAS_SETRESGID
3145 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
3146 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
3148 #elif defined(HAS_SETREGID)
3150 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
3151 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
3154 if ((PL_delaymagic & DM_GID) == DM_RGID) {
3155 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
3156 PL_delaymagic &= ~DM_RGID;
3158 # endif /* HAS_SETRGID */
3160 if ((PL_delaymagic & DM_GID) == DM_EGID) {
3161 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
3162 PL_delaymagic &= ~DM_EGID;
3164 # endif /* HAS_SETEGID */
3165 if (PL_delaymagic & DM_GID) {
3166 if (PL_delaymagic_gid != PL_delaymagic_egid)
3167 DIE(aTHX_ "No setregid available");
3168 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
3170 #endif /* HAS_SETRESGID */
3172 tmp_gid = PerlProc_getgid();
3173 tmp_egid = PerlProc_getegid();
3175 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
3176 #ifdef NO_TAINT_SUPPORT
3177 PERL_UNUSED_VAR(tmp_uid);
3178 PERL_UNUSED_VAR(tmp_euid);
3179 PERL_UNUSED_VAR(tmp_gid);
3180 PERL_UNUSED_VAR(tmp_egid);
3183 PL_delaymagic = old_delaymagic;
3185 rpp_popfree_to((gimme == G_LIST ? relem : firstrelem) - 1);
3187 if (gimme == G_SCALAR) {
3190 if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
3191 sv = (firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero;
3194 TARGi(firstlelem - firstrelem, 1);
3206 PMOP * const pm = cPMOP;
3207 REGEXP * rx = PM_GETRE(pm);
3208 regexp *prog = ReANY(rx);
3209 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
3210 SV * const rv = newSV_type_mortal(SVt_IV);
3214 SvUPGRADE(rv, SVt_IV);
3215 /* For a subroutine describing itself as "This is a hacky workaround" I'm
3216 loathe to use it here, but it seems to be the right fix. Or close.
3217 The key part appears to be that it's essential for pp_qr to return a new
3218 object (SV), which implies that there needs to be an effective way to
3219 generate a new SV from the existing SV that is pre-compiled in the
3221 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
3224 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
3225 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
3226 *cvp = cv_clone(cv);
3227 SvREFCNT_dec_NN(cv);
3231 HV *const stash = gv_stashsv(pkg, GV_ADD);
3232 SvREFCNT_dec_NN(pkg);
3233 (void)sv_bless(rv, stash);
3236 if (UNLIKELY(RXp_ISTAINTED(prog))) {
3238 SvTAINTED_on(SvRV(rv));
3245 S_are_we_in_Debug_EXECUTE_r(pTHX)
3247 /* Given a 'use re' is in effect, does it ask for outputting execution
3250 * This is separated from the sole place it's called, an inline function,
3251 * because it is the large-ish slow portion of the function */
3253 DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX;
3255 return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK));
3258 PERL_STATIC_INLINE bool
3259 S_should_we_output_Debug_r(pTHX_ regexp *prog)
3261 PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R;
3263 /* pp_match can output regex debugging info. This function returns a
3264 * boolean as to whether or not it should.
3266 * Under -Dr, it should. Any reasonable compiler will optimize this bit of
3267 * code away on non-debugging builds. */
3268 if (UNLIKELY(DEBUG_r_TEST)) {
3272 /* If the regex engine is using the non-debugging execution routine, then
3273 * no debugging should be output. Same if the field is NULL that pluggable
3274 * engines are not supposed to fill. */
3275 if ( LIKELY(prog->engine->exec == &Perl_regexec_flags)
3276 || UNLIKELY(prog->engine->op_comp == NULL))
3281 /* Otherwise have to check */
3282 return S_are_we_in_Debug_EXECUTE_r(aTHX);
3293 SSize_t curpos = 0; /* initial pos() or current $+[0] */
3296 const char *truebase; /* Start of string */
3297 REGEXP *rx = PM_GETRE(pm);
3298 regexp *prog = ReANY(rx);
3300 const U8 gimme = GIMME_V;
3302 const I32 oldsave = PL_savestack_ix;
3303 I32 had_zerolen = 0;
3307 if (PL_op->op_flags & OPf_STACKED) {
3308 targ = PL_stack_sp[0];
3309 /* We have to keep targ alive on the stack. At the end we have to
3310 * free it and shuffle down all the return values by one.
3311 * Remember the position.
3313 sp_base = PL_stack_sp - PL_stack_base;
3314 assert(sp_base > 0);
3319 targ = PAD_SV(PL_op->op_targ);
3326 /* Skip get-magic if this is a qr// clone, because regcomp has
3328 truebase = prog->mother_re
3329 ? SvPV_nomg_const(TARG, len)
3330 : SvPV_const(TARG, len);
3332 DIE(aTHX_ "panic: pp_match");
3333 strend = truebase + len;
3334 rxtainted = (RXp_ISTAINTED(prog) ||
3335 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
3338 /* We need to know this in case we fail out early - pos() must be reset */
3339 global = dynpm->op_pmflags & PMf_GLOBAL;
3341 /* PMdf_USED is set after a ?? matches once */
3344 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
3346 pm->op_pmflags & PMf_USED
3349 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3350 PerlIO_printf(Perl_debug_log, "?? already matched once");
3355 /* handle the empty pattern */
3356 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
3357 if (PL_curpm == PL_reg_curpm) {
3358 if (PL_curpm_under) {
3359 if (PL_curpm_under == PL_reg_curpm) {
3360 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3362 pm = PL_curpm_under;
3372 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
3373 if (UNLIKELY(should_we_output_Debug_r(prog))) {
3374 PerlIO_printf(Perl_debug_log,
3375 "String shorter than min possible regex match (%zd < %zd)\n",
3376 len, RXp_MINLEN(prog));
3381 /* get pos() if //g */
3383 mg = mg_find_mglob(TARG);
3384 if (mg && mg->mg_len >= 0) {
3385 curpos = MgBYTEPOS(mg, TARG, truebase, len);
3386 /* last time pos() was set, it was zero-length match */
3387 if (mg->mg_flags & MGf_MINMATCH)
3392 #ifdef PERL_SAWAMPERSAND
3393 if ( RXp_NPARENS(prog)
3395 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3396 || (dynpm->op_pmflags & PMf_KEEPCOPY)
3400 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
3401 /* In @a = /(.)/g, we iterate multiple times, but copy the buffer
3402 * only on the first iteration. Therefore we need to copy $' as well
3403 * as $&, to make the rest of the string available for captures in
3404 * subsequent iterations */
3405 if (! (global && gimme == G_LIST))
3406 r_flags |= REXEC_COPY_SKIP_POST;
3408 #ifdef PERL_SAWAMPERSAND
3409 if (dynpm->op_pmflags & PMf_KEEPCOPY)
3410 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3411 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3418 s = truebase + curpos;
3420 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
3421 had_zerolen, TARG, NULL, r_flags))
3425 if (dynpm->op_pmflags & PMf_ONCE)
3427 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
3429 dynpm->op_pmflags |= PMf_USED;
3433 RXp_MATCH_TAINTED_on(prog);
3434 TAINT_IF(RXp_MATCH_TAINTED(prog));
3438 if (global && (gimme != G_LIST || (dynpm->op_pmflags & PMf_CONTINUE))) {
3440 mg = sv_magicext_mglob(TARG);
3441 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS_END(prog,0));
3442 if (RXp_ZERO_LEN(prog))
3443 mg->mg_flags |= MGf_MINMATCH;
3445 mg->mg_flags &= ~MGf_MINMATCH;
3448 if ((!RXp_NPARENS(prog) && !global) || gimme != G_LIST) {
3449 LEAVE_SCOPE(oldsave);
3451 rpp_popfree_1(); /* free arg */
3452 rpp_push_1(&PL_sv_yes);
3456 /* push captures on stack */
3459 const I32 logical_nparens = RXp_LOGICAL_NPARENS(prog);
3460 /* This following statement is *devious* code. If we are in a global
3461 match and the pattern has no parens in it, we should return $&
3462 (offset pair 0). So we set logical_paren to 1 when we should return
3463 $&, otherwise we set it to 0.
3465 This allows us to simply add logical_nparens to logical_paren to
3466 compute the number of elements we are going to return.
3468 In the loop init we "not" it with: logical_paren = !logical_paren
3469 which results in it being 0 inside the loop when we want to return
3470 $&, and results in it being 1 when we want to return the parens.
3471 Thus we either loop over 1..logical_nparens, or just over 0.
3473 This is an elegant way to do this code-wise, but is super devious
3474 and potentially confusing. When I first saw this logic I thought
3475 "WTF?". But it makes sense after you poke it a while.
3477 Frankly I probably would have done it differently, but it works so
3478 I am leaving it. - Yves */
3479 I32 logical_paren = (global && !logical_nparens) ? 1 : 0;
3480 I32 *l2p = RXp_LOGICAL_TO_PARNO(prog);
3481 /* This is used to step through the physical parens associated
3482 with a given logical paren. */
3483 I32 *p2l_next = RXp_PARNO_TO_LOGICAL_NEXT(prog);
3485 rpp_extend(logical_nparens + logical_paren); /* devious code ... */
3486 EXTEND_MORTAL(logical_nparens + logical_paren); /* ... see above */
3488 /* Loop over the logical parens in the pattern. This may not
3489 correspond to the actual paren checked, as branch reset may
3490 mean that there is more than one paren "behind" the logical
3491 parens. Eg, in /(?|(a)|(b))/ there are two parens, but one
3493 for (logical_paren = !logical_paren;
3494 logical_paren <= logical_nparens;
3497 /* Now convert the logical_paren to the physical parens which
3498 are "behind" it. If branch reset was not used, then
3499 physical_paren and logical_paren are the same as each other
3500 and we will only perform one iteration of the loop. */
3501 I32 phys_paren = l2p ? l2p[logical_paren] : logical_paren;
3502 SSize_t offs_start, offs_end;
3503 /* We check the loop invariants below and break out of the loop
3504 explicitly if our checks fail, so we use while (1) here to
3505 avoid double testing a conditional. */
3507 /* Check end offset first, as the start might be >=0 even
3508 though the end is -1, so testing the end first helps
3509 us avoid the start check. Really we should be able to
3510 get away with ONLY testing the end, but testing both
3511 doesn't hurt much and preserves sanity. */
3512 if (((offs_end = RXp_OFFS_END(prog, phys_paren)) != -1) &&
3513 ((offs_start = RXp_OFFS_START(prog, phys_paren)) != -1))
3515 const SSize_t len = offs_end - offs_start;
3516 const char * const s = offs_start + truebase;
3517 if ( UNLIKELY( len < 0 || len > strend - s) ) {
3518 DIE(aTHX_ "panic: pp_match start/end pointers, paren=%" I32df ", "
3519 "start=%zd, end=%zd, s=%p, strend=%p, len=%zd",
3520 phys_paren, offs_start, offs_end, s, strend, len);
3522 rpp_push_1(newSVpvn_flags(s, len,
3528 } else if (!p2l_next || !(phys_paren = p2l_next[phys_paren])) {
3529 /* Either logical_paren and phys_paren are the same and
3530 we won't have a p2l_next, or they aren't the same (and
3531 we do have a p2l_next) but we have exhausted the list
3532 of physical parens associated with this logical paren.
3533 Either way we are done, and we can push undef and break
3535 rpp_push_1(sv_newmortal());
3541 curpos = (UV)RXp_OFFS_END(prog,0);
3542 had_zerolen = RXp_ZERO_LEN(prog);
3543 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
3546 LEAVE_SCOPE(oldsave);
3549 NOT_REACHED; /* NOTREACHED */
3552 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
3554 mg = mg_find_mglob(TARG);
3558 LEAVE_SCOPE(oldsave);
3559 if (gimme != G_LIST) {
3561 rpp_popfree_1(); /* free arg */
3562 rpp_push_1(&PL_sv_no);
3567 /* return when in list context (i.e. don't push YES/NO, but do return
3568 * a (possibly empty) list of matches */
3570 /* need to free the original argument and shift any results down
3572 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
3573 #ifdef PERL_RC_STACK
3574 SV *old_sv = PL_stack_sp[-nitems];
3577 Move(PL_stack_sp - nitems + 1,
3578 PL_stack_sp - nitems, nitems, SV*);
3580 #ifdef PERL_RC_STACK
3581 SvREFCNT_dec_NN(old_sv);
3590 Perl_do_readline(pTHX)
3592 dSP; dTARGETSTACKED;
3597 IO * const io = GvIO(PL_last_in_gv);
3598 const I32 type = PL_op->op_type;
3599 const U8 gimme = GIMME_V;
3602 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
3604 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
3605 if (gimme == G_SCALAR) {
3607 SvSetSV_nosteal(TARG, TOPs);
3617 if (IoFLAGS(io) & IOf_ARGV) {
3618 if (IoFLAGS(io) & IOf_START) {
3620 if (av_count(GvAVn(PL_last_in_gv)) == 0) {
3621 IoFLAGS(io) &= ~IOf_START;
3622 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
3623 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
3624 sv_setpvs(GvSVn(PL_last_in_gv), "-");
3625 SvSETMAGIC(GvSV(PL_last_in_gv));
3630 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3631 if (!fp) { /* Note: fp != IoIFP(io) */
3632 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
3635 else if (type == OP_GLOB)
3636 fp = Perl_start_glob(aTHX_ POPs, io);
3638 else if (type == OP_GLOB)
3640 else if (IoTYPE(io) == IoTYPE_WRONLY) {
3641 report_wrongway_fh(PL_last_in_gv, '>');
3645 if ((!io || !(IoFLAGS(io) & IOf_START))
3646 && ckWARN(WARN_CLOSED)
3649 report_evil_fh(PL_last_in_gv);
3651 if (gimme == G_SCALAR) {
3652 /* undef TARG, and push that undefined value */
3653 if (type != OP_RCATLINE) {
3661 if (gimme == G_SCALAR) {
3663 if (type == OP_RCATLINE && SvGMAGICAL(sv))
3666 if (type == OP_RCATLINE)
3667 SvPV_force_nomg_nolen(sv);
3671 else if (isGV_with_GP(sv)) {
3672 SvPV_force_nomg_nolen(sv);
3674 SvUPGRADE(sv, SVt_PV);
3675 tmplen = SvLEN(sv); /* remember if already alloced */
3676 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
3677 /* try short-buffering it. Please update t/op/readline.t
3678 * if you change the growth length.
3683 if (type == OP_RCATLINE && SvOK(sv)) {
3685 SvPV_force_nomg_nolen(sv);
3691 sv = sv_2mortal(newSV(80));
3695 /* This should not be marked tainted if the fp is marked clean */
3696 #define MAYBE_TAINT_LINE(io, sv) \
3697 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3702 /* delay EOF state for a snarfed empty file */
3703 #define SNARF_EOF(gimme,rs,io,sv) \
3704 (gimme != G_SCALAR || SvCUR(sv) \
3705 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
3709 if (!sv_gets(sv, fp, offset)
3711 || SNARF_EOF(gimme, PL_rs, io, sv)
3712 || PerlIO_error(fp)))
3714 if (IoFLAGS(io) & IOf_ARGV) {
3715 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3719 (void)do_close(PL_last_in_gv, FALSE);
3721 else if (type == OP_GLOB) {
3722 /* clear any errors here so we only fail on the pclose()
3723 failing, which should only happen on the child
3726 PerlIO_clearerr(fp);
3727 if (!do_close(PL_last_in_gv, FALSE)) {
3728 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3729 "glob failed (child exited with status %d%s)",
3730 (int)(STATUS_CURRENT >> 8),
3731 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
3734 if (gimme == G_SCALAR) {
3735 if (type != OP_RCATLINE) {
3736 SV_CHECK_THINKFIRST_COW_DROP(TARG);
3742 MAYBE_TAINT_LINE(io, sv);
3745 MAYBE_TAINT_LINE(io, sv);
3747 IoFLAGS(io) |= IOf_NOLINE;
3751 if (type == OP_GLOB) {
3755 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
3756 char * const tmps = SvEND(sv) - 1;
3757 if (*tmps == *SvPVX_const(PL_rs)) {
3759 SvCUR_set(sv, SvCUR(sv) - 1);
3762 for (t1 = SvPVX_const(sv); *t1; t1++)
3764 if (memCHRs("*%?", *t1))
3766 if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1))
3769 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
3770 (void)POPs; /* Unmatched wildcard? Chuck it... */
3773 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
3774 if (ckWARN(WARN_UTF8)) {
3775 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3776 const STRLEN len = SvCUR(sv) - offset;
3779 if (!is_utf8_string_loc(s, len, &f))
3780 /* Emulate :encoding(utf8) warning in the same case. */
3781 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3782 "utf8 \"\\x%02X\" does not map to Unicode",
3783 f < (U8*)SvEND(sv) ? *f : 0);
3786 if (gimme == G_LIST) {
3787 if (SvLEN(sv) - SvCUR(sv) > 20) {
3788 SvPV_shrink_to_cur(sv);
3790 sv = sv_2mortal(newSV(80));
3793 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
3794 /* try to reclaim a bit of scalar space (only on 1st alloc) */
3795 const STRLEN new_len
3796 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
3797 SvPV_renew(sv, new_len);
3807 SV * const keysv = PL_stack_sp[0];
3808 HV * const hv = MUTABLE_HV(PL_stack_sp[-1]);
3809 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3810 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3812 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3813 bool preeminent = TRUE;
3816 if (SvTYPE(hv) != SVt_PVHV) {
3817 retsv = &PL_sv_undef;
3825 /* Try to preserve the existence of a tied hash
3826 * element by using EXISTS and DELETE if possible.
3827 * Fall back to FETCH and STORE otherwise. */
3828 if (SvCANEXISTDELETE(hv))
3829 preeminent = hv_exists_ent(hv, keysv, 0);
3832 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3833 svp = he ? &HeVAL(he) : NULL;
3835 if (!svp || !*svp || *svp == &PL_sv_undef) {
3839 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3841 lv = newSV_type_mortal(SVt_PVLV);
3843 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
3844 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
3845 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3852 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
3853 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
3854 else if (preeminent)
3855 save_helem_flags(hv, keysv, svp,
3856 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3858 SAVEHDELETE(hv, keysv);
3860 else if (PL_op->op_private & OPpDEREF) {
3861 retsv = vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3865 sv = (svp && *svp ? *svp : &PL_sv_undef);
3866 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3867 * was to make C<local $tied{foo} = $tied{foo}> possible.
3868 * However, it seems no longer to be needed for that purpose, and
3869 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3870 * would loop endlessly since the pos magic is getting set on the
3871 * mortal copy and lost. However, the copy has the effect of
3872 * triggering the get magic, and losing it altogether made things like
3873 * c<$tied{foo};> in void context no longer do get magic, which some
3874 * code relied on. Also, delayed triggering of magic on @+ and friends
3875 * meant the original regex may be out of scope by now. So as a
3876 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3877 * being called too many times). */
3878 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
3883 rpp_replace_2_1(retsv);
3888 /* a stripped-down version of Perl_softref2xv() for use by
3889 * pp_multideref(), which doesn't use PL_op->op_flags */
3892 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3895 if (PL_op->op_private & HINT_STRICT_REFS) {
3897 Perl_die(aTHX_ PL_no_symref_sv, sv,
3898 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3900 Perl_die(aTHX_ PL_no_usym, what);
3903 Perl_die(aTHX_ PL_no_usym, what);
3904 return gv_fetchsv_nomg(sv, GV_ADD, type);
3908 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
3909 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
3911 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
3912 * Each of these either contains a set of actions, or an argument, such as
3913 * an IV to use as an array index, or a lexical var to retrieve.
3914 * Several actions are stored per UV; we keep shifting new actions off the
3915 * one UV, and only reload when it becomes zero.
3920 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3921 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3922 UV actions = items->uv;
3925 /* this tells find_uninit_var() where we're up to */
3926 PL_multideref_pc = items;
3927 bool replace = FALSE;
3930 /* there are three main classes of action; the first retrieves
3931 * the initial AV or HV from a variable or the stack; the second
3932 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3933 * the third an unrolled (/DREFHV, rv2hv, helem).
3935 switch (actions & MDEREF_ACTION_MASK) {
3938 actions = (++items)->uv;
3941 case MDEREF_AV_padav_aelem: /* $lex[...] */
3942 sv = PAD_SVl((++items)->pad_offset);
3945 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
3946 sv = UNOP_AUX_item_sv(++items);
3947 assert(isGV_with_GP(sv));
3948 sv = (SV*)GvAVn((GV*)sv);
3951 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
3955 goto do_AV_rv2av_aelem;
3958 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
3959 sv = UNOP_AUX_item_sv(++items);
3960 assert(isGV_with_GP(sv));
3961 sv = GvSVn((GV*)sv);
3962 goto do_AV_vivify_rv2av_aelem;
3964 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
3965 sv = PAD_SVl((++items)->pad_offset);
3968 do_AV_vivify_rv2av_aelem:
3969 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
3970 /* this is the OPpDEREF action normally found at the end of
3971 * ops like aelem, helem, rv2sv */
3972 sv = vivify_ref(sv, OPpDEREF_AV);
3976 /* this is basically a copy of pp_rv2av when it just has the
3979 if (LIKELY(SvROK(sv))) {
3980 if (UNLIKELY(SvAMAGIC(sv))) {
3981 sv = amagic_deref_call(sv, to_av_amg);
3984 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3985 DIE(aTHX_ "Not an ARRAY reference");
3987 else if (SvTYPE(sv) != SVt_PVAV) {
3988 if (!isGV_with_GP(sv))
3989 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3990 sv = MUTABLE_SV(GvAVn((GV*)sv));
3996 /* retrieve the key; this may be either a lexical or package
3997 * var (whose index/ptr is stored as an item) or a signed
3998 * integer constant stored as an item.
4001 IV elem = 0; /* to shut up stupid compiler warnings */
4004 assert(SvTYPE(sv) == SVt_PVAV);
4006 switch (actions & MDEREF_INDEX_MASK) {
4007 case MDEREF_INDEX_none:
4009 case MDEREF_INDEX_const:
4010 elem = (++items)->iv;
4012 case MDEREF_INDEX_padsv:
4013 elemsv = PAD_SVl((++items)->pad_offset);
4015 case MDEREF_INDEX_gvsv:
4016 elemsv = UNOP_AUX_item_sv(++items);
4017 assert(isGV_with_GP(elemsv));
4018 elemsv = GvSVn((GV*)elemsv);
4020 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
4021 && ckWARN(WARN_MISC)))
4022 Perl_warner(aTHX_ packWARN(WARN_MISC),
4023 "Use of reference \"%" SVf "\" as array index",
4025 /* the only time that S_find_uninit_var() needs this
4026 * is to determine which index value triggered the
4027 * undef warning. So just update it here. Note that
4028 * since we don't save and restore this var (e.g. for
4029 * tie or overload execution), its value will be
4030 * meaningless apart from just here */
4031 PL_multideref_pc = items;
4032 elem = SvIV(elemsv);
4037 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
4039 if (!(actions & MDEREF_FLAG_last)) {
4040 SV** svp = av_fetch((AV*)sv, elem, 1);
4041 if (!svp || ! (sv=*svp))
4042 DIE(aTHX_ PL_no_aelem, elem);
4046 if (PL_op->op_private &
4047 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
4049 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
4050 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
4053 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
4054 sv = av_delete((AV*)sv, elem, discard);
4062 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4063 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4064 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4065 bool preeminent = TRUE;
4066 AV *const av = (AV*)sv;
4069 if (UNLIKELY(localizing)) {
4073 /* Try to preserve the existence of a tied array
4074 * element by using EXISTS and DELETE if possible.
4075 * Fall back to FETCH and STORE otherwise. */
4076 if (SvCANEXISTDELETE(av))
4077 preeminent = av_exists(av, elem);
4080 svp = av_fetch(av, elem, lval && !defer);
4083 if (!svp || !(sv = *svp)) {
4086 DIE(aTHX_ PL_no_aelem, elem);
4087 len = av_top_index(av);
4088 /* Resolve a negative index that falls within
4089 * the array. Leave it negative it if falls
4090 * outside the array. */
4091 if (elem < 0 && len + elem >= 0)
4093 if (elem >= 0 && elem <= len)
4094 /* Falls within the array. */
4095 sv = av_nonelem(av,elem);
4097 /* Falls outside the array. If it is neg-
4098 ative, magic_setdefelem will use the
4099 index for error reporting. */
4100 sv = sv_2mortal(newSVavdefelem(av,elem,1));
4103 if (UNLIKELY(localizing)) {
4105 save_aelem(av, elem, svp);
4106 sv = *svp; /* may have changed */
4109 SAVEADELETE(av, elem);
4114 sv = (svp ? *svp : &PL_sv_undef);
4115 /* see note in pp_helem() */
4116 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
4125 rpp_replace_1_1(sv);
4135 case MDEREF_HV_padhv_helem: /* $lex{...} */
4136 sv = PAD_SVl((++items)->pad_offset);
4139 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
4140 sv = UNOP_AUX_item_sv(++items);
4141 assert(isGV_with_GP(sv));
4142 sv = (SV*)GvHVn((GV*)sv);
4145 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
4149 goto do_HV_rv2hv_helem;
4152 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
4153 sv = UNOP_AUX_item_sv(++items);
4154 assert(isGV_with_GP(sv));
4155 sv = GvSVn((GV*)sv);
4156 goto do_HV_vivify_rv2hv_helem;
4158 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
4159 sv = PAD_SVl((++items)->pad_offset);
4162 do_HV_vivify_rv2hv_helem:
4163 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
4164 /* this is the OPpDEREF action normally found at the end of
4165 * ops like aelem, helem, rv2sv */
4166 sv = vivify_ref(sv, OPpDEREF_HV);
4170 /* this is basically a copy of pp_rv2hv when it just has the
4171 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
4174 if (LIKELY(SvROK(sv))) {
4175 if (UNLIKELY(SvAMAGIC(sv))) {
4176 sv = amagic_deref_call(sv, to_hv_amg);
4179 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
4180 DIE(aTHX_ "Not a HASH reference");
4182 else if (SvTYPE(sv) != SVt_PVHV) {
4183 if (!isGV_with_GP(sv))
4184 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
4185 sv = MUTABLE_SV(GvHVn((GV*)sv));
4191 /* retrieve the key; this may be either a lexical / package
4192 * var or a string constant, whose index/ptr is stored as an
4195 SV *keysv = NULL; /* to shut up stupid compiler warnings */
4197 assert(SvTYPE(sv) == SVt_PVHV);
4199 switch (actions & MDEREF_INDEX_MASK) {
4200 case MDEREF_INDEX_none:
4203 case MDEREF_INDEX_const:
4204 keysv = UNOP_AUX_item_sv(++items);
4207 case MDEREF_INDEX_padsv:
4208 keysv = PAD_SVl((++items)->pad_offset);
4211 case MDEREF_INDEX_gvsv:
4212 keysv = UNOP_AUX_item_sv(++items);
4213 keysv = GvSVn((GV*)keysv);
4217 /* see comment above about setting this var */
4218 PL_multideref_pc = items;
4221 /* ensure that candidate CONSTs have been HEKified */
4222 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
4223 || SvTYPE(keysv) >= SVt_PVMG
4226 || SvIsCOW_shared_hash(keysv));
4228 /* this is basically a copy of pp_helem with OPpDEREF skipped */
4230 if (!(actions & MDEREF_FLAG_last)) {
4231 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
4232 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
4233 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4237 if (PL_op->op_private &
4238 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
4240 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
4241 sv = hv_exists_ent((HV*)sv, keysv, 0)
4242 ? &PL_sv_yes : &PL_sv_no;
4245 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
4246 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
4254 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4255 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4256 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4257 bool preeminent = TRUE;
4259 HV * const hv = (HV*)sv;
4262 if (UNLIKELY(localizing)) {
4266 /* Try to preserve the existence of a tied hash
4267 * element by using EXISTS and DELETE if possible.
4268 * Fall back to FETCH and STORE otherwise. */
4269 if (SvCANEXISTDELETE(hv))
4270 preeminent = hv_exists_ent(hv, keysv, 0);
4273 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
4274 svp = he ? &HeVAL(he) : NULL;
4278 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
4282 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4283 lv = newSV_type_mortal(SVt_PVLV);
4285 sv_magic(lv, key2 = newSVsv(keysv),
4286 PERL_MAGIC_defelem, NULL, 0);
4287 /* sv_magic() increments refcount */
4288 SvREFCNT_dec_NN(key2);
4289 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
4295 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
4296 save_gp(MUTABLE_GV(sv),
4297 !(PL_op->op_flags & OPf_SPECIAL));
4298 else if (preeminent) {
4299 save_helem_flags(hv, keysv, svp,
4300 (PL_op->op_flags & OPf_SPECIAL)
4301 ? 0 : SAVEf_SETMAGIC);
4302 sv = *svp; /* may have changed */
4305 SAVEHDELETE(hv, keysv);
4310 sv = (svp && *svp ? *svp : &PL_sv_undef);
4311 /* see note in pp_helem() */
4312 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
4321 actions >>= MDEREF_SHIFT;
4329 PERL_CONTEXT *cx = CX_CUR();
4330 SV **itersvp = CxITERVAR(cx);
4331 const U8 type = CxTYPE(cx);
4333 /* Classic "for" syntax iterates one-at-a-time.
4334 Many-at-a-time for loops are only for lexicals declared as part of the
4335 for loop, and rely on all the lexicals being in adjacent pad slots.
4337 Curiously, even if the iterator variable is a lexical, the pad offset is
4338 stored in the targ slot of the ENTERITER op, meaning that targ of this OP
4339 has always been zero. Hence we can use this op's targ to hold "how many"
4340 for many-at-a-time. We actually store C<how_many - 1>, so that for the
4341 case of one-at-a-time we have zero (as before), as this makes all the
4342 logic of the for loop below much simpler, with all the other
4343 one-at-a-time cases just falling out of this "naturally". */
4344 PADOFFSET how_many = PL_op->op_targ;
4349 for (; i <= how_many; ++i ) {
4358 case CXt_LOOP_LAZYSV: /* string increment */
4360 SV* cur = cx->blk_loop.state_u.lazysv.cur;
4361 SV *end = cx->blk_loop.state_u.lazysv.end;
4362 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
4363 It has SvPVX of "" and SvCUR of 0, which is what we want. */
4365 const char *max = SvPV_const(end, maxlen);
4366 bool pad_it = FALSE;
4367 if (DO_UTF8(end) && IN_UNI_8_BIT)
4368 maxlen = sv_len_utf8_nomg(end);
4369 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen)) {
4373 /* We are looping n-at-a-time and the range isn't a multiple
4374 of n, so we fill the rest of the lexicals with undef.
4375 This only happens on the last iteration of the loop, and
4376 we will have already set up the "terminate next time"
4377 condition earlier in this for loop for this call of the
4378 ITER op when we set up the lexical corresponding to the
4379 last value in the range. Hence we don't goto retno (yet),
4380 and just below we don't repeat the setup for "terminate
4386 /* NB: on the first iteration, oldsv will have a ref count of at
4387 * least 2 (one extra from blk_loop.itersave), so the GV or pad
4388 * slot will get localised; on subsequent iterations the RC==1
4389 * optimisation may kick in and the SV will be reused. */
4390 if (UNLIKELY(pad_it)) {
4391 *itersvp = &PL_sv_undef;
4392 SvREFCNT_dec(oldsv);
4394 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
4395 /* safe to reuse old SV */
4396 sv_setsv(oldsv, cur);
4399 /* we need a fresh SV every time so that loop body sees a
4400 * completely new SV for closures/references to work as
4402 *itersvp = newSVsv(cur);
4403 SvREFCNT_dec(oldsv);
4406 if (UNLIKELY(pad_it)) {
4407 /* We're "beyond the end" of the iterator here, filling the
4408 extra lexicals with undef, so we mustn't do anything
4409 (further) to the iterator itself at this point.
4410 (Observe how the other two blocks modify the iterator's
4413 else if (strEQ(SvPVX_const(cur), max))
4414 sv_setiv(cur, 0); /* terminate next time */
4420 case CXt_LOOP_LAZYIV: /* integer increment */
4422 IV cur = cx->blk_loop.state_u.lazyiv.cur;
4423 bool pad_it = FALSE;
4424 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) {
4432 /* see NB comment above */
4433 if (UNLIKELY(pad_it)) {
4434 *itersvp = &PL_sv_undef;
4435 SvREFCNT_dec(oldsv);
4437 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
4438 /* safe to reuse old SV */
4440 if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
4442 /* Cheap SvIOK_only().
4443 * Assert that flags which SvIOK_only() would test or
4444 * clear can't be set, because we're SVt_IV */
4445 assert(!(SvFLAGS(oldsv) &
4446 (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
4447 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
4448 /* SvIV_set() where sv_any points to head */
4449 oldsv->sv_u.svu_iv = cur;
4453 sv_setiv(oldsv, cur);
4456 /* we need a fresh SV every time so that loop body sees a
4457 * completely new SV for closures/references to work as they
4459 *itersvp = newSViv(cur);
4460 SvREFCNT_dec(oldsv);
4463 if (UNLIKELY(pad_it)) {
4464 /* We're good (see "We are looping n-at-a-time" comment
4467 else if (UNLIKELY(cur == IV_MAX)) {
4468 /* Handle end of range at IV_MAX */
4469 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
4471 ++cx->blk_loop.state_u.lazyiv.cur;
4475 case CXt_LOOP_LIST: /* for (1,2,3) */
4477 assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
4478 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
4479 ix = (cx->blk_loop.state_u.stack.ix += inc);
4480 if (UNLIKELY(inc > 0
4481 ? ix > cx->blk_oldsp
4482 : ix <= cx->blk_loop.state_u.stack.basesp)
4491 sv = PL_stack_base[ix];
4495 goto loop_ary_common;
4497 case CXt_LOOP_ARY: /* for (@ary) */
4499 av = cx->blk_loop.state_u.ary.ary;
4500 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
4501 ix = (cx->blk_loop.state_u.ary.ix += inc);
4502 if (UNLIKELY(inc > 0
4511 } else if (UNLIKELY(SvRMAGICAL(av))) {
4512 SV * const * const svp = av_fetch(av, ix, FALSE);
4513 sv = svp ? *svp : NULL;
4516 sv = AvARRAY(av)[ix];
4521 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
4522 SvSetMagicSV(*itersvp, sv);
4527 if (UNLIKELY(SvIS_FREED(sv))) {
4529 Perl_croak(aTHX_ "Use of freed value in iteration");
4536 SvREFCNT_inc_simple_void_NN(sv);
4540 sv = newSVavdefelem(av, ix, 0);
4547 SvREFCNT_dec(oldsv);
4551 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
4554 /* Only relevant for a many-at-a-time loop: */
4558 /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead
4559 * jump straight to the AND op's op_other */
4560 assert(PL_op->op_next->op_type == OP_AND);
4561 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4562 return cLOGOPx(PL_op->op_next)->op_other;
4565 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4567 /* pp_enteriter should have pre-extended the stack */
4568 EXTEND_SKIP(PL_stack_sp, 1);
4569 *++PL_stack_sp = &PL_sv_yes;
4570 return PL_op->op_next;
4574 /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead
4575 * jump straight to the AND op's op_next */
4576 assert(PL_op->op_next->op_type == OP_AND);
4577 /* pp_enteriter should have pre-extended the stack */
4578 EXTEND_SKIP(PL_stack_sp, 1);
4579 /* we only need this for the rare case where the OP_AND isn't
4580 * in void context, e.g. $x = do { for (..) {...} };
4581 * (or for when an XS module has replaced the op_ppaddr)
4582 * but it's cheaper to just push it rather than testing first
4584 *++PL_stack_sp = &PL_sv_no;
4585 if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
4586 return PL_op->op_next->op_next;
4589 /* An XS module has replaced the op_ppaddr, so fall back to the slow,
4591 return PL_op->op_next;
4597 A description of how taint works in pattern matching and substitution.
4599 This is all conditional on NO_TAINT_SUPPORT remaining undefined (the default).
4600 Under NO_TAINT_SUPPORT, taint-related operations should become no-ops.
4602 While the pattern is being assembled/concatenated and then compiled,
4603 PL_tainted will get set (via TAINT_set) if any component of the pattern
4604 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
4605 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
4606 TAINT_get). It will also be set if any component of the pattern matches
4607 based on locale-dependent behavior.
4609 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
4610 the pattern is marked as tainted. This means that subsequent usage, such
4611 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
4612 on the new pattern too.
4614 RXf_TAINTED_SEEN is used post-execution by the get magic code
4615 of $1 et al to indicate whether the returned value should be tainted.
4616 It is the responsibility of the caller of the pattern (i.e. pp_match,
4617 pp_subst etc) to set this flag for any other circumstances where $1 needs
4620 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
4622 There are three possible sources of taint
4624 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
4625 * the replacement string (or expression under /e)
4627 There are four destinations of taint and they are affected by the sources
4628 according to the rules below:
4630 * the return value (not including /r):
4631 tainted by the source string and pattern, but only for the
4632 number-of-iterations case; boolean returns aren't tainted;
4633 * the modified string (or modified copy under /r):
4634 tainted by the source string, pattern, and replacement strings;
4636 tainted by the pattern, and under 'use re "taint"', by the source
4638 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
4639 should always be unset before executing subsequent code.
4641 The overall action of pp_subst is:
4643 * at the start, set bits in rxtainted indicating the taint status of
4644 the various sources.
4646 * After each pattern execution, update the SUBST_TAINT_PAT bit in
4647 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
4648 pattern has subsequently become tainted via locale ops.
4650 * If control is being passed to pp_substcont to execute a /e block,
4651 save rxtainted in the CXt_SUBST block, for future use by
4654 * Whenever control is being returned to perl code (either by falling
4655 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
4656 use the flag bits in rxtainted to make all the appropriate types of
4657 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
4658 et al will appear tainted.
4660 pp_match is just a simpler version of the above.
4664 PP_wrapped(pp_subst, ((PL_op->op_flags & OPf_STACKED) ? 2 : 1), 0)
4676 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
4677 See "how taint works" above */
4680 REGEXP *rx = PM_GETRE(pm);
4681 regexp *prog = ReANY(rx);
4683 int force_on_match = 0;
4684 const I32 oldsave = PL_savestack_ix;
4685 bool doutf8 = FALSE; /* whether replacement is in utf8 */
4690 /* known replacement string? */
4691 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
4695 if (PL_op->op_flags & OPf_STACKED)
4706 SvGETMAGIC(TARG); /* must come before cow check */
4708 /* note that a string might get converted to COW during matching */
4709 was_cow = cBOOL(SvIsCOW(TARG));
4711 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4712 #ifndef PERL_ANY_COW
4714 sv_force_normal_flags(TARG,0);
4716 if ((SvREADONLY(TARG)
4717 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
4718 || SvTYPE(TARG) > SVt_PVLV)
4719 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
4720 Perl_croak_no_modify();
4724 orig = SvPV_nomg(TARG, len);
4725 /* note we don't (yet) force the var into being a string; if we fail
4726 * to match, we leave as-is; on successful match however, we *will*
4727 * coerce into a string, then repeat the match */
4728 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
4731 /* only replace once? */
4732 once = !(rpm->op_pmflags & PMf_GLOBAL);
4734 /* See "how taint works" above */
4737 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
4738 | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
4739 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
4740 | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4741 || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0));
4747 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
4749 strend = orig + len;
4750 /* We can match twice at each position, once with zero-length,
4751 * second time with non-zero.
4752 * Don't handle utf8 specially; we can use length-in-bytes as an
4753 * upper bound on length-in-characters, and avoid the cpu-cost of
4754 * computing a tighter bound. */
4755 maxiters = 2 * len + 10;
4757 /* handle the empty pattern */
4758 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
4759 if (PL_curpm == PL_reg_curpm) {
4760 if (PL_curpm_under) {
4761 if (PL_curpm_under == PL_reg_curpm) {
4762 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
4764 pm = PL_curpm_under;
4774 #ifdef PERL_SAWAMPERSAND
4775 r_flags = ( RXp_NPARENS(prog)
4777 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
4778 || (rpm->op_pmflags & PMf_KEEPCOPY)
4783 r_flags = REXEC_COPY_STR;
4786 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
4789 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
4790 LEAVE_SCOPE(oldsave);
4795 /* known replacement string? */
4797 /* replacement needing upgrading? */
4798 if (DO_UTF8(TARG) && !doutf8) {
4799 nsv = sv_newmortal();
4801 sv_utf8_upgrade(nsv);
4802 c = SvPV_const(nsv, clen);
4806 c = SvPV_const(dstr, clen);
4807 doutf8 = DO_UTF8(dstr);
4810 if (UNLIKELY(TAINT_get))
4811 rxtainted |= SUBST_TAINT_REPL;
4818 /* can do inplace substitution? */
4823 && (SSize_t)clen <= RXp_MINLENRET(prog)
4825 || !(r_flags & REXEC_COPY_STR)
4826 || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
4828 && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
4829 && (!doutf8 || SvUTF8(TARG))
4830 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4834 /* string might have got converted to COW since we set was_cow */
4835 if (SvIsCOW(TARG)) {
4836 if (!force_on_match)
4838 assert(SvVOK(TARG));
4841 if (force_on_match) {
4842 /* redo the first match, this time with the orig var
4843 * forced into being a string */
4845 orig = SvPV_force_nomg(TARG, len);
4851 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4852 rxtainted |= SUBST_TAINT_PAT;
4853 m = orig + RXp_OFFS_START(prog,0);
4854 d = orig + RXp_OFFS_END(prog,0);
4856 if (m - s > strend - d) { /* faster to shorten from end */
4859 Copy(c, m, clen, char);
4864 Move(d, m, i, char);
4868 SvCUR_set(TARG, m - s);
4870 else { /* faster from front */
4874 Move(s, d - i, i, char);
4877 Copy(c, d, clen, char);
4884 d = s = RXp_OFFS_START(prog,0) + orig;
4887 if (UNLIKELY(iters++ > maxiters))
4888 DIE(aTHX_ "Substitution loop");
4889 /* run time pattern taint, eg locale */
4890 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4891 rxtainted |= SUBST_TAINT_PAT;
4892 m = RXp_OFFS_START(prog,0) + orig;
4895 Move(s, d, i, char);
4899 Copy(c, d, clen, char);
4902 s = RXp_OFFS_END(prog,0) + orig;
4903 } while (CALLREGEXEC(rx, s, strend, orig,
4904 s == m, /* don't match same null twice */
4906 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4908 SSize_t i = strend - s;
4909 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
4910 Move(s, d, i+1, char); /* include the NUL */
4914 if (PL_op->op_private & OPpTRUEBOOL)
4924 if (force_on_match) {
4925 /* redo the first match, this time with the orig var
4926 * forced into being a string */
4928 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4929 /* I feel that it should be possible to avoid this mortal copy
4930 given that the code below copies into a new destination.
4931 However, I suspect it isn't worth the complexity of
4932 unravelling the C<goto force_it> for the small number of
4933 cases where it would be viable to drop into the copy code. */
4934 TARG = sv_2mortal(newSVsv(TARG));
4936 orig = SvPV_force_nomg(TARG, len);
4942 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4943 rxtainted |= SUBST_TAINT_PAT;
4945 s = RXp_OFFS_START(prog,0) + orig;
4946 dstr = newSVpvn_flags(orig, s-orig,
4947 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
4952 /* note that a whole bunch of local vars are saved here for
4953 * use by pp_substcont: here's a list of them in case you're
4954 * searching for places in this sub that uses a particular var:
4955 * iters maxiters r_flags oldsave rxtainted orig dstr targ
4956 * s m strend rx once */
4958 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
4962 if (UNLIKELY(iters++ > maxiters))
4963 DIE(aTHX_ "Substitution loop");
4964 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4965 rxtainted |= SUBST_TAINT_PAT;
4966 if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
4968 char *old_orig = orig;
4969 assert(RXp_SUBOFFSET(prog) == 0);
4971 orig = RXp_SUBBEG(prog);
4972 s = orig + (old_s - old_orig);
4973 strend = s + (strend - old_s);
4975 m = RXp_OFFS_START(prog,0) + orig;
4976 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
4977 s = RXp_OFFS_END(prog,0) + orig;
4979 /* replacement already stringified */
4981 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
4985 sv_catsv(dstr, repl);
4989 } while (CALLREGEXEC(rx, s, strend, orig,
4990 s == m, /* Yields minend of 0 or 1 */
4992 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4993 assert(strend >= s);
4994 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
4996 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4997 /* From here on down we're using the copy, and leaving the original
5004 /* The match may make the string COW. If so, brilliant, because
5005 that's just saved us one malloc, copy and free - the regexp has
5006 donated the old buffer, and we malloc an entirely new one, rather
5007 than the regexp malloc()ing a buffer and copying our original,
5008 only for us to throw it away here during the substitution. */
5009 if (SvIsCOW(TARG)) {
5010 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
5016 SvPV_set(TARG, SvPVX(dstr));
5017 SvCUR_set(TARG, SvCUR(dstr));
5018 SvLEN_set(TARG, SvLEN(dstr));
5019 SvFLAGS(TARG) |= SvUTF8(dstr);
5020 SvPV_set(dstr, NULL);
5023 if (PL_op->op_private & OPpTRUEBOOL)
5030 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
5031 (void)SvPOK_only_UTF8(TARG);
5034 /* See "how taint works" above */
5036 if ((rxtainted & SUBST_TAINT_PAT) ||
5037 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
5038 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
5040 (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
5042 if (!(rxtainted & SUBST_TAINT_BOOLRET)
5043 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
5045 SvTAINTED_on(TOPs); /* taint return value */
5047 SvTAINTED_off(TOPs); /* may have got tainted earlier */
5049 /* needed for mg_set below */
5051 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
5055 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
5057 LEAVE_SCOPE(oldsave);
5064 /* Understanding the stack during a grep.
5066 * 'grep expr, args' is implemented in the form of
5073 * The stack examples below are in the form of 'perl -Ds' output,
5074 * where any stack element indexed by PL_markstack_ptr[i] has a star
5075 * just to the right of it. In addition, the corresponding i value
5076 * is displayed under the indexed stack element.
5078 * On entry to grepwhile, the stack looks like this:
5080 * => * M1..Mn X1 * X2..Xn C * R1..Rn BOOL
5084 * M1..Mn Accumulated args which have been matched so far.
5085 * X1..Xn Random discardable elements from previous iterations.
5086 * C The current (just processed) arg, still aliased to $_.
5087 * R1..Rn The args remaining to be processed.
5088 * BOOL the result of the just-executed grep expression.
5090 * Note that it is easiest to think of the top two stack marks as both
5091 * being one too high, and so it would make more sense to have had the
5094 * => * M1..Mn * X1..Xn * C R1..Rn BOOL
5097 * where the stack is divided neatly into 3 groups:
5100 * - being, or yet to be, processed.
5101 * But off-by-one is the way it is currently, and it works as long as
5102 * we keep it consistent and bear it in mind.
5104 * pp_grepwhile() does the following:
5106 * - for a match, replace the X1 pointer with a pointer to C and bump
5107 * PL_markstack_ptr[-1]
5108 * - if more args to process, bump PL_markstack_ptr[0] and update the
5110 * - remove top 3 MARKs and return M1..Mn, or a scalar,
5111 * or void as appropriate.
5115 bool match = SvTRUE_NN(*PL_stack_sp);
5119 SV **from_p = PL_stack_base + PL_markstack_ptr[0];
5120 SV **to_p = PL_stack_base + PL_markstack_ptr[-1]++;
5126 #ifdef PERL_RC_STACK
5127 SvREFCNT_inc_simple_void_NN(from);
5133 ++*PL_markstack_ptr;
5135 LEAVE_with_name("grep_item"); /* exit inner scope */
5138 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > PL_stack_sp)) {
5140 const U8 gimme = GIMME_V;
5142 LEAVE_with_name("grep"); /* exit outer scope */
5143 (void)POPMARK; /* pop src */
5144 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
5145 (void)POPMARK; /* pop dst */
5146 SV **base = PL_stack_base + POPMARK; /* pop original mark */
5148 if (gimme == G_LIST)
5149 rpp_popfree_to(base + items);
5151 rpp_popfree_to(base);
5152 if (gimme == G_SCALAR) {
5153 if (PL_op->op_private & OPpTRUEBOOL)
5154 rpp_push_1(items ? &PL_sv_yes : &PL_sv_zero);
5168 ENTER_with_name("grep_item"); /* enter inner scope */
5171 src = PL_stack_base[TOPMARK];
5172 if (SvPADTMP(src)) {
5173 SV *newsrc = sv_mortalcopy(src);
5174 PL_stack_base[TOPMARK] = newsrc;
5175 #ifdef PERL_RC_STACK
5176 SvREFCNT_inc_simple_void_NN(newsrc);
5185 return cLOGOP->op_other;
5190 /* leave_adjust_stacks():
5192 * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
5193 * positioning them at to_sp+1 onwards, and do the equivalent of a
5194 * FREEMPS and TAINT_NOT.
5196 * Not intended to be called in void context.
5198 * When leaving a sub, eval, do{} or other scope, the things that need
5199 * doing to process the return args are:
5200 * * in scalar context, only return the last arg (or PL_sv_undef if none);
5201 * * for the types of return that return copies of their args (such
5202 * as rvalue sub return), make a mortal copy of every return arg,
5203 * except where we can optimise the copy away without it being
5204 * semantically visible;
5205 * * make sure that the arg isn't prematurely freed; in the case of an
5206 * arg not copied, this may involve mortalising it. For example, in
5207 * C<sub f { my $x = ...; $x }>, $x would be freed when we do
5208 * CX_LEAVE_SCOPE(cx) unless it's protected or copied.
5210 * What condition to use when deciding whether to pass the arg through
5211 * or make a copy, is determined by the 'pass' arg; its valid values are:
5212 * 0: rvalue sub/eval exit
5213 * 1: other rvalue scope exit
5214 * 2: :lvalue sub exit in rvalue context
5215 * 3: :lvalue sub exit in lvalue context and other lvalue scope exits
5217 * There is a big issue with doing a FREETMPS. We would like to free any
5218 * temps created by the last statement which the sub executed, rather than
5219 * leaving them for the caller. In a situation where a sub call isn't
5220 * soon followed by a nextstate (e.g. nested recursive calls, a la
5221 * fibonacci()), temps can accumulate, causing memory and performance
5224 * On the other hand, we don't want to free any TEMPs which are keeping
5225 * alive any return args that we skipped copying; nor do we wish to undo
5226 * any mortalising done here.
5228 * The solution is to split the temps stack frame into two, with a cut
5229 * point delineating the two halves. We arrange that by the end of this
5230 * function, all the temps stack frame entries we wish to keep are in the
5231 * range PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
5232 * the range tmps_base .. PL_tmps_ix. During the course of this
5233 * function, tmps_base starts off as PL_tmps_floor+1, then increases
5234 * whenever we find or create a temp that we know should be kept. In
5235 * general the stuff above tmps_base is undecided until we reach the end,
5236 * and we may need a sort stage for that.
5238 * To determine whether a TEMP is keeping a return arg alive, every
5239 * arg that is kept rather than copied and which has the SvTEMP flag
5240 * set, has the flag temporarily unset, to mark it. At the end we scan
5241 * the temps stack frame above the cut for entries without SvTEMP and
5242 * keep them, while turning SvTEMP on again. Note that if we die before
5243 * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
5244 * those SVs may be slightly less efficient.
5246 * In practice various optimisations for some common cases mean we can
5247 * avoid most of the scanning and swapping about with the temps stack.
5251 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
5253 SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
5256 PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
5260 if (gimme == G_LIST) {
5261 nargs = PL_stack_sp - from_sp;
5265 assert(gimme == G_SCALAR);
5266 if (UNLIKELY(from_sp >= PL_stack_sp)) {
5267 /* no return args */
5268 assert(from_sp == PL_stack_sp);
5270 *++PL_stack_sp = &PL_sv_undef;
5272 from_sp = PL_stack_sp;
5276 /* common code for G_SCALAR and G_LIST */
5278 #ifdef PERL_RC_STACK
5280 /* free any items from the stack which are about to get
5282 SV **p = from_sp - 1;
5293 tmps_base = PL_tmps_floor + 1;
5297 /* pointer version of tmps_base. Not safe across temp stack
5301 EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
5302 tmps_basep = PL_tmps_stack + tmps_base;
5304 /* process each return arg */
5307 SV *sv = *from_sp++;
5309 assert(PL_tmps_ix + nargs < PL_tmps_max);
5311 /* PADTMPs with container set magic shouldn't appear in the
5312 * wild. This assert is more important for pp_leavesublv(),
5313 * but by testing for it here, we're more likely to catch
5314 * bad cases (what with :lvalue subs not being widely
5315 * deployed). The two issues are that for something like
5316 * sub :lvalue { $tied{foo} }
5318 * sub :lvalue { substr($foo,1,2) }
5319 * pp_leavesublv() will croak if the sub returns a PADTMP,
5320 * and currently functions like pp_substr() return a mortal
5321 * rather than using their PADTMP when returning a PVLV.
5322 * This is because the PVLV will hold a ref to $foo,
5323 * so $foo would get delayed in being freed while
5324 * the PADTMP SV remained in the PAD.
5325 * So if this assert fails it means either:
5326 * 1) there is pp code similar to pp_substr that is
5327 * returning a PADTMP instead of a mortal, and probably
5329 * 2) pp_leavesublv is making unwarranted assumptions
5330 * about always croaking on a PADTMP
5332 if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
5334 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
5335 assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
5341 pass == 0 ? (rpp_is_lone(sv) && !SvMAGICAL(sv))
5342 : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
5343 : pass == 2 ? (!SvPADTMP(sv))
5346 /* pass through: skip copy for logic or optimisation
5347 * reasons; instead mortalise it, except that ... */
5349 #ifdef PERL_RC_STACK
5355 /* ... since this SV is an SvTEMP , we don't need to
5356 * re-mortalise it; instead we just need to ensure
5357 * that its existing entry in the temps stack frame
5358 * ends up below the cut and so avoids being freed
5359 * this time round. We mark it as needing to be kept
5360 * by temporarily unsetting SvTEMP; then at the end,
5361 * we shuffle any !SvTEMP entries on the tmps stack
5362 * back below the cut.
5363 * However, there's a significant chance that there's
5364 * a 1:1 correspondence between the first few (or all)
5365 * elements in the return args stack frame and those
5366 * in the temps stack frame; e,g.:
5367 * sub f { ....; map {...} .... },
5368 * or if we're exiting multiple scopes and one of the
5369 * inner scopes has already made mortal copies of each
5372 * If so, this arg sv will correspond to the next item
5373 * on the tmps stack above the cut, and so can be kept
5374 * merely by moving the cut boundary up one, rather
5375 * than messing with SvTEMP. If all args are 1:1 then
5376 * we can avoid the sorting stage below completely.
5378 * If there are no items above the cut on the tmps
5379 * stack, then the SvTEMP must comne from an item
5380 * below the cut, so there's nothing to do.
5382 if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
5383 if (sv == *tmps_basep)
5389 else if (!SvPADTMP(sv)) {
5390 /* mortalise arg to avoid it being freed during save
5391 * stack unwinding. Pad tmps don't need mortalising as
5392 * they're never freed. This is the equivalent of
5393 * sv_2mortal(SvREFCNT_inc(sv)), except that:
5394 * * it assumes that the temps stack has already been
5396 * * it puts the new item at the cut rather than at
5397 * ++PL_tmps_ix, moving the previous occupant there
5400 if (!SvIMMORTAL(sv)) {
5401 SvREFCNT_inc_simple_void_NN(sv);
5403 /* Note that if there's nothing above the cut,
5404 * this copies the garbage one slot above
5405 * PL_tmps_ix onto itself. This is harmless (the
5406 * stack's already been extended), but might in
5407 * theory trigger warnings from tools like ASan
5409 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
5415 /* Make a mortal copy of the SV.
5416 * The following code is the equivalent of sv_mortalcopy()
5418 * * it assumes the temps stack has already been extended;
5419 * * it optimises the copying for some simple SV types;
5420 * * it puts the new item at the cut rather than at
5421 * ++PL_tmps_ix, moving the previous occupant there
5424 SV *newsv = newSV_type(SVt_NULL);
5426 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
5427 /* put it on the tmps stack early so it gets freed if we die */
5428 *tmps_basep++ = newsv;
5430 if (SvTYPE(sv) <= SVt_IV) {
5431 /* arg must be one of undef, IV/UV, or RV: skip
5432 * sv_setsv_flags() and do the copy directly */
5434 U32 srcflags = SvFLAGS(sv);
5436 assert(!SvGMAGICAL(sv));
5437 if (srcflags & (SVf_IOK|SVf_ROK)) {
5438 SET_SVANY_FOR_BODYLESS_IV(newsv);
5440 if (srcflags & SVf_ROK) {
5441 newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
5442 /* SV type plus flags */
5443 dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
5446 /* both src and dst are <= SVt_IV, so sv_any
5447 * points to the head; so access the heads
5448 * directly rather than going via sv_any.
5450 assert( &(sv->sv_u.svu_iv)
5451 == &(((XPVIV*) SvANY(sv))->xiv_iv));
5452 assert( &(newsv->sv_u.svu_iv)
5453 == &(((XPVIV*) SvANY(newsv))->xiv_iv));
5454 newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
5455 /* SV type plus flags */
5456 dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
5457 |(srcflags & SVf_IVisUV));
5461 assert(!(srcflags & SVf_OK));
5462 dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
5464 SvFLAGS(newsv) = dstflags;
5468 /* do the full sv_setsv() */
5472 old_base = tmps_basep - PL_tmps_stack;
5474 sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
5475 /* the mg_get or sv_setsv might have created new temps
5476 * or realloced the tmps stack; regrow and reload */
5477 EXTEND_MORTAL(nargs);
5478 tmps_basep = PL_tmps_stack + old_base;
5479 TAINT_NOT; /* Each item is independent */
5483 #ifdef PERL_RC_STACK
5485 SvREFCNT_dec_NN(sv);
5488 SvREFCNT_inc_simple_void_NN(newsv);
5496 /* If there are any temps left above the cut, we need to sort
5497 * them into those to keep and those to free. The only ones to
5498 * keep are those for which we've temporarily unset SvTEMP.
5499 * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
5500 * swapping pairs as necessary. Stop when we meet in the middle.
5503 SV **top = PL_tmps_stack + PL_tmps_ix;
5504 while (tmps_basep <= top) {
5517 tmps_base = tmps_basep - PL_tmps_stack;
5520 PL_stack_sp = to_sp;
5522 /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
5523 while (PL_tmps_ix >= tmps_base) {
5524 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
5526 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
5530 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
5536 /* also tail-called by pp_return */
5546 assert(CxTYPE(cx) == CXt_SUB);
5548 if (CxMULTICALL(cx)) {
5549 /* entry zero of a stack is always PL_sv_undef, which
5550 * simplifies converting a '()' return into undef in scalar context */
5551 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
5555 gimme = cx->blk_gimme;
5556 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
5558 if (gimme == G_VOID)
5559 rpp_popfree_to(oldsp);
5561 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
5564 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
5566 retop = cx->blk_sub.retop;
5573 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
5574 * forces an abandon */
5577 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
5579 PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
5581 if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))
5582 #ifndef PERL_RC_STACK
5586 clear_defarray_simple(av);
5587 #ifndef PERL_RC_STACK
5593 const SSize_t size = AvFILLp(av) + 1;
5594 /* The ternary gives consistency with av_extend() */
5595 AV *newav = newAV_alloc_xz(size < PERL_ARRAY_NEW_MIN_KEY ?
5596 PERL_ARRAY_NEW_MIN_KEY : size);
5597 #ifndef PERL_RC_STACK
5598 AvREIFY_only(newav);
5600 PAD_SVl(0) = MUTABLE_SV(newav);
5601 SvREFCNT_dec_NN(av);
5611 I32 old_savestack_ix;
5612 SV *sv = *PL_stack_sp;
5617 /* Locate the CV to call:
5618 * - most common case: RV->CV: f(), $ref->():
5619 * note that if a sub is compiled before its caller is compiled,
5620 * the stash entry will be a ref to a CV, rather than being a GV.
5621 * - second most common case: CV: $ref->method()
5624 /* a non-magic-RV -> CV ? */
5625 if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
5626 cv = MUTABLE_CV(SvRV(sv));
5627 if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
5631 cv = MUTABLE_CV(sv);
5634 if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
5635 /* handle all the weird cases */
5636 switch (SvTYPE(sv)) {
5638 if (!isGV_with_GP(sv))
5642 cv = GvCVu((const GV *)sv);
5643 if (UNLIKELY(!cv)) {
5645 cv = sv_2cv(sv, &stash, &gv, 0);
5647 old_savestack_ix = PL_savestack_ix;
5658 if (UNLIKELY(SvAMAGIC(sv))) {
5659 sv = amagic_deref_call(sv, to_cv_amg);
5665 if (UNLIKELY(!SvOK(sv)))
5666 DIE(aTHX_ PL_no_usym, "a subroutine");
5668 sym = SvPV_nomg_const(sv, len);
5669 if (PL_op->op_private & HINT_STRICT_REFS)
5670 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
5671 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
5674 cv = MUTABLE_CV(SvRV(sv));
5675 if (LIKELY(SvTYPE(cv) == SVt_PVCV))
5681 DIE(aTHX_ "Not a CODE reference");
5685 /* At this point we want to save PL_savestack_ix, either by doing a
5686 * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
5687 * CV we will be using (so we don't know whether its XS, so we can't
5688 * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
5689 * the save stack. So remember where we are currently on the save
5690 * stack, and later update the CX or scopestack entry accordingly. */
5691 old_savestack_ix = PL_savestack_ix;
5693 /* these two fields are in a union. If they ever become separate,
5694 * we have to test for both of them being null below */
5696 assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
5697 while (UNLIKELY(!CvROOT(cv))) {
5701 /* anonymous or undef'd function leaves us no recourse */
5702 if (CvLEXICAL(cv) && CvHASGV(cv))
5703 DIE(aTHX_ "Undefined subroutine &%" SVf " called",
5704 SVfARG(cv_name(cv, NULL, 0)));
5705 if (CvANON(cv) || !CvHASGV(cv)) {
5706 DIE(aTHX_ "Undefined subroutine called");
5709 /* autoloaded stub? */
5710 if (cv != GvCV(gv = CvGV(cv))) {
5713 /* should call AUTOLOAD now? */
5716 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
5717 (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
5718 |(PL_op->op_flags & OPf_REF
5719 ? GV_AUTOLOAD_ISMETHOD
5721 cv = autogv ? GvCV(autogv) : NULL;
5724 sub_name = sv_newmortal();
5725 gv_efullname3(sub_name, gv, NULL);
5726 DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
5730 /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
5731 if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
5732 DIE(aTHX_ "Closure prototype called");
5734 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
5737 Perl_get_db_sub(aTHX_ &sv, cv);
5739 PL_curcopdb = PL_curcop;
5741 /* check for lsub that handles lvalue subroutines */
5742 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
5743 /* if lsub not found then fall back to DB::sub */
5744 if (!cv) cv = GvCV(PL_DBsub);
5746 cv = GvCV(PL_DBsub);
5749 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
5750 DIE(aTHX_ "No DB::sub routine defined");
5753 rpp_popfree_1(); /* finished with sv now */
5755 if (!(CvISXSUB(cv))) {
5756 /* This path taken at least 75% of the time */
5763 /* keep PADTMP args alive throughout the call (we need to do this
5764 * because @_ isn't refcounted). Note that we create the mortals
5765 * in the caller's tmps frame, so they won't be freed until after
5766 * we return from the sub.
5770 while (svp < PL_stack_sp) {
5775 SV *newsv = sv_mortalcopy(sv);
5777 #ifdef PERL_RC_STACK
5778 /* should just skip the mortalisation instead */
5779 SvREFCNT_inc_simple_void_NN(newsv);
5780 SvREFCNT_dec_NN(sv);
5789 cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
5790 hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
5791 cx_pushsub(cx, cv, PL_op->op_next, hasargs);
5793 padlist = CvPADLIST(cv);
5794 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
5795 pad_push(padlist, depth);
5796 PAD_SET_CUR_NOSAVE(padlist, depth);
5797 if (LIKELY(hasargs)) {
5798 AV *const av = MUTABLE_AV(PAD_SVl(0));
5802 defavp = &GvAV(PL_defgv);
5803 cx->blk_sub.savearray = *defavp;
5804 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
5806 /* it's the responsibility of whoever leaves a sub to ensure
5807 * that a clean, empty AV is left in pad[0]. This is normally
5808 * done by cx_popsub() */
5810 #ifdef PERL_RC_STACK
5813 assert(!AvREAL(av));
5815 assert(AvFILLp(av) == -1);
5817 items = PL_stack_sp - MARK;
5818 if (UNLIKELY(items - 1 > AvMAX(av))) {
5819 SV **ary = AvALLOC(av);
5820 Renew(ary, items, SV*);
5821 AvMAX(av) = items - 1;
5827 Copy(MARK+1,AvARRAY(av),items,SV*);
5828 AvFILLp(av) = items - 1;
5829 #ifdef PERL_RC_STACK
5830 /* transfer ownership of the arguments' refcounts to av */
5834 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5836 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5837 SVfARG(cv_name(cv, NULL, 0)));
5838 /* warning must come *after* we fully set up the context
5839 * stuff so that __WARN__ handlers can safely dounwind()
5842 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
5843 && ckWARN(WARN_RECURSION)
5844 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
5845 sub_crush_depth(cv);
5849 SSize_t markix = TOPMARK;
5853 /* pretend we did the ENTER earlier */
5854 PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
5858 if (UNLIKELY(((PL_op->op_private
5859 & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
5860 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5862 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5863 SVfARG(cv_name(cv, NULL, 0)));
5865 if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
5866 /* Need to copy @_ to stack. Alternative may be to
5867 * switch stack to @_, and copy return values
5868 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
5869 AV * const av = GvAV(PL_defgv);
5870 const SSize_t items = AvFILL(av) + 1;
5874 const bool m = cBOOL(SvRMAGICAL(av));
5875 /* Mark is at the end of the stack. */
5877 for (; i < items; ++i)
5881 SV ** const svp = av_fetch(av, i, 0);
5882 sv = svp ? *svp : NULL;
5885 sv = AvARRAY(av)[i];
5887 rpp_push_1(sv ? sv : av_nonelem(av, i));
5892 SV **mark = PL_stack_base + markix;
5893 SSize_t items = PL_stack_sp - mark;
5896 if (*mark && SvPADTMP(*mark)) {
5898 SV *newsv = sv_mortalcopy(oldsv);
5900 #ifdef PERL_RC_STACK
5901 /* should just skip the mortalisation instead */
5902 SvREFCNT_inc_simple_void_NN(newsv);
5903 SvREFCNT_dec_NN(oldsv);
5909 /* We assume first XSUB in &DB::sub is the called one. */
5910 if (UNLIKELY(PL_curcopdb)) {
5911 SAVEVPTR(PL_curcop);
5912 PL_curcop = PL_curcopdb;
5915 /* Do we need to open block here? XXXX */
5917 /* calculate gimme here as PL_op might get changed and then not
5918 * restored until the LEAVE further down */
5919 is_scalar = (GIMME_V == G_SCALAR);
5921 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
5926 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5927 /* This duplicates the check done in runops_debug(), but provides more
5928 * information in the common case of the fault being with an XSUB.
5930 * It should also catch an XSUB pushing more than it extends
5931 * in scalar context.
5933 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
5934 Perl_croak_nocontext(
5935 "panic: XSUB %s::%s (%s) failed to extend arg stack: "
5936 "base=%p, sp=%p, hwm=%p\n",
5937 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv),
5938 PL_stack_base, PL_stack_sp,
5939 PL_stack_base + PL_curstackinfo->si_stack_hwm);
5941 /* Enforce some sanity in scalar context. */
5943 SV **svp = PL_stack_base + markix + 1;
5944 if (svp != PL_stack_sp) {
5945 #ifdef PERL_RC_STACK
5946 if (svp < PL_stack_sp) {
5947 /* move return value to bottom of stack frame
5948 * and free everything else */
5949 SV* retsv = *PL_stack_sp;
5950 *PL_stack_sp = *svp;
5952 rpp_popfree_to(svp);
5955 *++PL_stack_sp = &PL_sv_undef;
5957 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
5968 Perl_sub_crush_depth(pTHX_ CV *cv)
5970 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
5973 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
5975 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
5976 SVfARG(cv_name(cv,NULL,0)));
5982 /* like croak, but report in context of caller */
5985 Perl_croak_caller(const char *pat, ...)
5989 const PERL_CONTEXT *cx = caller_cx(0, NULL);
5991 /* make error appear at call site */
5993 PL_curcop = cx->blk_oldcop;
5995 va_start(args, pat);
5997 NOT_REACHED; /* NOTREACHED */
6005 SV* const elemsv = PL_stack_sp[0];
6006 IV elem = SvIV(elemsv);
6007 AV *const av = MUTABLE_AV(PL_stack_sp[-1]);
6008 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
6009 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
6010 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6011 bool preeminent = TRUE;
6015 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
6016 Perl_warner(aTHX_ packWARN(WARN_MISC),
6017 "Use of reference \"%" SVf "\" as array index",
6019 if (UNLIKELY(SvTYPE(av) != SVt_PVAV)) {
6020 retsv = &PL_sv_undef;
6024 if (UNLIKELY(localizing)) {
6028 /* Try to preserve the existence of a tied array
6029 * element by using EXISTS and DELETE if possible.
6030 * Fall back to FETCH and STORE otherwise. */
6031 if (SvCANEXISTDELETE(av))
6032 preeminent = av_exists(av, elem);
6035 svp = av_fetch(av, elem, lval && !defer);
6037 #ifdef PERL_MALLOC_WRAP
6038 if (SvUOK(elemsv)) {
6039 const UV uv = SvUV(elemsv);
6040 elem = uv > IV_MAX ? IV_MAX : uv;
6042 else if (SvNOK(elemsv))
6043 elem = (IV)SvNV(elemsv);
6045 MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend");
6048 if (!svp || !*svp) {
6051 DIE(aTHX_ PL_no_aelem, elem);
6052 len = av_top_index(av);
6053 /* Resolve a negative index that falls within the array. Leave
6054 it negative it if falls outside the array. */
6055 if (elem < 0 && len + elem >= 0)
6057 if (elem >= 0 && elem <= len)
6058 /* Falls within the array. */
6059 retsv = av_nonelem(av, elem);
6061 /* Falls outside the array. If it is negative,
6062 magic_setdefelem will use the index for error reporting.
6064 retsv = sv_2mortal(newSVavdefelem(av, elem, 1));
6067 if (UNLIKELY(localizing)) {
6069 save_aelem(av, elem, svp);
6071 SAVEADELETE(av, elem);
6073 else if (PL_op->op_private & OPpDEREF) {
6074 retsv = vivify_ref(*svp, PL_op->op_private & OPpDEREF);
6078 sv = (svp ? *svp : &PL_sv_undef);
6079 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
6084 rpp_replace_2_1(retsv);
6089 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
6091 PERL_ARGS_ASSERT_VIVIFY_REF;
6096 Perl_croak_no_modify();
6097 prepare_SV_for_RV(sv);
6100 SvRV_set(sv, newSV_type(SVt_NULL));
6103 SvRV_set(sv, MUTABLE_SV(newAV()));
6106 SvRV_set(sv, MUTABLE_SV(newHV()));
6113 if (SvGMAGICAL(sv)) {
6114 /* copy the sv without magic to prevent magic from being
6116 SV* msv = sv_newmortal();
6117 sv_setsv_nomg(msv, sv);
6123 PERL_STATIC_INLINE HV *
6124 S_opmethod_stash(pTHX_ SV* meth)
6129 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
6130 ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
6131 "package or object reference", SVfARG(meth)),
6133 : *(PL_stack_base + TOPMARK + 1);
6135 PERL_ARGS_ASSERT_OPMETHOD_STASH;
6139 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
6142 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
6143 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
6144 stash = gv_stashsv(sv, GV_CACHE_ONLY);
6145 if (stash) return stash;
6149 ob = MUTABLE_SV(SvRV(sv));
6150 else if (!SvOK(sv)) goto undefined;
6151 else if (isGV_with_GP(sv)) {
6153 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
6154 "without a package or object reference",
6157 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
6158 assert(!LvTARGLEN(ob));
6162 /* Replace the object at the base of the stack frame.
6163 * This is "below" whatever pp_wrap has wrapped, so needs freeing.
6165 SV *newsv = sv_2mortal(newRV(ob));
6166 SV **svp = (PL_stack_base + TOPMARK + 1);
6167 #ifdef PERL_RC_STACK
6171 #ifdef PERL_RC_STACK
6172 SvREFCNT_inc_simple_void_NN(newsv);
6173 SvREFCNT_dec_NN(oldsv);
6177 /* this isn't a reference */
6180 const char * const packname = SvPV_nomg_const(sv, packlen);
6181 const U32 packname_utf8 = SvUTF8(sv);
6182 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
6183 if (stash) return stash;
6185 if (!(iogv = gv_fetchpvn_flags(
6186 packname, packlen, packname_utf8, SVt_PVIO
6188 !(ob=MUTABLE_SV(GvIO(iogv))))
6190 /* this isn't the name of a filehandle either */
6193 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
6194 "without a package or object reference",
6197 /* assume it's a package name */
6198 stash = gv_stashpvn(packname, packlen, packname_utf8);
6199 if (stash) return stash;
6200 else return MUTABLE_HV(sv);
6202 /* it _is_ a filehandle name -- replace with a reference.
6203 * Replace the object at the base of the stack frame.
6204 * This is "below" whatever pp_wrap has wrapped, so needs freeing.
6206 SV *newsv = sv_2mortal(newRV(MUTABLE_SV(iogv)));
6207 SV **svp = (PL_stack_base + TOPMARK + 1);
6208 #ifdef PERL_RC_STACK
6212 #ifdef PERL_RC_STACK
6213 SvREFCNT_inc_simple_void_NN(newsv);
6214 SvREFCNT_dec_NN(oldsv);
6218 /* if we got here, ob should be an object or a glob */
6219 if (!ob || !(SvOBJECT(ob)
6220 || (isGV_with_GP(ob)
6221 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
6224 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
6225 SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
6226 ? newSVpvs_flags("DOES", SVs_TEMP)
6237 SV* const meth = *PL_stack_sp;
6240 SV* const rmeth = SvRV(meth);
6241 if (SvTYPE(rmeth) == SVt_PVCV) {
6242 rpp_replace_1_1(rmeth);
6247 stash = opmethod_stash(meth);
6249 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
6252 rpp_replace_1_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6256 #define METHOD_CHECK_CACHE(stash,cache,meth) \
6257 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
6259 gv = MUTABLE_GV(HeVAL(he)); \
6260 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
6261 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
6263 rpp_xpush_1(MUTABLE_SV(GvCV(gv))); \
6271 SV* const meth = cMETHOP_meth;
6272 HV* const stash = opmethod_stash(meth);
6274 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
6275 METHOD_CHECK_CACHE(stash, stash, meth);
6278 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
6281 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6289 SV* const meth = cMETHOP_meth;
6290 HV* const stash = CopSTASH(PL_curcop);
6291 /* Actually, SUPER doesn't need real object's (or class') stash at all,
6292 * as it uses CopSTASH. However, we must ensure that object(class) is
6293 * correct (this check is done by S_opmethod_stash) */
6294 opmethod_stash(meth);
6296 if ((cache = HvMROMETA(stash)->super)) {
6297 METHOD_CHECK_CACHE(stash, cache, meth);
6300 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
6303 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6310 SV* const meth = cMETHOP_meth;
6311 HV* stash = gv_stashsv(cMETHOP_rclass, 0);
6312 opmethod_stash(meth); /* not used but needed for error checks */
6314 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
6315 else stash = MUTABLE_HV(cMETHOP_rclass);
6317 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
6320 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6324 PP(pp_method_redir_super)
6328 SV* const meth = cMETHOP_meth;
6329 HV* stash = gv_stashsv(cMETHOP_rclass, 0);
6330 opmethod_stash(meth); /* not used but needed for error checks */
6332 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOP_rclass);
6333 else if ((cache = HvMROMETA(stash)->super)) {
6334 METHOD_CHECK_CACHE(stash, cache, meth);
6337 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
6340 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
6345 * ex: set ts=8 sts=4 sw=4 et: