This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a44ee34d9ed986b3572208b326cc22f6c21b8f95
[perl5.git] / pp_hot.c
1 /*    pp_hot.c
2  *
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
5  *
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.
8  *
9  */
10
11 /*
12  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13  * shaking the air.
14  *
15  *                  Awake!  Awake!  Fear, Fire, Foes!  Awake!
16  *                               Fire, Foes!  Awake!
17  *
18  *     [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
19  */
20
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.
26  *
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
31  * performance.
32  */
33
34 #include "EXTERN.h"
35 #define PERL_IN_PP_HOT_C
36 #include "perl.h"
37
38 /* Hot code. */
39
40 PP(pp_const)
41 {
42     dSP;
43     XPUSHs(cSVOP_sv);
44     RETURN;
45 }
46
47 PP(pp_nextstate)
48 {
49     PL_curcop = (COP*)PL_op;
50     TAINT_NOT;          /* Each statement is presumed innocent */
51     PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
52     FREETMPS;
53     PERL_ASYNC_CHECK();
54     return NORMAL;
55 }
56
57 PP(pp_gvsv)
58 {
59     dSP;
60     EXTEND(SP,1);
61     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
62         PUSHs(save_scalar(cGVOP_gv));
63     else
64         PUSHs(GvSVn(cGVOP_gv));
65     RETURN;
66 }
67
68
69 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
70
71 PP(pp_null)
72 {
73     return NORMAL;
74 }
75
76 /* This is sometimes called directly by pp_coreargs, pp_grepstart and
77    amagic_call. */
78 PP(pp_pushmark)
79 {
80     PUSHMARK(PL_stack_sp);
81     return NORMAL;
82 }
83
84 PP(pp_stringify)
85 {
86     dSP; dTARGET;
87     SV * const sv = TOPs;
88     SETs(TARG);
89     sv_copypv(TARG, sv);
90     SvSETMAGIC(TARG);
91     /* no PUTBACK, SETs doesn't inc/dec SP */
92     return NORMAL;
93 }
94
95 PP(pp_gv)
96 {
97     dSP;
98     XPUSHs(MUTABLE_SV(cGVOP_gv));
99     RETURN;
100 }
101
102
103 /* also used for: pp_andassign() */
104
105 PP(pp_and)
106 {
107     PERL_ASYNC_CHECK();
108     {
109         /* SP is not used to remove a variable that is saved across the
110           sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
111           register or load/store vs direct mem ops macro is introduced, this
112           should be a define block between direct PL_stack_sp and dSP operations,
113           presently, using PL_stack_sp is bias towards CISC cpus */
114         SV * const sv = *PL_stack_sp;
115         if (!SvTRUE_NN(sv))
116             return NORMAL;
117         else {
118             if (PL_op->op_type == OP_AND)
119                 --PL_stack_sp;
120             return cLOGOP->op_other;
121         }
122     }
123 }
124
125 PP(pp_sassign)
126 {
127     dSP;
128     /* sassign keeps its args in the optree traditionally backwards.
129        So we pop them differently.
130     */
131     SV *left = POPs; SV *right = TOPs;
132
133     if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
134         SV * const temp = left;
135         left = right; right = temp;
136     }
137     assert(TAINTING_get || !TAINT_get);
138     if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
139         TAINT_NOT;
140     if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
141         /* *foo =\&bar */
142         SV * const cv = SvRV(right);
143         const U32 cv_type = SvTYPE(cv);
144         const bool is_gv = isGV_with_GP(left);
145         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
146
147         if (!got_coderef) {
148             assert(SvROK(cv));
149         }
150
151         /* Can do the optimisation if left (LVALUE) is not a typeglob,
152            right (RVALUE) is a reference to something, and we're in void
153            context. */
154         if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
155             /* Is the target symbol table currently empty?  */
156             GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
157             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
158                 /* Good. Create a new proxy constant subroutine in the target.
159                    The gv becomes a(nother) reference to the constant.  */
160                 SV *const value = SvRV(cv);
161
162                 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
163                 SvPCS_IMPORTED_on(gv);
164                 SvRV_set(gv, value);
165                 SvREFCNT_inc_simple_void(value);
166                 SETs(left);
167                 RETURN;
168             }
169         }
170
171         /* Need to fix things up.  */
172         if (!is_gv) {
173             /* Need to fix GV.  */
174             left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
175         }
176
177         if (!got_coderef) {
178             /* We've been returned a constant rather than a full subroutine,
179                but they expect a subroutine reference to apply.  */
180             if (SvROK(cv)) {
181                 ENTER_with_name("sassign_coderef");
182                 SvREFCNT_inc_void(SvRV(cv));
183                 /* newCONSTSUB takes a reference count on the passed in SV
184                    from us.  We set the name to NULL, otherwise we get into
185                    all sorts of fun as the reference to our new sub is
186                    donated to the GV that we're about to assign to.
187                 */
188                 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
189                                                       SvRV(cv))));
190                 SvREFCNT_dec_NN(cv);
191                 LEAVE_with_name("sassign_coderef");
192             } else {
193                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
194                    is that
195                    First:   ops for \&{"BONK"}; return us the constant in the
196                             symbol table
197                    Second:  ops for *{"BONK"} cause that symbol table entry
198                             (and our reference to it) to be upgraded from RV
199                             to typeblob)
200                    Thirdly: We get here. cv is actually PVGV now, and its
201                             GvCV() is actually the subroutine we're looking for
202
203                    So change the reference so that it points to the subroutine
204                    of that typeglob, as that's what they were after all along.
205                 */
206                 GV *const upgraded = MUTABLE_GV(cv);
207                 CV *const source = GvCV(upgraded);
208
209                 assert(source);
210                 assert(CvFLAGS(source) & CVf_CONST);
211
212                 SvREFCNT_inc_simple_void_NN(source);
213                 SvREFCNT_dec_NN(upgraded);
214                 SvRV_set(right, MUTABLE_SV(source));
215             }
216         }
217
218     }
219     if (
220       UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
221       (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
222     )
223         Perl_warner(aTHX_
224             packWARN(WARN_MISC), "Useless assignment to a temporary"
225         );
226     SvSetMagicSV(left, right);
227     SETs(left);
228     RETURN;
229 }
230
231 PP(pp_cond_expr)
232 {
233     dSP;
234     SV *sv;
235
236     PERL_ASYNC_CHECK();
237     sv = POPs;
238     RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
239 }
240
241 PP(pp_unstack)
242 {
243     PERL_CONTEXT *cx;
244     PERL_ASYNC_CHECK();
245     TAINT_NOT;          /* Each statement is presumed innocent */
246     cx  = CX_CUR();
247     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
248     FREETMPS;
249     if (!(PL_op->op_flags & OPf_SPECIAL)) {
250         assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
251         CX_LEAVE_SCOPE(cx);
252     }
253     return NORMAL;
254 }
255
256 PP(pp_concat)
257 {
258   dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
259   {
260     dPOPTOPssrl;
261     bool lbyte;
262     STRLEN rlen;
263     const char *rpv = NULL;
264     bool rbyte = FALSE;
265     bool rcopied = FALSE;
266
267     if (TARG == right && right != left) { /* $r = $l.$r */
268         rpv = SvPV_nomg_const(right, rlen);
269         rbyte = !DO_UTF8(right);
270         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
271         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
272         rcopied = TRUE;
273     }
274
275     if (TARG != left) { /* not $l .= $r */
276         STRLEN llen;
277         const char* const lpv = SvPV_nomg_const(left, llen);
278         lbyte = !DO_UTF8(left);
279         sv_setpvn(TARG, lpv, llen);
280         if (!lbyte)
281             SvUTF8_on(TARG);
282         else
283             SvUTF8_off(TARG);
284     }
285     else { /* $l .= $r   and   left == TARG */
286         if (!SvOK(left)) {
287             if ((left == right                          /* $l .= $l */
288                  || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
289                 && ckWARN(WARN_UNINITIALIZED)
290                 )
291                 report_uninit(left);
292             SvPVCLEAR(left);
293         }
294         else {
295             SvPV_force_nomg_nolen(left);
296         }
297         lbyte = !DO_UTF8(left);
298         if (IN_BYTES)
299             SvUTF8_off(left);
300     }
301
302     if (!rcopied) {
303         rpv = SvPV_nomg_const(right, rlen);
304         rbyte = !DO_UTF8(right);
305     }
306     if (lbyte != rbyte) {
307         if (lbyte)
308             sv_utf8_upgrade_nomg(TARG);
309         else {
310             if (!rcopied)
311                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
312             sv_utf8_upgrade_nomg(right);
313             rpv = SvPV_nomg_const(right, rlen);
314         }
315     }
316     sv_catpvn_nomg(TARG, rpv, rlen);
317
318     SETTARG;
319     RETURN;
320   }
321 }
322
323 /* push the elements of av onto the stack.
324  * Returns PL_op->op_next to allow tail-call optimisation of its callers */
325
326 STATIC OP*
327 S_pushav(pTHX_ AV* const av)
328 {
329     dSP;
330     const SSize_t maxarg = AvFILL(av) + 1;
331     EXTEND(SP, maxarg);
332     if (UNLIKELY(SvRMAGICAL(av))) {
333         PADOFFSET i;
334         for (i=0; i < (PADOFFSET)maxarg; i++) {
335             SV ** const svp = av_fetch(av, i, FALSE);
336             SP[i+1] = svp ? *svp : &PL_sv_undef;
337         }
338     }
339     else {
340         PADOFFSET i;
341         for (i=0; i < (PADOFFSET)maxarg; i++) {
342             SV * const sv = AvARRAY(av)[i];
343             SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
344         }
345     }
346     SP += maxarg;
347     PUTBACK;
348     return NORMAL;
349 }
350
351
352 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
353
354 PP(pp_padrange)
355 {
356     dSP;
357     PADOFFSET base = PL_op->op_targ;
358     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
359     if (PL_op->op_flags & OPf_SPECIAL) {
360         /* fake the RHS of my ($x,$y,..) = @_ */
361         PUSHMARK(SP);
362         (void)S_pushav(aTHX_ GvAVn(PL_defgv));
363         SPAGAIN;
364     }
365
366     /* note, this is only skipped for compile-time-known void cxt */
367     if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
368         int i;
369
370         EXTEND(SP, count);
371         PUSHMARK(SP);
372         for (i = 0; i <count; i++)
373             *++SP = PAD_SV(base+i);
374     }
375     if (PL_op->op_private & OPpLVAL_INTRO) {
376         SV **svp = &(PAD_SVl(base));
377         const UV payload = (UV)(
378                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
379                     | (count << SAVE_TIGHT_SHIFT)
380                     | SAVEt_CLEARPADRANGE);
381         int i;
382
383         STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
384         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
385                 == (Size_t)base);
386         {
387             dSS_ADD;
388             SS_ADD_UV(payload);
389             SS_ADD_END(1);
390         }
391
392         for (i = 0; i <count; i++)
393             SvPADSTALE_off(*svp++); /* mark lexical as active */
394     }
395     RETURN;
396 }
397
398
399 PP(pp_padsv)
400 {
401     dSP;
402     EXTEND(SP, 1);
403     {
404         OP * const op = PL_op;
405         /* access PL_curpad once */
406         SV ** const padentry = &(PAD_SVl(op->op_targ));
407         {
408             dTARG;
409             TARG = *padentry;
410             PUSHs(TARG);
411             PUTBACK; /* no pop/push after this, TOPs ok */
412         }
413         if (op->op_flags & OPf_MOD) {
414             if (op->op_private & OPpLVAL_INTRO)
415                 if (!(op->op_private & OPpPAD_STATE))
416                     save_clearsv(padentry);
417             if (op->op_private & OPpDEREF) {
418                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
419                    than TARG reduces the scope of TARG, so it does not
420                    span the call to save_clearsv, resulting in smaller
421                    machine code. */
422                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
423             }
424         }
425         return op->op_next;
426     }
427 }
428
429 PP(pp_readline)
430 {
431     dSP;
432     /* pp_coreargs pushes a NULL to indicate no args passed to
433      * CORE::readline() */
434     if (TOPs) {
435         SvGETMAGIC(TOPs);
436         tryAMAGICunTARGETlist(iter_amg, 0);
437         PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
438     }
439     else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
440     if (!isGV_with_GP(PL_last_in_gv)) {
441         if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
442             PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
443         else {
444             dSP;
445             XPUSHs(MUTABLE_SV(PL_last_in_gv));
446             PUTBACK;
447             Perl_pp_rv2gv(aTHX);
448             PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
449             if (PL_last_in_gv == (GV *)&PL_sv_undef)
450                 PL_last_in_gv = NULL;
451             else
452                 assert(isGV_with_GP(PL_last_in_gv));
453         }
454     }
455     return do_readline();
456 }
457
458 PP(pp_eq)
459 {
460     dSP;
461     SV *left, *right;
462
463     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
464     right = POPs;
465     left  = TOPs;
466     SETs(boolSV(
467         (SvIOK_notUV(left) && SvIOK_notUV(right))
468         ? (SvIVX(left) == SvIVX(right))
469         : ( do_ncmp(left, right) == 0)
470     ));
471     RETURN;
472 }
473
474
475 /* also used for: pp_i_preinc() */
476
477 PP(pp_preinc)
478 {
479     SV *sv = *PL_stack_sp;
480
481     if (LIKELY(((sv->sv_flags &
482                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
483                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
484                 == SVf_IOK))
485         && SvIVX(sv) != IV_MAX)
486     {
487         SvIV_set(sv, SvIVX(sv) + 1);
488     }
489     else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
490         sv_inc(sv);
491     SvSETMAGIC(sv);
492     return NORMAL;
493 }
494
495
496 /* also used for: pp_i_predec() */
497
498 PP(pp_predec)
499 {
500     SV *sv = *PL_stack_sp;
501
502     if (LIKELY(((sv->sv_flags &
503                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
504                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
505                 == SVf_IOK))
506         && SvIVX(sv) != IV_MIN)
507     {
508         SvIV_set(sv, SvIVX(sv) - 1);
509     }
510     else /* Do all the PERL_PRESERVE_IVUV and hard cases  in sv_dec */
511         sv_dec(sv);
512     SvSETMAGIC(sv);
513     return NORMAL;
514 }
515
516
517 /* also used for: pp_orassign() */
518
519 PP(pp_or)
520 {
521     dSP;
522     SV *sv;
523     PERL_ASYNC_CHECK();
524     sv = TOPs;
525     if (SvTRUE_NN(sv))
526         RETURN;
527     else {
528         if (PL_op->op_type == OP_OR)
529             --SP;
530         RETURNOP(cLOGOP->op_other);
531     }
532 }
533
534
535 /* also used for: pp_dor() pp_dorassign() */
536
537 PP(pp_defined)
538 {
539     dSP;
540     SV* sv;
541     bool defined;
542     const int op_type = PL_op->op_type;
543     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
544
545     if (is_dor) {
546         PERL_ASYNC_CHECK();
547         sv = TOPs;
548         if (UNLIKELY(!sv || !SvANY(sv))) {
549             if (op_type == OP_DOR)
550                 --SP;
551             RETURNOP(cLOGOP->op_other);
552         }
553     }
554     else {
555         /* OP_DEFINED */
556         sv = POPs;
557         if (UNLIKELY(!sv || !SvANY(sv)))
558             RETPUSHNO;
559     }
560
561     defined = FALSE;
562     switch (SvTYPE(sv)) {
563     case SVt_PVAV:
564         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
565             defined = TRUE;
566         break;
567     case SVt_PVHV:
568         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
569             defined = TRUE;
570         break;
571     case SVt_PVCV:
572         if (CvROOT(sv) || CvXSUB(sv))
573             defined = TRUE;
574         break;
575     default:
576         SvGETMAGIC(sv);
577         if (SvOK(sv))
578             defined = TRUE;
579         break;
580     }
581
582     if (is_dor) {
583         if(defined) 
584             RETURN; 
585         if(op_type == OP_DOR)
586             --SP;
587         RETURNOP(cLOGOP->op_other);
588     }
589     /* assuming OP_DEFINED */
590     if(defined) 
591         RETPUSHYES;
592     RETPUSHNO;
593 }
594
595
596
597 PP(pp_add)
598 {
599     dSP; dATARGET; bool useleft; SV *svl, *svr;
600
601     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
602     svr = TOPs;
603     svl = TOPm1s;
604
605 #ifdef PERL_PRESERVE_IVUV
606
607     /* special-case some simple common cases */
608     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
609         IV il, ir;
610         U32 flags = (svl->sv_flags & svr->sv_flags);
611         if (flags & SVf_IOK) {
612             /* both args are simple IVs */
613             UV topl, topr;
614             il = SvIVX(svl);
615             ir = SvIVX(svr);
616           do_iv:
617             topl = ((UV)il) >> (UVSIZE * 8 - 2);
618             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
619
620             /* if both are in a range that can't under/overflow, do a
621              * simple integer add: if the top of both numbers
622              * are 00  or 11, then it's safe */
623             if (!( ((topl+1) | (topr+1)) & 2)) {
624                 SP--;
625                 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
626                 SETs(TARG);
627                 RETURN;
628             }
629             goto generic;
630         }
631         else if (flags & SVf_NOK) {
632             /* both args are NVs */
633             NV nl = SvNVX(svl);
634             NV nr = SvNVX(svr);
635
636             if (
637 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
638                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
639                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
640 #else
641                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
642 #endif
643                 )
644                 /* nothing was lost by converting to IVs */
645                 goto do_iv;
646             SP--;
647             TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
648             SETs(TARG);
649             RETURN;
650         }
651     }
652
653   generic:
654
655     useleft = USE_LEFT(svl);
656     /* We must see if we can perform the addition with integers if possible,
657        as the integer code detects overflow while the NV code doesn't.
658        If either argument hasn't had a numeric conversion yet attempt to get
659        the IV. It's important to do this now, rather than just assuming that
660        it's not IOK as a PV of "9223372036854775806" may not take well to NV
661        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
662        integer in case the second argument is IV=9223372036854775806
663        We can (now) rely on sv_2iv to do the right thing, only setting the
664        public IOK flag if the value in the NV (or PV) slot is truly integer.
665
666        A side effect is that this also aggressively prefers integer maths over
667        fp maths for integer values.
668
669        How to detect overflow?
670
671        C 99 section 6.2.6.1 says
672
673        The range of nonnegative values of a signed integer type is a subrange
674        of the corresponding unsigned integer type, and the representation of
675        the same value in each type is the same. A computation involving
676        unsigned operands can never overflow, because a result that cannot be
677        represented by the resulting unsigned integer type is reduced modulo
678        the number that is one greater than the largest value that can be
679        represented by the resulting type.
680
681        (the 9th paragraph)
682
683        which I read as "unsigned ints wrap."
684
685        signed integer overflow seems to be classed as "exception condition"
686
687        If an exceptional condition occurs during the evaluation of an
688        expression (that is, if the result is not mathematically defined or not
689        in the range of representable values for its type), the behavior is
690        undefined.
691
692        (6.5, the 5th paragraph)
693
694        I had assumed that on 2s complement machines signed arithmetic would
695        wrap, hence coded pp_add and pp_subtract on the assumption that
696        everything perl builds on would be happy.  After much wailing and
697        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
698        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
699        unsigned code below is actually shorter than the old code. :-)
700     */
701
702     if (SvIV_please_nomg(svr)) {
703         /* Unless the left argument is integer in range we are going to have to
704            use NV maths. Hence only attempt to coerce the right argument if
705            we know the left is integer.  */
706         UV auv = 0;
707         bool auvok = FALSE;
708         bool a_valid = 0;
709
710         if (!useleft) {
711             auv = 0;
712             a_valid = auvok = 1;
713             /* left operand is undef, treat as zero. + 0 is identity,
714                Could SETi or SETu right now, but space optimise by not adding
715                lots of code to speed up what is probably a rarish case.  */
716         } else {
717             /* Left operand is defined, so is it IV? */
718             if (SvIV_please_nomg(svl)) {
719                 if ((auvok = SvUOK(svl)))
720                     auv = SvUVX(svl);
721                 else {
722                     const IV aiv = SvIVX(svl);
723                     if (aiv >= 0) {
724                         auv = aiv;
725                         auvok = 1;      /* Now acting as a sign flag.  */
726                     } else {
727                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
728                     }
729                 }
730                 a_valid = 1;
731             }
732         }
733         if (a_valid) {
734             bool result_good = 0;
735             UV result;
736             UV buv;
737             bool buvok = SvUOK(svr);
738         
739             if (buvok)
740                 buv = SvUVX(svr);
741             else {
742                 const IV biv = SvIVX(svr);
743                 if (biv >= 0) {
744                     buv = biv;
745                     buvok = 1;
746                 } else
747                     buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
748             }
749             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
750                else "IV" now, independent of how it came in.
751                if a, b represents positive, A, B negative, a maps to -A etc
752                a + b =>  (a + b)
753                A + b => -(a - b)
754                a + B =>  (a - b)
755                A + B => -(a + b)
756                all UV maths. negate result if A negative.
757                add if signs same, subtract if signs differ. */
758
759             if (auvok ^ buvok) {
760                 /* Signs differ.  */
761                 if (auv >= buv) {
762                     result = auv - buv;
763                     /* Must get smaller */
764                     if (result <= auv)
765                         result_good = 1;
766                 } else {
767                     result = buv - auv;
768                     if (result <= buv) {
769                         /* result really should be -(auv-buv). as its negation
770                            of true value, need to swap our result flag  */
771                         auvok = !auvok;
772                         result_good = 1;
773                     }
774                 }
775             } else {
776                 /* Signs same */
777                 result = auv + buv;
778                 if (result >= auv)
779                     result_good = 1;
780             }
781             if (result_good) {
782                 SP--;
783                 if (auvok)
784                     SETu( result );
785                 else {
786                     /* Negate result */
787                     if (result <= (UV)IV_MIN)
788                         SETi(result == (UV)IV_MIN
789                                 ? IV_MIN : -(IV)result);
790                     else {
791                         /* result valid, but out of range for IV.  */
792                         SETn( -(NV)result );
793                     }
794                 }
795                 RETURN;
796             } /* Overflow, drop through to NVs.  */
797         }
798     }
799
800 #else
801     useleft = USE_LEFT(svl);
802 #endif
803
804     {
805         NV value = SvNV_nomg(svr);
806         (void)POPs;
807         if (!useleft) {
808             /* left operand is undef, treat as zero. + 0.0 is identity. */
809             SETn(value);
810             RETURN;
811         }
812         SETn( value + SvNV_nomg(svl) );
813         RETURN;
814     }
815 }
816
817
818 /* also used for: pp_aelemfast_lex() */
819
820 PP(pp_aelemfast)
821 {
822     dSP;
823     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
824         ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
825     const U32 lval = PL_op->op_flags & OPf_MOD;
826     const I8 key   = (I8)PL_op->op_private;
827     SV** svp;
828     SV *sv;
829
830     assert(SvTYPE(av) == SVt_PVAV);
831
832     EXTEND(SP, 1);
833
834     /* inlined av_fetch() for simple cases ... */
835     if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
836         sv = AvARRAY(av)[key];
837         if (sv) {
838             PUSHs(sv);
839             RETURN;
840         }
841     }
842
843     /* ... else do it the hard way */
844     svp = av_fetch(av, key, lval);
845     sv = (svp ? *svp : &PL_sv_undef);
846
847     if (UNLIKELY(!svp && lval))
848         DIE(aTHX_ PL_no_aelem, (int)key);
849
850     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
851         mg_get(sv);
852     PUSHs(sv);
853     RETURN;
854 }
855
856 PP(pp_join)
857 {
858     dSP; dMARK; dTARGET;
859     MARK++;
860     do_join(TARG, *MARK, MARK, SP);
861     SP = MARK;
862     SETs(TARG);
863     RETURN;
864 }
865
866 /* Oversized hot code. */
867
868 /* also used for: pp_say() */
869
870 PP(pp_print)
871 {
872     dSP; dMARK; dORIGMARK;
873     PerlIO *fp;
874     MAGIC *mg;
875     GV * const gv
876         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
877     IO *io = GvIO(gv);
878
879     if (io
880         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
881     {
882       had_magic:
883         if (MARK == ORIGMARK) {
884             /* If using default handle then we need to make space to
885              * pass object as 1st arg, so move other args up ...
886              */
887             MEXTEND(SP, 1);
888             ++MARK;
889             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
890             ++SP;
891         }
892         return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
893                                 mg,
894                                 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
895                                  | (PL_op->op_type == OP_SAY
896                                     ? TIED_METHOD_SAY : 0)), sp - mark);
897     }
898     if (!io) {
899         if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
900             && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
901             goto had_magic;
902         report_evil_fh(gv);
903         SETERRNO(EBADF,RMS_IFI);
904         goto just_say_no;
905     }
906     else if (!(fp = IoOFP(io))) {
907         if (IoIFP(io))
908             report_wrongway_fh(gv, '<');
909         else
910             report_evil_fh(gv);
911         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
912         goto just_say_no;
913     }
914     else {
915         SV * const ofs = GvSV(PL_ofsgv); /* $, */
916         MARK++;
917         if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
918             while (MARK <= SP) {
919                 if (!do_print(*MARK, fp))
920                     break;
921                 MARK++;
922                 if (MARK <= SP) {
923                     /* don't use 'ofs' here - it may be invalidated by magic callbacks */
924                     if (!do_print(GvSV(PL_ofsgv), fp)) {
925                         MARK--;
926                         break;
927                     }
928                 }
929             }
930         }
931         else {
932             while (MARK <= SP) {
933                 if (!do_print(*MARK, fp))
934                     break;
935                 MARK++;
936             }
937         }
938         if (MARK <= SP)
939             goto just_say_no;
940         else {
941             if (PL_op->op_type == OP_SAY) {
942                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
943                     goto just_say_no;
944             }
945             else if (PL_ors_sv && SvOK(PL_ors_sv))
946                 if (!do_print(PL_ors_sv, fp)) /* $\ */
947                     goto just_say_no;
948
949             if (IoFLAGS(io) & IOf_FLUSH)
950                 if (PerlIO_flush(fp) == EOF)
951                     goto just_say_no;
952         }
953     }
954     SP = ORIGMARK;
955     XPUSHs(&PL_sv_yes);
956     RETURN;
957
958   just_say_no:
959     SP = ORIGMARK;
960     XPUSHs(&PL_sv_undef);
961     RETURN;
962 }
963
964
965 /* do the common parts of pp_padhv() and pp_rv2hv()
966  * It assumes the caller has done EXTEND(SP, 1) or equivalent.
967  * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
968  * 'has_targ' indicates that the op has a target - this should
969  * be a compile-time constant so that the code can constant-folded as
970  * appropriate
971  * */
972
973 PERL_STATIC_INLINE OP*
974 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
975 {
976     bool tied;
977     dSP;
978
979     assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
980
981     if (gimme == G_ARRAY) {
982         hv_pushkv(hv);
983         return NORMAL;
984     }
985
986     if (is_keys)
987         /* 'keys %h' masquerading as '%h': reset iterator */
988         (void)hv_iterinit(hv);
989
990     tied = SvRMAGICAL(hv) && mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied);
991
992     if (  (  PL_op->op_private & OPpTRUEBOOL
993           || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
994              && block_gimme() == G_VOID)
995           )
996     ) {
997         if (tied)
998             PUSHs(Perl_hv_scalar(aTHX_ hv));
999         else
1000             PUSHs(HvUSEDKEYS(hv) ? &PL_sv_yes : &PL_sv_zero);
1001     }
1002     else if (gimme == G_SCALAR) {
1003         if (is_keys) {
1004             IV i;
1005             if (tied) {
1006                 i = 0;
1007                 while (hv_iternext(hv))
1008                     i++;
1009             }
1010             else
1011                 i = HvUSEDKEYS(hv);
1012             if (has_targ) {
1013                 dTARGET;
1014                 PUSHi(i);
1015             }
1016             else
1017                 mPUSHi(i);
1018         }
1019         else
1020             PUSHs(Perl_hv_scalar(aTHX_ hv));
1021     }
1022
1023     PUTBACK;
1024     return NORMAL;
1025 }
1026
1027
1028 /* This is also called directly by pp_lvavref.  */
1029 PP(pp_padav)
1030 {
1031     dSP; dTARGET;
1032     U8 gimme;
1033     assert(SvTYPE(TARG) == SVt_PVAV);
1034     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1035         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1036             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1037     EXTEND(SP, 1);
1038
1039     if (PL_op->op_flags & OPf_REF) {
1040         PUSHs(TARG);
1041         RETURN;
1042     }
1043     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1044         const I32 flags = is_lvalue_sub();
1045         if (flags && !(flags & OPpENTERSUB_INARGS)) {
1046             if (GIMME_V == G_SCALAR)
1047                 /* diag_listed_as: Can't return %s to lvalue scalar context */
1048                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1049             PUSHs(TARG);
1050             RETURN;
1051        }
1052     }
1053
1054     gimme = GIMME_V;
1055     if (gimme == G_ARRAY)
1056         return S_pushav(aTHX_ (AV*)TARG);
1057
1058     if (gimme == G_SCALAR) {
1059         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1060         if (!maxarg)
1061             PUSHs(&PL_sv_zero);
1062         else if (PL_op->op_private & OPpTRUEBOOL)
1063             PUSHs(&PL_sv_yes);
1064         else
1065             mPUSHi(maxarg);
1066     }
1067     RETURN;
1068 }
1069
1070
1071 PP(pp_padhv)
1072 {
1073     dSP; dTARGET;
1074     U8 gimme;
1075
1076     assert(SvTYPE(TARG) == SVt_PVHV);
1077     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1078         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1079             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1080
1081     EXTEND(SP, 1);
1082
1083     if (PL_op->op_flags & OPf_REF) {
1084         PUSHs(TARG);
1085         RETURN;
1086     }
1087     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1088         const I32 flags = is_lvalue_sub();
1089         if (flags && !(flags & OPpENTERSUB_INARGS)) {
1090             if (GIMME_V == G_SCALAR)
1091                 /* diag_listed_as: Can't return %s to lvalue scalar context */
1092                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
1093             PUSHs(TARG);
1094             RETURN;
1095         }
1096     }
1097
1098     gimme = GIMME_V;
1099
1100     return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
1101                         cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1102                         0 /* has_targ*/);
1103 }
1104
1105
1106 /* also used for: pp_rv2hv() */
1107 /* also called directly by pp_lvavref */
1108
1109 PP(pp_rv2av)
1110 {
1111     dSP; dTOPss;
1112     const U8 gimme = GIMME_V;
1113     static const char an_array[] = "an ARRAY";
1114     static const char a_hash[] = "a HASH";
1115     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1116                           || PL_op->op_type == OP_LVAVREF;
1117     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
1118
1119     SvGETMAGIC(sv);
1120     if (SvROK(sv)) {
1121         if (UNLIKELY(SvAMAGIC(sv))) {
1122             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
1123         }
1124         sv = SvRV(sv);
1125         if (UNLIKELY(SvTYPE(sv) != type))
1126             /* diag_listed_as: Not an ARRAY reference */
1127             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
1128         else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1129                 && PL_op->op_private & OPpLVAL_INTRO))
1130             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
1131     }
1132     else if (UNLIKELY(SvTYPE(sv) != type)) {
1133             GV *gv;
1134         
1135             if (!isGV_with_GP(sv)) {
1136                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
1137                                      type, &sp);
1138                 if (!gv)
1139                     RETURN;
1140             }
1141             else {
1142                 gv = MUTABLE_GV(sv);
1143             }
1144             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
1145             if (PL_op->op_private & OPpLVAL_INTRO)
1146                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
1147     }
1148     if (PL_op->op_flags & OPf_REF) {
1149                 SETs(sv);
1150                 RETURN;
1151     }
1152     else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
1153               const I32 flags = is_lvalue_sub();
1154               if (flags && !(flags & OPpENTERSUB_INARGS)) {
1155                 if (gimme != G_ARRAY)
1156                     goto croak_cant_return;
1157                 SETs(sv);
1158                 RETURN;
1159               }
1160     }
1161
1162     if (is_pp_rv2av) {
1163         AV *const av = MUTABLE_AV(sv);
1164
1165         if (gimme == G_ARRAY) {
1166             SP--;
1167             PUTBACK;
1168             return S_pushav(aTHX_ av);
1169         }
1170
1171         if (gimme == G_SCALAR) {
1172             const SSize_t maxarg = AvFILL(av) + 1;
1173             if (PL_op->op_private & OPpTRUEBOOL)
1174                 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
1175             else {
1176                 dTARGET;
1177                 SETi(maxarg);
1178             }
1179         }
1180     }
1181     else {
1182         SP--; PUTBACK;
1183         return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
1184                         cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
1185                         1 /* has_targ*/);
1186     }
1187     RETURN;
1188
1189  croak_cant_return:
1190     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
1191                is_pp_rv2av ? "array" : "hash");
1192     RETURN;
1193 }
1194
1195 STATIC void
1196 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
1197 {
1198     PERL_ARGS_ASSERT_DO_ODDBALL;
1199
1200     if (*oddkey) {
1201         if (ckWARN(WARN_MISC)) {
1202             const char *err;
1203             if (oddkey == firstkey &&
1204                 SvROK(*oddkey) &&
1205                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
1206                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
1207             {
1208                 err = "Reference found where even-sized list expected";
1209             }
1210             else
1211                 err = "Odd number of elements in hash assignment";
1212             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1213         }
1214
1215     }
1216 }
1217
1218
1219 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
1220  * are common to both the LHS and RHS of an aassign, and replace them
1221  * with copies. All these copies are made before the actual list assign is
1222  * done.
1223  *
1224  * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
1225  * element ($b) to the first LH element ($a), modifies $a; when the
1226  * second assignment is done, the second RH element now has the wrong
1227  * value. So we initially replace the RHS with ($b, mortalcopy($a)).
1228  * Note that we don't need to make a mortal copy of $b.
1229  *
1230  * The algorithm below works by, for every RHS element, mark the
1231  * corresponding LHS target element with SVf_BREAK. Then if the RHS
1232  * element is found with SVf_BREAK set, it means it would have been
1233  * modified, so make a copy.
1234  * Note that by scanning both LHS and RHS in lockstep, we avoid
1235  * unnecessary copies (like $b above) compared with a naive
1236  * "mark all LHS; copy all marked RHS; unmark all LHS".
1237  *
1238  * If the LHS element is a 'my' declaration' and has a refcount of 1, then
1239  * it can't be common and can be skipped.
1240  *
1241  * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
1242  * that we thought we didn't need to call S_aassign_copy_common(), but we
1243  * have anyway for sanity checking. If we find we need to copy, then panic.
1244  */
1245
1246 PERL_STATIC_INLINE void
1247 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
1248         SV **firstrelem, SV **lastrelem
1249 #ifdef DEBUGGING
1250         , bool fake
1251 #endif
1252 )
1253 {
1254     dVAR;
1255     SV **relem;
1256     SV **lelem;
1257     SSize_t lcount = lastlelem - firstlelem + 1;
1258     bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
1259     bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
1260     bool copy_all = FALSE;
1261
1262     assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
1263     assert(firstlelem < lastlelem); /* at least 2 LH elements */
1264     assert(firstrelem < lastrelem); /* at least 2 RH elements */
1265
1266
1267     lelem = firstlelem;
1268     /* we never have to copy the first RH element; it can't be corrupted
1269      * by assigning something to the corresponding first LH element.
1270      * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
1271      */
1272     relem = firstrelem + 1;
1273
1274     for (; relem <= lastrelem; relem++) {
1275         SV *svr;
1276
1277         /* mark next LH element */
1278
1279         if (--lcount >= 0) {
1280             SV *svl = *lelem++;
1281
1282             if (UNLIKELY(!svl)) {/* skip AV alias marker */
1283                 assert (lelem <= lastlelem);
1284                 svl = *lelem++;
1285                 lcount--;
1286             }
1287
1288             assert(svl);
1289             if (SvSMAGICAL(svl)) {
1290                 copy_all = TRUE;
1291             }
1292             if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
1293                 if (!marked)
1294                     return;
1295                 /* this LH element will consume all further args;
1296                  * no need to mark any further LH elements (if any).
1297                  * But we still need to scan any remaining RHS elements;
1298                  * set lcount negative to distinguish from  lcount == 0,
1299                  * so the loop condition continues being true
1300                  */
1301                 lcount = -1;
1302                 lelem--; /* no need to unmark this element */
1303             }
1304             else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
1305                 SvFLAGS(svl) |= SVf_BREAK;
1306                 marked = TRUE;
1307             }
1308             else if (!marked) {
1309                 /* don't check RH element if no SVf_BREAK flags set yet */
1310                 if (!lcount)
1311                     break;
1312                 continue;
1313             }
1314         }
1315
1316         /* see if corresponding RH element needs copying */
1317
1318         assert(marked);
1319         svr = *relem;
1320         assert(svr);
1321
1322         if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
1323             U32 brk = (SvFLAGS(svr) & SVf_BREAK);
1324
1325 #ifdef DEBUGGING
1326             if (fake) {
1327                 /* op_dump(PL_op); */
1328                 Perl_croak(aTHX_
1329                     "panic: aassign skipped needed copy of common RH elem %"
1330                         UVuf, (UV)(relem - firstrelem));
1331             }
1332 #endif
1333
1334             TAINT_NOT;  /* Each item is independent */
1335
1336             /* Dear TODO test in t/op/sort.t, I love you.
1337                (It's relying on a panic, not a "semi-panic" from newSVsv()
1338                and then an assertion failure below.)  */
1339             if (UNLIKELY(SvIS_FREED(svr))) {
1340                 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1341                            (void*)svr);
1342             }
1343             /* avoid break flag while copying; otherwise COW etc
1344              * disabled... */
1345             SvFLAGS(svr) &= ~SVf_BREAK;
1346             /* Not newSVsv(), as it does not allow copy-on-write,
1347                resulting in wasteful copies.
1348                Also, we use SV_NOSTEAL in case the SV is used more than
1349                once, e.g.  (...) = (f())[0,0]
1350                Where the same SV appears twice on the RHS without a ref
1351                count bump.  (Although I suspect that the SV won't be
1352                stealable here anyway - DAPM).
1353                */
1354             *relem = sv_mortalcopy_flags(svr,
1355                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1356             /* ... but restore afterwards in case it's needed again,
1357              * e.g. ($a,$b,$c) = (1,$a,$a)
1358              */
1359             SvFLAGS(svr) |= brk;
1360         }
1361
1362         if (!lcount)
1363             break;
1364     }
1365
1366     if (!marked)
1367         return;
1368
1369     /*unmark LHS */
1370
1371     while (lelem > firstlelem) {
1372         SV * const svl = *(--lelem);
1373         if (svl)
1374             SvFLAGS(svl) &= ~SVf_BREAK;
1375     }
1376 }
1377
1378
1379
1380 PP(pp_aassign)
1381 {
1382     dVAR; dSP;
1383     SV **lastlelem = PL_stack_sp;
1384     SV **lastrelem = PL_stack_base + POPMARK;
1385     SV **firstrelem = PL_stack_base + POPMARK + 1;
1386     SV **firstlelem = lastrelem + 1;
1387
1388     SV **relem;
1389     SV **lelem;
1390     U8 gimme;
1391     /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
1392      * only need to save locally, not on the save stack */
1393     U16 old_delaymagic = PL_delaymagic;
1394 #ifdef DEBUGGING
1395     bool fake = 0;
1396 #endif
1397
1398     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1399
1400     /* If there's a common identifier on both sides we have to take
1401      * special care that assigning the identifier on the left doesn't
1402      * clobber a value on the right that's used later in the list.
1403      */
1404
1405     /* at least 2 LH and RH elements, or commonality isn't an issue */
1406     if (firstlelem < lastlelem && firstrelem < lastrelem) {
1407         for (relem = firstrelem+1; relem <= lastrelem; relem++) {
1408             if (SvGMAGICAL(*relem))
1409                 goto do_scan;
1410         }
1411         for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1412             if (*lelem && SvSMAGICAL(*lelem))
1413                 goto do_scan;
1414         }
1415         if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
1416             if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1417                 /* skip the scan if all scalars have a ref count of 1 */
1418                 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1419                     SV *sv = *lelem;
1420                     if (!sv || SvREFCNT(sv) == 1)
1421                         continue;
1422                     if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1423                         goto do_scan;
1424                     break;
1425                 }
1426             }
1427             else {
1428             do_scan:
1429                 S_aassign_copy_common(aTHX_
1430                                       firstlelem, lastlelem, firstrelem, lastrelem
1431 #ifdef DEBUGGING
1432                     , fake
1433 #endif
1434                 );
1435             }
1436         }
1437     }
1438 #ifdef DEBUGGING
1439     else {
1440         /* on debugging builds, do the scan even if we've concluded we
1441          * don't need to, then panic if we find commonality. Note that the
1442          * scanner assumes at least 2 elements */
1443         if (firstlelem < lastlelem && firstrelem < lastrelem) {
1444             fake = 1;
1445             goto do_scan;
1446         }
1447     }
1448 #endif
1449
1450     gimme = GIMME_V;
1451     relem = firstrelem;
1452     lelem = firstlelem;
1453
1454     if (relem > lastrelem)
1455         goto no_relems;
1456
1457     /* first lelem loop while there are still relems */
1458     while (LIKELY(lelem <= lastlelem)) {
1459         bool alias = FALSE;
1460         SV *lsv = *lelem++;
1461
1462         TAINT_NOT; /* Each item stands on its own, taintwise. */
1463
1464         assert(relem <= lastrelem);
1465         if (UNLIKELY(!lsv)) {
1466             alias = TRUE;
1467             lsv = *lelem++;
1468             ASSUME(SvTYPE(lsv) == SVt_PVAV);
1469         }
1470
1471         switch (SvTYPE(lsv)) {
1472         case SVt_PVAV: {
1473             SV **svp;
1474             SSize_t i;
1475             SSize_t tmps_base;
1476             SSize_t nelems = lastrelem - relem + 1;
1477             AV *ary = MUTABLE_AV(lsv);
1478
1479             /* Assigning to an aggregate is tricky. First there is the
1480              * issue of commonality, e.g. @a = ($a[0]). Since the
1481              * stack isn't refcounted, clearing @a prior to storing
1482              * elements will free $a[0]. Similarly with
1483              *    sub FETCH { $status[$_[1]] } @status = @tied[0,1];
1484              *
1485              * The way to avoid these issues is to make the copy of each
1486              * SV (and we normally store a *copy* in the array) *before*
1487              * clearing the array. But this has a problem in that
1488              * if the code croaks during copying, the not-yet-stored copies
1489              * could leak. One way to avoid this is to make all the copies
1490              * mortal, but that's quite expensive.
1491              *
1492              * The current solution to these issues is to use a chunk
1493              * of the tmps stack as a temporary refcounted-stack. SVs
1494              * will be put on there during processing to avoid leaks,
1495              * but will be removed again before the end of this block,
1496              * so free_tmps() is never normally called. Also, the
1497              * sv_refcnt of the SVs doesn't have to be manipulated, since
1498              * the ownership of 1 reference count is transferred directly
1499              * from the tmps stack to the AV when the SV is stored.
1500              *
1501              * We disarm slots in the temps stack by storing PL_sv_undef
1502              * there: it doesn't matter if that SV's refcount is
1503              * repeatedly decremented during a croak. But usually this is
1504              * only an interim measure. By the end of this code block
1505              * we try where possible to not leave any PL_sv_undef's on the
1506              * tmps stack e.g. by shuffling newer entries down.
1507              *
1508              * There is one case where we don't copy: non-magical
1509              * SvTEMP(sv)'s with a ref count of 1. The only owner of these
1510              * is on the tmps stack, so its safe to directly steal the SV
1511              * rather than copying. This is common in things like function
1512              * returns, map etc, which all return a list of such SVs.
1513              *
1514              * Note however something like @a = (f())[0,0], where there is
1515              * a danger of the same SV being shared:  this avoided because
1516              * when the SV is stored as $a[0], its ref count gets bumped,
1517              * so the RC==1 test fails and the second element is copied
1518              * instead.
1519              *
1520              * We also use one slot in the tmps stack to hold an extra
1521              * ref to the array, to ensure it doesn't get prematurely
1522              * freed. Again, this is removed before the end of this block.
1523              *
1524              * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
1525              * @a = ($a[0]) case, but the current implementation uses the
1526              * same algorithm regardless, so ignores that flag. (It *is*
1527              * used in the hash branch below, however).
1528             */
1529
1530             /* Reserve slots for ary, plus the elems we're about to copy,
1531              * then protect ary and temporarily void the remaining slots
1532              * with &PL_sv_undef */
1533             EXTEND_MORTAL(nelems + 1);
1534             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
1535             tmps_base = PL_tmps_ix + 1;
1536             for (i = 0; i < nelems; i++)
1537                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1538             PL_tmps_ix += nelems;
1539
1540             /* Make a copy of each RHS elem and save on the tmps_stack
1541              * (or pass through where we can optimise away the copy) */
1542
1543             if (UNLIKELY(alias)) {
1544                 U32 lval = (gimme == G_ARRAY)
1545                                 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1546                 for (svp = relem; svp <= lastrelem; svp++) {
1547                     SV *rsv = *svp;
1548
1549                     SvGETMAGIC(rsv);
1550                     if (!SvROK(rsv))
1551                         DIE(aTHX_ "Assigned value is not a reference");
1552                     if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
1553                    /* diag_listed_as: Assigned value is not %s reference */
1554                         DIE(aTHX_
1555                            "Assigned value is not a SCALAR reference");
1556                     if (lval)
1557                         *svp = rsv = sv_mortalcopy(rsv);
1558                     /* XXX else check for weak refs?  */
1559                     rsv = SvREFCNT_inc_NN(SvRV(rsv));
1560                     assert(tmps_base <= PL_tmps_max);
1561                     PL_tmps_stack[tmps_base++] = rsv;
1562                 }
1563             }
1564             else {
1565                 for (svp = relem; svp <= lastrelem; svp++) {
1566                     SV *rsv = *svp;
1567
1568                     if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1569                         /* can skip the copy */
1570                         SvREFCNT_inc_simple_void_NN(rsv);
1571                         SvTEMP_off(rsv);
1572                     }
1573                     else {
1574                         SV *nsv;
1575                         /* do get before newSV, in case it dies and leaks */
1576                         SvGETMAGIC(rsv);
1577                         nsv = newSV(0);
1578                         /* see comment in S_aassign_copy_common about
1579                          * SV_NOSTEAL */
1580                         sv_setsv_flags(nsv, rsv,
1581                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1582                         rsv = *svp = nsv;
1583                     }
1584
1585                     assert(tmps_base <= PL_tmps_max);
1586                     PL_tmps_stack[tmps_base++] = rsv;
1587                 }
1588             }
1589
1590             if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
1591                 av_clear(ary);
1592
1593             /* store in the array, the SVs that are in the tmps stack */
1594
1595             tmps_base -= nelems;
1596
1597             if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
1598                 /* for arrays we can't cheat with, use the official API */
1599                 av_extend(ary, nelems - 1);
1600                 for (i = 0; i < nelems; i++) {
1601                     SV **svp = &(PL_tmps_stack[tmps_base + i]);
1602                     SV *rsv = *svp;
1603                     /* A tied store won't take ownership of rsv, so keep
1604                      * the 1 refcnt on the tmps stack; otherwise disarm
1605                      * the tmps stack entry */
1606                     if (av_store(ary, i, rsv))
1607                         *svp = &PL_sv_undef;
1608                     /* av_store() may have added set magic to rsv */;
1609                     SvSETMAGIC(rsv);
1610                 }
1611                 /* disarm ary refcount: see comments below about leak */
1612                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1613             }
1614             else {
1615                 /* directly access/set the guts of the AV */
1616                 SSize_t fill = nelems - 1;
1617                 if (fill > AvMAX(ary))
1618                     av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
1619                                     &AvARRAY(ary));
1620                 AvFILLp(ary) = fill;
1621                 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
1622                 /* Quietly remove all the SVs from the tmps stack slots,
1623                  * since ary has now taken ownership of the refcnt.
1624                  * Also remove ary: which will now leak if we die before
1625                  * the SvREFCNT_dec_NN(ary) below */
1626                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1627                     Move(&PL_tmps_stack[tmps_base + nelems],
1628                          &PL_tmps_stack[tmps_base - 1],
1629                          PL_tmps_ix - (tmps_base + nelems) + 1,
1630                          SV*);
1631                 PL_tmps_ix -= (nelems + 1);
1632             }
1633
1634             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1635                 /* its assumed @ISA set magic can't die and leak ary */
1636                 SvSETMAGIC(MUTABLE_SV(ary));
1637             SvREFCNT_dec_NN(ary);
1638
1639             relem = lastrelem + 1;
1640             goto no_relems;
1641         }
1642
1643         case SVt_PVHV: {                                /* normal hash */
1644
1645             SV **svp;
1646             bool dirty_tmps;
1647             SSize_t i;
1648             SSize_t tmps_base;
1649             SSize_t nelems = lastrelem - relem + 1;
1650             HV *hash = MUTABLE_HV(lsv);
1651
1652             if (UNLIKELY(nelems & 1)) {
1653                 do_oddball(lastrelem, relem);
1654                 /* we have firstlelem to reuse, it's not needed any more */
1655                 *++lastrelem = &PL_sv_undef;
1656                 nelems++;
1657             }
1658
1659             /* See the SVt_PVAV branch above for a long description of
1660              * how the following all works. The main difference for hashes
1661              * is that we treat keys and values separately (and have
1662              * separate loops for them): as for arrays, values are always
1663              * copied (except for the SvTEMP optimisation), since they
1664              * need to be stored in the hash; while keys are only
1665              * processed where they might get prematurely freed or
1666              * whatever. */
1667
1668             /* tmps stack slots:
1669              * * reserve a slot for the hash keepalive;
1670              * * reserve slots for the hash values we're about to copy;
1671              * * preallocate for the keys we'll possibly copy or refcount bump
1672              *   later;
1673              * then protect hash and temporarily void the remaining
1674              * value slots with &PL_sv_undef */
1675             EXTEND_MORTAL(nelems + 1);
1676
1677              /* convert to number of key/value pairs */
1678              nelems >>= 1;
1679
1680             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
1681             tmps_base = PL_tmps_ix + 1;
1682             for (i = 0; i < nelems; i++)
1683                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1684             PL_tmps_ix += nelems;
1685
1686             /* Make a copy of each RHS hash value and save on the tmps_stack
1687              * (or pass through where we can optimise away the copy) */
1688
1689             for (svp = relem + 1; svp <= lastrelem; svp += 2) {
1690                 SV *rsv = *svp;
1691
1692                 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1693                     /* can skip the copy */
1694                     SvREFCNT_inc_simple_void_NN(rsv);
1695                     SvTEMP_off(rsv);
1696                 }
1697                 else {
1698                     SV *nsv;
1699                     /* do get before newSV, in case it dies and leaks */
1700                     SvGETMAGIC(rsv);
1701                     nsv = newSV(0);
1702                     /* see comment in S_aassign_copy_common about
1703                      * SV_NOSTEAL */
1704                     sv_setsv_flags(nsv, rsv,
1705                             (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1706                     rsv = *svp = nsv;
1707                 }
1708
1709                 assert(tmps_base <= PL_tmps_max);
1710                 PL_tmps_stack[tmps_base++] = rsv;
1711             }
1712             tmps_base -= nelems;
1713
1714
1715             /* possibly protect keys */
1716
1717             if (UNLIKELY(gimme == G_ARRAY)) {
1718                 /* handle e.g.
1719                 *     @a = ((%h = ($$r, 1)), $r = "x");
1720                 *     $_++ for %h = (1,2,3,4);
1721                 */
1722                 EXTEND_MORTAL(nelems);
1723                 for (svp = relem; svp <= lastrelem; svp += 2)
1724                     *svp = sv_mortalcopy_flags(*svp,
1725                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1726             }
1727             else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
1728                 /* for possible commonality, e.g.
1729                  *       %h = ($h{a},1)
1730                  * avoid premature freeing RHS keys by mortalising
1731                  * them.
1732                  * For a magic element, make a copy so that its magic is
1733                  * called *before* the hash is emptied (which may affect
1734                  * a tied value for example).
1735                  * In theory we should check for magic keys in all
1736                  * cases, not just under OPpASSIGN_COMMON_AGG, but in
1737                  * practice, !OPpASSIGN_COMMON_AGG implies only
1738                  * constants or padtmps on the RHS.
1739                  */
1740                 EXTEND_MORTAL(nelems);
1741                 for (svp = relem; svp <= lastrelem; svp += 2) {
1742                     SV *rsv = *svp;
1743                     if (UNLIKELY(SvGMAGICAL(rsv))) {
1744                         SSize_t n;
1745                         *svp = sv_mortalcopy_flags(*svp,
1746                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1747                         /* allow other branch to continue pushing
1748                          * onto tmps stack without checking each time */
1749                         n = (lastrelem - relem) >> 1;
1750                         EXTEND_MORTAL(n);
1751                     }
1752                     else
1753                         PL_tmps_stack[++PL_tmps_ix] =
1754                                     SvREFCNT_inc_simple_NN(rsv);
1755                 }
1756             }
1757
1758             if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
1759                 hv_clear(hash);
1760
1761             /* now assign the keys and values to the hash */
1762
1763             dirty_tmps = FALSE;
1764
1765             if (UNLIKELY(gimme == G_ARRAY)) {
1766                 /* @a = (%h = (...)) etc */
1767                 SV **svp;
1768                 SV **topelem = relem;
1769
1770                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1771                     SV *key = *svp++;
1772                     SV *val = *svp;
1773                     /* remove duplicates from list we return */
1774                     if (!hv_exists_ent(hash, key, 0)) {
1775                         /* copy key back: possibly to an earlier
1776                          * stack location if we encountered dups earlier,
1777                          * The values will be updated later
1778                          */
1779                         *topelem = key;
1780                         topelem += 2;
1781                     }
1782                     /* A tied store won't take ownership of val, so keep
1783                      * the 1 refcnt on the tmps stack; otherwise disarm
1784                      * the tmps stack entry */
1785                     if (hv_store_ent(hash, key, val, 0))
1786                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1787                     else
1788                         dirty_tmps = TRUE;
1789                     /* hv_store_ent() may have added set magic to val */;
1790                     SvSETMAGIC(val);
1791                 }
1792                 if (topelem < svp) {
1793                     /* at this point we have removed the duplicate key/value
1794                      * pairs from the stack, but the remaining values may be
1795                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1796                      * the (a 2), but the stack now probably contains
1797                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1798                      * obliterates the earlier key. So refresh all values. */
1799                     lastrelem = topelem - 1;
1800                     while (relem < lastrelem) {
1801                         HE *he;
1802                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1803                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1804                     }
1805                 }
1806             }
1807             else {
1808                 SV **svp;
1809                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1810                     SV *key = *svp++;
1811                     SV *val = *svp;
1812                     if (hv_store_ent(hash, key, val, 0))
1813                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1814                     else
1815                         dirty_tmps = TRUE;
1816                     /* hv_store_ent() may have added set magic to val */;
1817                     SvSETMAGIC(val);
1818                 }
1819             }
1820
1821             if (dirty_tmps) {
1822                 /* there are still some 'live' recounts on the tmps stack
1823                  * - usually caused by storing into a tied hash. So let
1824                  * free_tmps() do the proper but slow job later.
1825                  * Just disarm hash refcount: see comments below about leak
1826                  */
1827                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1828             }
1829             else {
1830                 /* Quietly remove all the SVs from the tmps stack slots,
1831                  * since hash has now taken ownership of the refcnt.
1832                  * Also remove hash: which will now leak if we die before
1833                  * the SvREFCNT_dec_NN(hash) below */
1834                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1835                     Move(&PL_tmps_stack[tmps_base + nelems],
1836                          &PL_tmps_stack[tmps_base - 1],
1837                          PL_tmps_ix - (tmps_base + nelems) + 1,
1838                          SV*);
1839                 PL_tmps_ix -= (nelems + 1);
1840             }
1841
1842             SvREFCNT_dec_NN(hash);
1843
1844             relem = lastrelem + 1;
1845             goto no_relems;
1846         }
1847
1848         default:
1849             if (!SvIMMORTAL(lsv)) {
1850                 SV *ref;
1851
1852                 if (UNLIKELY(
1853                   SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
1854                   (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
1855                 ))
1856                     Perl_warner(aTHX_
1857                        packWARN(WARN_MISC),
1858                       "Useless assignment to a temporary"
1859                     );
1860
1861                 /* avoid freeing $$lsv if it might be needed for further
1862                  * elements, e.g. ($ref, $foo) = (1, $$ref) */
1863                 if (   SvROK(lsv)
1864                     && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
1865                     && lelem <= lastlelem
1866                 ) {
1867                     SSize_t ix;
1868                     SvREFCNT_inc_simple_void_NN(ref);
1869                     /* an unrolled sv_2mortal */
1870                     ix = ++PL_tmps_ix;
1871                     if (UNLIKELY(ix >= PL_tmps_max))
1872                         /* speculatively grow enough to cover other
1873                          * possible refs */
1874                          (void)tmps_grow_p(ix + (lastlelem - lelem));
1875                     PL_tmps_stack[ix] = ref;
1876                 }
1877
1878                 sv_setsv(lsv, *relem);
1879                 *relem = lsv;
1880                 SvSETMAGIC(lsv);
1881             }
1882             if (++relem > lastrelem)
1883                 goto no_relems;
1884             break;
1885         } /* switch */
1886     } /* while */
1887
1888
1889   no_relems:
1890
1891     /* simplified lelem loop for when there are no relems left */
1892     while (LIKELY(lelem <= lastlelem)) {
1893         SV *lsv = *lelem++;
1894
1895         TAINT_NOT; /* Each item stands on its own, taintwise. */
1896
1897         if (UNLIKELY(!lsv)) {
1898             lsv = *lelem++;
1899             ASSUME(SvTYPE(lsv) == SVt_PVAV);
1900         }
1901
1902         switch (SvTYPE(lsv)) {
1903         case SVt_PVAV:
1904             if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
1905                 av_clear((AV*)lsv);
1906                 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1907                     SvSETMAGIC(lsv);
1908             }
1909             break;
1910
1911         case SVt_PVHV:
1912             if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
1913                 hv_clear((HV*)lsv);
1914             break;
1915
1916         default:
1917             if (!SvIMMORTAL(lsv)) {
1918                 sv_set_undef(lsv);
1919                 SvSETMAGIC(lsv);
1920                 *relem++ = lsv;
1921             }
1922             break;
1923         } /* switch */
1924     } /* while */
1925
1926     TAINT_NOT; /* result of list assign isn't tainted */
1927
1928     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1929         /* Will be used to set PL_tainting below */
1930         Uid_t tmp_uid  = PerlProc_getuid();
1931         Uid_t tmp_euid = PerlProc_geteuid();
1932         Gid_t tmp_gid  = PerlProc_getgid();
1933         Gid_t tmp_egid = PerlProc_getegid();
1934
1935         /* XXX $> et al currently silently ignore failures */
1936         if (PL_delaymagic & DM_UID) {
1937 #ifdef HAS_SETRESUID
1938             PERL_UNUSED_RESULT(
1939                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1940                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1941                          (Uid_t)-1));
1942 #else
1943 #  ifdef HAS_SETREUID
1944             PERL_UNUSED_RESULT(
1945                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1946                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1947 #  else
1948 #    ifdef HAS_SETRUID
1949             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1950                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1951                 PL_delaymagic &= ~DM_RUID;
1952             }
1953 #    endif /* HAS_SETRUID */
1954 #    ifdef HAS_SETEUID
1955             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1956                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1957                 PL_delaymagic &= ~DM_EUID;
1958             }
1959 #    endif /* HAS_SETEUID */
1960             if (PL_delaymagic & DM_UID) {
1961                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1962                     DIE(aTHX_ "No setreuid available");
1963                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1964             }
1965 #  endif /* HAS_SETREUID */
1966 #endif /* HAS_SETRESUID */
1967
1968             tmp_uid  = PerlProc_getuid();
1969             tmp_euid = PerlProc_geteuid();
1970         }
1971         /* XXX $> et al currently silently ignore failures */
1972         if (PL_delaymagic & DM_GID) {
1973 #ifdef HAS_SETRESGID
1974             PERL_UNUSED_RESULT(
1975                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1976                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1977                           (Gid_t)-1));
1978 #else
1979 #  ifdef HAS_SETREGID
1980             PERL_UNUSED_RESULT(
1981                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1982                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1983 #  else
1984 #    ifdef HAS_SETRGID
1985             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1986                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1987                 PL_delaymagic &= ~DM_RGID;
1988             }
1989 #    endif /* HAS_SETRGID */
1990 #    ifdef HAS_SETEGID
1991             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1992                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1993                 PL_delaymagic &= ~DM_EGID;
1994             }
1995 #    endif /* HAS_SETEGID */
1996             if (PL_delaymagic & DM_GID) {
1997                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1998                     DIE(aTHX_ "No setregid available");
1999                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
2000             }
2001 #  endif /* HAS_SETREGID */
2002 #endif /* HAS_SETRESGID */
2003
2004             tmp_gid  = PerlProc_getgid();
2005             tmp_egid = PerlProc_getegid();
2006         }
2007         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
2008 #ifdef NO_TAINT_SUPPORT
2009         PERL_UNUSED_VAR(tmp_uid);
2010         PERL_UNUSED_VAR(tmp_euid);
2011         PERL_UNUSED_VAR(tmp_gid);
2012         PERL_UNUSED_VAR(tmp_egid);
2013 #endif
2014     }
2015     PL_delaymagic = old_delaymagic;
2016
2017     if (gimme == G_VOID)
2018         SP = firstrelem - 1;
2019     else if (gimme == G_SCALAR) {
2020         SP = firstrelem;
2021         EXTEND(SP,1);
2022         if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2023             SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2024         else {
2025             dTARGET;
2026             SETi(firstlelem - firstrelem);
2027         }
2028     }
2029     else
2030         SP = relem - 1;
2031
2032     RETURN;
2033 }
2034
2035 PP(pp_qr)
2036 {
2037     dSP;
2038     PMOP * const pm = cPMOP;
2039     REGEXP * rx = PM_GETRE(pm);
2040     regexp *prog = ReANY(rx);
2041     SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
2042     SV * const rv = sv_newmortal();
2043     CV **cvp;
2044     CV *cv;
2045
2046     SvUPGRADE(rv, SVt_IV);
2047     /* For a subroutine describing itself as "This is a hacky workaround" I'm
2048        loathe to use it here, but it seems to be the right fix. Or close.
2049        The key part appears to be that it's essential for pp_qr to return a new
2050        object (SV), which implies that there needs to be an effective way to
2051        generate a new SV from the existing SV that is pre-compiled in the
2052        optree.  */
2053     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
2054     SvROK_on(rv);
2055
2056     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
2057     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
2058         *cvp = cv_clone(cv);
2059         SvREFCNT_dec_NN(cv);
2060     }
2061
2062     if (pkg) {
2063         HV *const stash = gv_stashsv(pkg, GV_ADD);
2064         SvREFCNT_dec_NN(pkg);
2065         (void)sv_bless(rv, stash);
2066     }
2067
2068     if (UNLIKELY(RXp_ISTAINTED(prog))) {
2069         SvTAINTED_on(rv);
2070         SvTAINTED_on(SvRV(rv));
2071     }
2072     XPUSHs(rv);
2073     RETURN;
2074 }
2075
2076 PP(pp_match)
2077 {
2078     dSP; dTARG;
2079     PMOP *pm = cPMOP;
2080     PMOP *dynpm = pm;
2081     const char *s;
2082     const char *strend;
2083     SSize_t curpos = 0; /* initial pos() or current $+[0] */
2084     I32 global;
2085     U8 r_flags = 0;
2086     const char *truebase;                       /* Start of string  */
2087     REGEXP *rx = PM_GETRE(pm);
2088     regexp *prog = ReANY(rx);
2089     bool rxtainted;
2090     const U8 gimme = GIMME_V;
2091     STRLEN len;
2092     const I32 oldsave = PL_savestack_ix;
2093     I32 had_zerolen = 0;
2094     MAGIC *mg = NULL;
2095
2096     if (PL_op->op_flags & OPf_STACKED)
2097         TARG = POPs;
2098     else {
2099         if (ARGTARG)
2100             GETTARGET;
2101         else {
2102             TARG = DEFSV;
2103         }
2104         EXTEND(SP,1);
2105     }
2106
2107     PUTBACK;                            /* EVAL blocks need stack_sp. */
2108     /* Skip get-magic if this is a qr// clone, because regcomp has
2109        already done it. */
2110     truebase = prog->mother_re
2111          ? SvPV_nomg_const(TARG, len)
2112          : SvPV_const(TARG, len);
2113     if (!truebase)
2114         DIE(aTHX_ "panic: pp_match");
2115     strend = truebase + len;
2116     rxtainted = (RXp_ISTAINTED(prog) ||
2117                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
2118     TAINT_NOT;
2119
2120     /* We need to know this in case we fail out early - pos() must be reset */
2121     global = dynpm->op_pmflags & PMf_GLOBAL;
2122
2123     /* PMdf_USED is set after a ?? matches once */
2124     if (
2125 #ifdef USE_ITHREADS
2126         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2127 #else
2128         pm->op_pmflags & PMf_USED
2129 #endif
2130     ) {
2131         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
2132         goto nope;
2133     }
2134
2135     /* handle the empty pattern */
2136     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
2137         if (PL_curpm == PL_reg_curpm) {
2138             if (PL_curpm_under) {
2139                 if (PL_curpm_under == PL_reg_curpm) {
2140                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2141                 } else {
2142                     pm = PL_curpm_under;
2143                 }
2144             }
2145         } else {
2146             pm = PL_curpm;
2147         }
2148         rx = PM_GETRE(pm);
2149         prog = ReANY(rx);
2150     }
2151
2152     if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
2153         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
2154                                               UVuf " < %" IVdf ")\n",
2155                                               (UV)len, (IV)RXp_MINLEN(prog)));
2156         goto nope;
2157     }
2158
2159     /* get pos() if //g */
2160     if (global) {
2161         mg = mg_find_mglob(TARG);
2162         if (mg && mg->mg_len >= 0) {
2163             curpos = MgBYTEPOS(mg, TARG, truebase, len);
2164             /* last time pos() was set, it was zero-length match */
2165             if (mg->mg_flags & MGf_MINMATCH)
2166                 had_zerolen = 1;
2167         }
2168     }
2169
2170 #ifdef PERL_SAWAMPERSAND
2171     if (       RXp_NPARENS(prog)
2172             || PL_sawampersand
2173             || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2174             || (dynpm->op_pmflags & PMf_KEEPCOPY)
2175     )
2176 #endif
2177     {
2178         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
2179         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
2180          * only on the first iteration. Therefore we need to copy $' as well
2181          * as $&, to make the rest of the string available for captures in
2182          * subsequent iterations */
2183         if (! (global && gimme == G_ARRAY))
2184             r_flags |= REXEC_COPY_SKIP_POST;
2185     };
2186 #ifdef PERL_SAWAMPERSAND
2187     if (dynpm->op_pmflags & PMf_KEEPCOPY)
2188         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
2189         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
2190 #endif
2191
2192     s = truebase;
2193
2194   play_it_again:
2195     if (global)
2196         s = truebase + curpos;
2197
2198     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
2199                      had_zerolen, TARG, NULL, r_flags))
2200         goto nope;
2201
2202     PL_curpm = pm;
2203     if (dynpm->op_pmflags & PMf_ONCE)
2204 #ifdef USE_ITHREADS
2205         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
2206 #else
2207         dynpm->op_pmflags |= PMf_USED;
2208 #endif
2209
2210     if (rxtainted)
2211         RXp_MATCH_TAINTED_on(prog);
2212     TAINT_IF(RXp_MATCH_TAINTED(prog));
2213
2214     /* update pos */
2215
2216     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
2217         if (!mg)
2218             mg = sv_magicext_mglob(TARG);
2219         MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
2220         if (RXp_ZERO_LEN(prog))
2221             mg->mg_flags |= MGf_MINMATCH;
2222         else
2223             mg->mg_flags &= ~MGf_MINMATCH;
2224     }
2225
2226     if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
2227         LEAVE_SCOPE(oldsave);
2228         RETPUSHYES;
2229     }
2230
2231     /* push captures on stack */
2232
2233     {
2234         const I32 nparens = RXp_NPARENS(prog);
2235         I32 i = (global && !nparens) ? 1 : 0;
2236
2237         SPAGAIN;                        /* EVAL blocks could move the stack. */
2238         EXTEND(SP, nparens + i);
2239         EXTEND_MORTAL(nparens + i);
2240         for (i = !i; i <= nparens; i++) {
2241             PUSHs(sv_newmortal());
2242             if (LIKELY((RXp_OFFS(prog)[i].start != -1)
2243                      && RXp_OFFS(prog)[i].end   != -1 ))
2244             {
2245                 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
2246                 const char * const s = RXp_OFFS(prog)[i].start + truebase;
2247                 if (UNLIKELY(  RXp_OFFS(prog)[i].end   < 0
2248                             || RXp_OFFS(prog)[i].start < 0
2249                             || len < 0
2250                             || len > strend - s)
2251                 )
2252                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
2253                         "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
2254                         (long) i, (long) RXp_OFFS(prog)[i].start,
2255                         (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
2256                 sv_setpvn(*SP, s, len);
2257                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
2258                     SvUTF8_on(*SP);
2259             }
2260         }
2261         if (global) {
2262             curpos = (UV)RXp_OFFS(prog)[0].end;
2263             had_zerolen = RXp_ZERO_LEN(prog);
2264             PUTBACK;                    /* EVAL blocks may use stack */
2265             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2266             goto play_it_again;
2267         }
2268         LEAVE_SCOPE(oldsave);
2269         RETURN;
2270     }
2271     NOT_REACHED; /* NOTREACHED */
2272
2273   nope:
2274     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
2275         if (!mg)
2276             mg = mg_find_mglob(TARG);
2277         if (mg)
2278             mg->mg_len = -1;
2279     }
2280     LEAVE_SCOPE(oldsave);
2281     if (gimme == G_ARRAY)
2282         RETURN;
2283     RETPUSHNO;
2284 }
2285
2286 OP *
2287 Perl_do_readline(pTHX)
2288 {
2289     dSP; dTARGETSTACKED;
2290     SV *sv;
2291     STRLEN tmplen = 0;
2292     STRLEN offset;
2293     PerlIO *fp;
2294     IO * const io = GvIO(PL_last_in_gv);
2295     const I32 type = PL_op->op_type;
2296     const U8 gimme = GIMME_V;
2297
2298     if (io) {
2299         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2300         if (mg) {
2301             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
2302             if (gimme == G_SCALAR) {
2303                 SPAGAIN;
2304                 SvSetSV_nosteal(TARG, TOPs);
2305                 SETTARG;
2306             }
2307             return NORMAL;
2308         }
2309     }
2310     fp = NULL;
2311     if (io) {
2312         fp = IoIFP(io);
2313         if (!fp) {
2314             if (IoFLAGS(io) & IOf_ARGV) {
2315                 if (IoFLAGS(io) & IOf_START) {
2316                     IoLINES(io) = 0;
2317                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
2318                         IoFLAGS(io) &= ~IOf_START;
2319                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
2320                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
2321                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
2322                         SvSETMAGIC(GvSV(PL_last_in_gv));
2323                         fp = IoIFP(io);
2324                         goto have_fp;
2325                     }
2326                 }
2327                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2328                 if (!fp) { /* Note: fp != IoIFP(io) */
2329                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
2330                 }
2331             }
2332             else if (type == OP_GLOB)
2333                 fp = Perl_start_glob(aTHX_ POPs, io);
2334         }
2335         else if (type == OP_GLOB)
2336             SP--;
2337         else if (IoTYPE(io) == IoTYPE_WRONLY) {
2338             report_wrongway_fh(PL_last_in_gv, '>');
2339         }
2340     }
2341     if (!fp) {
2342         if ((!io || !(IoFLAGS(io) & IOf_START))
2343             && ckWARN(WARN_CLOSED)
2344             && type != OP_GLOB)
2345         {
2346             report_evil_fh(PL_last_in_gv);
2347         }
2348         if (gimme == G_SCALAR) {
2349             /* undef TARG, and push that undefined value */
2350             if (type != OP_RCATLINE) {
2351                 sv_set_undef(TARG);
2352             }
2353             PUSHTARG;
2354         }
2355         RETURN;
2356     }
2357   have_fp:
2358     if (gimme == G_SCALAR) {
2359         sv = TARG;
2360         if (type == OP_RCATLINE && SvGMAGICAL(sv))
2361             mg_get(sv);
2362         if (SvROK(sv)) {
2363             if (type == OP_RCATLINE)
2364                 SvPV_force_nomg_nolen(sv);
2365             else
2366                 sv_unref(sv);
2367         }
2368         else if (isGV_with_GP(sv)) {
2369             SvPV_force_nomg_nolen(sv);
2370         }
2371         SvUPGRADE(sv, SVt_PV);
2372         tmplen = SvLEN(sv);     /* remember if already alloced */
2373         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
2374             /* try short-buffering it. Please update t/op/readline.t
2375              * if you change the growth length.
2376              */
2377             Sv_Grow(sv, 80);
2378         }
2379         offset = 0;
2380         if (type == OP_RCATLINE && SvOK(sv)) {
2381             if (!SvPOK(sv)) {
2382                 SvPV_force_nomg_nolen(sv);
2383             }
2384             offset = SvCUR(sv);
2385         }
2386     }
2387     else {
2388         sv = sv_2mortal(newSV(80));
2389         offset = 0;
2390     }
2391
2392     /* This should not be marked tainted if the fp is marked clean */
2393 #define MAYBE_TAINT_LINE(io, sv) \
2394     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
2395         TAINT;                          \
2396         SvTAINTED_on(sv);               \
2397     }
2398
2399 /* delay EOF state for a snarfed empty file */
2400 #define SNARF_EOF(gimme,rs,io,sv) \
2401     (gimme != G_SCALAR || SvCUR(sv)                                     \
2402      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
2403
2404     for (;;) {
2405         PUTBACK;
2406         if (!sv_gets(sv, fp, offset)
2407             && (type == OP_GLOB
2408                 || SNARF_EOF(gimme, PL_rs, io, sv)
2409                 || PerlIO_error(fp)))
2410         {
2411             PerlIO_clearerr(fp);
2412             if (IoFLAGS(io) & IOf_ARGV) {
2413                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2414                 if (fp)
2415                     continue;
2416                 (void)do_close(PL_last_in_gv, FALSE);
2417             }
2418             else if (type == OP_GLOB) {
2419                 if (!do_close(PL_last_in_gv, FALSE)) {
2420                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
2421                                    "glob failed (child exited with status %d%s)",
2422                                    (int)(STATUS_CURRENT >> 8),
2423                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
2424                 }
2425             }
2426             if (gimme == G_SCALAR) {
2427                 if (type != OP_RCATLINE) {
2428                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
2429                     SvOK_off(TARG);
2430                 }
2431                 SPAGAIN;
2432                 PUSHTARG;
2433             }
2434             MAYBE_TAINT_LINE(io, sv);
2435             RETURN;
2436         }
2437         MAYBE_TAINT_LINE(io, sv);
2438         IoLINES(io)++;
2439         IoFLAGS(io) |= IOf_NOLINE;
2440         SvSETMAGIC(sv);
2441         SPAGAIN;
2442         XPUSHs(sv);
2443         if (type == OP_GLOB) {
2444             const char *t1;
2445             Stat_t statbuf;
2446
2447             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
2448                 char * const tmps = SvEND(sv) - 1;
2449                 if (*tmps == *SvPVX_const(PL_rs)) {
2450                     *tmps = '\0';
2451                     SvCUR_set(sv, SvCUR(sv) - 1);
2452                 }
2453             }
2454             for (t1 = SvPVX_const(sv); *t1; t1++)
2455 #ifdef __VMS
2456                 if (strchr("*%?", *t1))
2457 #else
2458                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
2459 #endif
2460                         break;
2461             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
2462                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
2463                 continue;
2464             }
2465         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
2466              if (ckWARN(WARN_UTF8)) {
2467                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
2468                 const STRLEN len = SvCUR(sv) - offset;
2469                 const U8 *f;
2470
2471                 if (!is_utf8_string_loc(s, len, &f))
2472                     /* Emulate :encoding(utf8) warning in the same case. */
2473                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
2474                                 "utf8 \"\\x%02X\" does not map to Unicode",
2475                                 f < (U8*)SvEND(sv) ? *f : 0);
2476              }
2477         }
2478         if (gimme == G_ARRAY) {
2479             if (SvLEN(sv) - SvCUR(sv) > 20) {
2480                 SvPV_shrink_to_cur(sv);
2481             }
2482             sv = sv_2mortal(newSV(80));
2483             continue;
2484         }
2485         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2486             /* try to reclaim a bit of scalar space (only on 1st alloc) */
2487             const STRLEN new_len
2488                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2489             SvPV_renew(sv, new_len);
2490         }
2491         RETURN;
2492     }
2493 }
2494
2495 PP(pp_helem)
2496 {
2497     dSP;
2498     HE* he;
2499     SV **svp;
2500     SV * const keysv = POPs;
2501     HV * const hv = MUTABLE_HV(POPs);
2502     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2503     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2504     SV *sv;
2505     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2506     bool preeminent = TRUE;
2507
2508     if (SvTYPE(hv) != SVt_PVHV)
2509         RETPUSHUNDEF;
2510
2511     if (localizing) {
2512         MAGIC *mg;
2513         HV *stash;
2514
2515         /* If we can determine whether the element exist,
2516          * Try to preserve the existenceness of a tied hash
2517          * element by using EXISTS and DELETE if possible.
2518          * Fallback to FETCH and STORE otherwise. */
2519         if (SvCANEXISTDELETE(hv))
2520             preeminent = hv_exists_ent(hv, keysv, 0);
2521     }
2522
2523     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2524     svp = he ? &HeVAL(he) : NULL;
2525     if (lval) {
2526         if (!svp || !*svp || *svp == &PL_sv_undef) {
2527             SV* lv;
2528             SV* key2;
2529             if (!defer) {
2530                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2531             }
2532             lv = sv_newmortal();
2533             sv_upgrade(lv, SVt_PVLV);
2534             LvTYPE(lv) = 'y';
2535             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2536             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
2537             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2538             LvTARGLEN(lv) = 1;
2539             PUSHs(lv);
2540             RETURN;
2541         }
2542         if (localizing) {
2543             if (HvNAME_get(hv) && isGV(*svp))
2544                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2545             else if (preeminent)
2546                 save_helem_flags(hv, keysv, svp,
2547                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2548             else
2549                 SAVEHDELETE(hv, keysv);
2550         }
2551         else if (PL_op->op_private & OPpDEREF) {
2552             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2553             RETURN;
2554         }
2555     }
2556     sv = (svp && *svp ? *svp : &PL_sv_undef);
2557     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2558      * was to make C<local $tied{foo} = $tied{foo}> possible.
2559      * However, it seems no longer to be needed for that purpose, and
2560      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2561      * would loop endlessly since the pos magic is getting set on the
2562      * mortal copy and lost. However, the copy has the effect of
2563      * triggering the get magic, and losing it altogether made things like
2564      * c<$tied{foo};> in void context no longer do get magic, which some
2565      * code relied on. Also, delayed triggering of magic on @+ and friends
2566      * meant the original regex may be out of scope by now. So as a
2567      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2568      * being called too many times). */
2569     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2570         mg_get(sv);
2571     PUSHs(sv);
2572     RETURN;
2573 }
2574
2575
2576 /* a stripped-down version of Perl_softref2xv() for use by
2577  * pp_multideref(), which doesn't use PL_op->op_flags */
2578
2579 STATIC GV *
2580 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2581                 const svtype type)
2582 {
2583     if (PL_op->op_private & HINT_STRICT_REFS) {
2584         if (SvOK(sv))
2585             Perl_die(aTHX_ PL_no_symref_sv, sv,
2586                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2587         else
2588             Perl_die(aTHX_ PL_no_usym, what);
2589     }
2590     if (!SvOK(sv))
2591         Perl_die(aTHX_ PL_no_usym, what);
2592     return gv_fetchsv_nomg(sv, GV_ADD, type);
2593 }
2594
2595
2596 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2597  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
2598  *
2599  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2600  * Each of these either contains a set of actions, or an argument, such as
2601  * an IV to use as an array index, or a lexical var to retrieve.
2602  * Several actions re stored per UV; we keep shifting new actions off the
2603  * one UV, and only reload when it becomes zero.
2604  */
2605
2606 PP(pp_multideref)
2607 {
2608     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2609     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2610     UV actions = items->uv;
2611
2612     assert(actions);
2613     /* this tells find_uninit_var() where we're up to */
2614     PL_multideref_pc = items;
2615
2616     while (1) {
2617         /* there are three main classes of action; the first retrieve
2618          * the initial AV or HV from a variable or the stack; the second
2619          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2620          * the third an unrolled (/DREFHV, rv2hv, helem).
2621          */
2622         switch (actions & MDEREF_ACTION_MASK) {
2623
2624         case MDEREF_reload:
2625             actions = (++items)->uv;
2626             continue;
2627
2628         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
2629             sv = PAD_SVl((++items)->pad_offset);
2630             goto do_AV_aelem;
2631
2632         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
2633             sv = UNOP_AUX_item_sv(++items);
2634             assert(isGV_with_GP(sv));
2635             sv = (SV*)GvAVn((GV*)sv);
2636             goto do_AV_aelem;
2637
2638         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
2639             {
2640                 dSP;
2641                 sv = POPs;
2642                 PUTBACK;
2643                 goto do_AV_rv2av_aelem;
2644             }
2645
2646         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
2647             sv = UNOP_AUX_item_sv(++items);
2648             assert(isGV_with_GP(sv));
2649             sv = GvSVn((GV*)sv);
2650             goto do_AV_vivify_rv2av_aelem;
2651
2652         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
2653             sv = PAD_SVl((++items)->pad_offset);
2654             /* FALLTHROUGH */
2655
2656         do_AV_vivify_rv2av_aelem:
2657         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
2658             /* this is the OPpDEREF action normally found at the end of
2659              * ops like aelem, helem, rv2sv */
2660             sv = vivify_ref(sv, OPpDEREF_AV);
2661             /* FALLTHROUGH */
2662
2663         do_AV_rv2av_aelem:
2664             /* this is basically a copy of pp_rv2av when it just has the
2665              * sKR/1 flags */
2666             SvGETMAGIC(sv);
2667             if (LIKELY(SvROK(sv))) {
2668                 if (UNLIKELY(SvAMAGIC(sv))) {
2669                     sv = amagic_deref_call(sv, to_av_amg);
2670                 }
2671                 sv = SvRV(sv);
2672                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2673                     DIE(aTHX_ "Not an ARRAY reference");
2674             }
2675             else if (SvTYPE(sv) != SVt_PVAV) {
2676                 if (!isGV_with_GP(sv))
2677                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2678                 sv = MUTABLE_SV(GvAVn((GV*)sv));
2679             }
2680             /* FALLTHROUGH */
2681
2682         do_AV_aelem:
2683             {
2684                 /* retrieve the key; this may be either a lexical or package
2685                  * var (whose index/ptr is stored as an item) or a signed
2686                  * integer constant stored as an item.
2687                  */
2688                 SV *elemsv;
2689                 IV elem = 0; /* to shut up stupid compiler warnings */
2690
2691
2692                 assert(SvTYPE(sv) == SVt_PVAV);
2693
2694                 switch (actions & MDEREF_INDEX_MASK) {
2695                 case MDEREF_INDEX_none:
2696                     goto finish;
2697                 case MDEREF_INDEX_const:
2698                     elem  = (++items)->iv;
2699                     break;
2700                 case MDEREF_INDEX_padsv:
2701                     elemsv = PAD_SVl((++items)->pad_offset);
2702                     goto check_elem;
2703                 case MDEREF_INDEX_gvsv:
2704                     elemsv = UNOP_AUX_item_sv(++items);
2705                     assert(isGV_with_GP(elemsv));
2706                     elemsv = GvSVn((GV*)elemsv);
2707                 check_elem:
2708                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2709                                             && ckWARN(WARN_MISC)))
2710                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2711                                 "Use of reference \"%" SVf "\" as array index",
2712                                 SVfARG(elemsv));
2713                     /* the only time that S_find_uninit_var() needs this
2714                      * is to determine which index value triggered the
2715                      * undef warning. So just update it here. Note that
2716                      * since we don't save and restore this var (e.g. for
2717                      * tie or overload execution), its value will be
2718                      * meaningless apart from just here */
2719                     PL_multideref_pc = items;
2720                     elem = SvIV(elemsv);
2721                     break;
2722                 }
2723
2724
2725                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2726
2727                 if (!(actions & MDEREF_FLAG_last)) {
2728                     SV** svp = av_fetch((AV*)sv, elem, 1);
2729                     if (!svp || ! (sv=*svp))
2730                         DIE(aTHX_ PL_no_aelem, elem);
2731                     break;
2732                 }
2733
2734                 if (PL_op->op_private &
2735                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2736                 {
2737                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2738                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2739                     }
2740                     else {
2741                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2742                         sv = av_delete((AV*)sv, elem, discard);
2743                         if (discard)
2744                             return NORMAL;
2745                         if (!sv)
2746                             sv = &PL_sv_undef;
2747                     }
2748                 }
2749                 else {
2750                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2751                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2752                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2753                     bool preeminent = TRUE;
2754                     AV *const av = (AV*)sv;
2755                     SV** svp;
2756
2757                     if (UNLIKELY(localizing)) {
2758                         MAGIC *mg;
2759                         HV *stash;
2760
2761                         /* If we can determine whether the element exist,
2762                          * Try to preserve the existenceness of a tied array
2763                          * element by using EXISTS and DELETE if possible.
2764                          * Fallback to FETCH and STORE otherwise. */
2765                         if (SvCANEXISTDELETE(av))
2766                             preeminent = av_exists(av, elem);
2767                     }
2768
2769                     svp = av_fetch(av, elem, lval && !defer);
2770
2771                     if (lval) {
2772                         if (!svp || !(sv = *svp)) {
2773                             IV len;
2774                             if (!defer)
2775                                 DIE(aTHX_ PL_no_aelem, elem);
2776                             len = av_tindex(av);
2777                             sv = sv_2mortal(newSVavdefelem(av,
2778                             /* Resolve a negative index now, unless it points
2779                              * before the beginning of the array, in which
2780                              * case record it for error reporting in
2781                              * magic_setdefelem. */
2782                                 elem < 0 && len + elem >= 0
2783                                     ? len + elem : elem, 1));
2784                         }
2785                         else {
2786                             if (UNLIKELY(localizing)) {
2787                                 if (preeminent) {
2788                                     save_aelem(av, elem, svp);
2789                                     sv = *svp; /* may have changed */
2790                                 }
2791                                 else
2792                                     SAVEADELETE(av, elem);
2793                             }
2794                         }
2795                     }
2796                     else {
2797                         sv = (svp ? *svp : &PL_sv_undef);
2798                         /* see note in pp_helem() */
2799                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2800                             mg_get(sv);
2801                     }
2802                 }
2803
2804             }
2805           finish:
2806             {
2807                 dSP;
2808                 XPUSHs(sv);
2809                 RETURN;
2810             }
2811             /* NOTREACHED */
2812
2813
2814
2815
2816         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
2817             sv = PAD_SVl((++items)->pad_offset);
2818             goto do_HV_helem;
2819
2820         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
2821             sv = UNOP_AUX_item_sv(++items);
2822             assert(isGV_with_GP(sv));
2823             sv = (SV*)GvHVn((GV*)sv);
2824             goto do_HV_helem;
2825
2826         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
2827             {
2828                 dSP;
2829                 sv = POPs;
2830                 PUTBACK;
2831                 goto do_HV_rv2hv_helem;
2832             }
2833
2834         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
2835             sv = UNOP_AUX_item_sv(++items);
2836             assert(isGV_with_GP(sv));
2837             sv = GvSVn((GV*)sv);
2838             goto do_HV_vivify_rv2hv_helem;
2839
2840         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
2841             sv = PAD_SVl((++items)->pad_offset);
2842             /* FALLTHROUGH */
2843
2844         do_HV_vivify_rv2hv_helem:
2845         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
2846             /* this is the OPpDEREF action normally found at the end of
2847              * ops like aelem, helem, rv2sv */
2848             sv = vivify_ref(sv, OPpDEREF_HV);
2849             /* FALLTHROUGH */
2850
2851         do_HV_rv2hv_helem:
2852             /* this is basically a copy of pp_rv2hv when it just has the
2853              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2854
2855             SvGETMAGIC(sv);
2856             if (LIKELY(SvROK(sv))) {
2857                 if (UNLIKELY(SvAMAGIC(sv))) {
2858                     sv = amagic_deref_call(sv, to_hv_amg);
2859                 }
2860                 sv = SvRV(sv);
2861                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2862                     DIE(aTHX_ "Not a HASH reference");
2863             }
2864             else if (SvTYPE(sv) != SVt_PVHV) {
2865                 if (!isGV_with_GP(sv))
2866                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2867                 sv = MUTABLE_SV(GvHVn((GV*)sv));
2868             }
2869             /* FALLTHROUGH */
2870
2871         do_HV_helem:
2872             {
2873                 /* retrieve the key; this may be either a lexical / package
2874                  * var or a string constant, whose index/ptr is stored as an
2875                  * item
2876                  */
2877                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2878
2879                 assert(SvTYPE(sv) == SVt_PVHV);
2880
2881                 switch (actions & MDEREF_INDEX_MASK) {
2882                 case MDEREF_INDEX_none:
2883                     goto finish;
2884
2885                 case MDEREF_INDEX_const:
2886                     keysv = UNOP_AUX_item_sv(++items);
2887                     break;
2888
2889                 case MDEREF_INDEX_padsv:
2890                     keysv = PAD_SVl((++items)->pad_offset);
2891                     break;
2892
2893                 case MDEREF_INDEX_gvsv:
2894                     keysv = UNOP_AUX_item_sv(++items);
2895                     keysv = GvSVn((GV*)keysv);
2896                     break;
2897                 }
2898
2899                 /* see comment above about setting this var */
2900                 PL_multideref_pc = items;
2901
2902
2903                 /* ensure that candidate CONSTs have been HEKified */
2904                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2905                        || SvTYPE(keysv) >= SVt_PVMG
2906                        || !SvOK(keysv)
2907                        || SvROK(keysv)
2908                        || SvIsCOW_shared_hash(keysv));
2909
2910                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2911
2912                 if (!(actions & MDEREF_FLAG_last)) {
2913                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2914                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2915                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2916                     break;
2917                 }
2918
2919                 if (PL_op->op_private &
2920                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2921                 {
2922                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2923                         sv = hv_exists_ent((HV*)sv, keysv, 0)
2924                                                 ? &PL_sv_yes : &PL_sv_no;
2925                     }
2926                     else {
2927                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2928                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2929                         if (discard)
2930                             return NORMAL;
2931                         if (!sv)
2932                             sv = &PL_sv_undef;
2933                     }
2934                 }
2935                 else {
2936                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2937                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2938                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2939                     bool preeminent = TRUE;
2940                     SV **svp;
2941                     HV * const hv = (HV*)sv;
2942                     HE* he;
2943
2944                     if (UNLIKELY(localizing)) {
2945                         MAGIC *mg;
2946                         HV *stash;
2947
2948                         /* If we can determine whether the element exist,
2949                          * Try to preserve the existenceness of a tied hash
2950                          * element by using EXISTS and DELETE if possible.
2951                          * Fallback to FETCH and STORE otherwise. */
2952                         if (SvCANEXISTDELETE(hv))
2953                             preeminent = hv_exists_ent(hv, keysv, 0);
2954                     }
2955
2956                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2957                     svp = he ? &HeVAL(he) : NULL;
2958
2959
2960                     if (lval) {
2961                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2962                             SV* lv;
2963                             SV* key2;
2964                             if (!defer)
2965                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2966                             lv = sv_newmortal();
2967                             sv_upgrade(lv, SVt_PVLV);
2968                             LvTYPE(lv) = 'y';
2969                             sv_magic(lv, key2 = newSVsv(keysv),
2970                                                 PERL_MAGIC_defelem, NULL, 0);
2971                             /* sv_magic() increments refcount */
2972                             SvREFCNT_dec_NN(key2);
2973                             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2974                             LvTARGLEN(lv) = 1;
2975                             sv = lv;
2976                         }
2977                         else {
2978                             if (localizing) {
2979                                 if (HvNAME_get(hv) && isGV(sv))
2980                                     save_gp(MUTABLE_GV(sv),
2981                                         !(PL_op->op_flags & OPf_SPECIAL));
2982                                 else if (preeminent) {
2983                                     save_helem_flags(hv, keysv, svp,
2984                                          (PL_op->op_flags & OPf_SPECIAL)
2985                                             ? 0 : SAVEf_SETMAGIC);
2986                                     sv = *svp; /* may have changed */
2987                                 }
2988                                 else
2989                                     SAVEHDELETE(hv, keysv);
2990                             }
2991                         }
2992                     }
2993                     else {
2994                         sv = (svp && *svp ? *svp : &PL_sv_undef);
2995                         /* see note in pp_helem() */
2996                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2997                             mg_get(sv);
2998                     }
2999                 }
3000                 goto finish;
3001             }
3002
3003         } /* switch */
3004
3005         actions >>= MDEREF_SHIFT;
3006     } /* while */
3007     /* NOTREACHED */
3008 }
3009
3010
3011 PP(pp_iter)
3012 {
3013     PERL_CONTEXT *cx;
3014     SV *oldsv;
3015     SV **itersvp;
3016
3017     SV *sv;
3018     AV *av;
3019     IV ix;
3020     IV inc;
3021
3022     cx = CX_CUR();
3023     itersvp = CxITERVAR(cx);
3024     assert(itersvp);
3025
3026     switch (CxTYPE(cx)) {
3027
3028     case CXt_LOOP_LAZYSV: /* string increment */
3029     {
3030         SV* cur = cx->blk_loop.state_u.lazysv.cur;
3031         SV *end = cx->blk_loop.state_u.lazysv.end;
3032         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
3033            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
3034         STRLEN maxlen = 0;
3035         const char *max = SvPV_const(end, maxlen);
3036         if (DO_UTF8(end) && IN_UNI_8_BIT)
3037             maxlen = sv_len_utf8_nomg(end);
3038         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
3039             goto retno;
3040
3041         oldsv = *itersvp;
3042         /* NB: on the first iteration, oldsv will have a ref count of at
3043          * least 2 (one extra from blk_loop.itersave), so the GV or pad
3044          * slot will get localised; on subsequent iterations the RC==1
3045          * optimisation may kick in and the SV will be reused. */
3046          if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3047             /* safe to reuse old SV */
3048             sv_setsv(oldsv, cur);
3049         }
3050         else
3051         {
3052             /* we need a fresh SV every time so that loop body sees a
3053              * completely new SV for closures/references to work as
3054              * they used to */
3055             *itersvp = newSVsv(cur);
3056             SvREFCNT_dec(oldsv);
3057         }
3058         if (strEQ(SvPVX_const(cur), max))
3059             sv_setiv(cur, 0); /* terminate next time */
3060         else
3061             sv_inc(cur);
3062         break;
3063     }
3064
3065     case CXt_LOOP_LAZYIV: /* integer increment */
3066     {
3067         IV cur = cx->blk_loop.state_u.lazyiv.cur;
3068         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
3069             goto retno;
3070
3071         oldsv = *itersvp;
3072         /* see NB comment above */
3073         if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3074             /* safe to reuse old SV */
3075
3076             if (    (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
3077                  == SVt_IV)
3078             {
3079                 /* Cheap SvIOK_only().
3080                  * Assert that flags which SvIOK_only() would test or
3081                  * clear can't be set, because we're SVt_IV */
3082                 assert(!(SvFLAGS(oldsv) &
3083                     (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
3084                 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
3085                 /* SvIV_set() where sv_any points to head */
3086                 oldsv->sv_u.svu_iv = cur;
3087
3088             }
3089             else
3090                 sv_setiv(oldsv, cur);
3091         }
3092         else
3093         {
3094             /* we need a fresh SV every time so that loop body sees a
3095              * completely new SV for closures/references to work as they
3096              * used to */
3097             *itersvp = newSViv(cur);
3098             SvREFCNT_dec(oldsv);
3099         }
3100
3101         if (UNLIKELY(cur == IV_MAX)) {
3102             /* Handle end of range at IV_MAX */
3103             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
3104         } else
3105             ++cx->blk_loop.state_u.lazyiv.cur;
3106         break;
3107     }
3108
3109     case CXt_LOOP_LIST: /* for (1,2,3) */
3110
3111         assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
3112         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3113         ix = (cx->blk_loop.state_u.stack.ix += inc);
3114         if (UNLIKELY(inc > 0
3115                         ? ix > cx->blk_oldsp
3116                         : ix <= cx->blk_loop.state_u.stack.basesp)
3117         )
3118             goto retno;
3119
3120         sv = PL_stack_base[ix];
3121         av = NULL;
3122         goto loop_ary_common;
3123
3124     case CXt_LOOP_ARY: /* for (@ary) */
3125
3126         av = cx->blk_loop.state_u.ary.ary;
3127         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3128         ix = (cx->blk_loop.state_u.ary.ix += inc);
3129         if (UNLIKELY(inc > 0
3130                         ? ix > AvFILL(av)
3131                         : ix < 0)
3132         )
3133             goto retno;
3134
3135         if (UNLIKELY(SvRMAGICAL(av))) {
3136             SV * const * const svp = av_fetch(av, ix, FALSE);
3137             sv = svp ? *svp : NULL;
3138         }
3139         else {
3140             sv = AvARRAY(av)[ix];
3141         }
3142
3143       loop_ary_common:
3144
3145         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
3146             SvSetMagicSV(*itersvp, sv);
3147             break;
3148         }
3149
3150         if (LIKELY(sv)) {
3151             if (UNLIKELY(SvIS_FREED(sv))) {
3152                 *itersvp = NULL;
3153                 Perl_croak(aTHX_ "Use of freed value in iteration");
3154             }
3155             if (SvPADTMP(sv)) {
3156                 sv = newSVsv(sv);
3157             }
3158             else {
3159                 SvTEMP_off(sv);
3160                 SvREFCNT_inc_simple_void_NN(sv);
3161             }
3162         }
3163         else if (av) {
3164             sv = newSVavdefelem(av, ix, 0);
3165         }
3166         else
3167             sv = &PL_sv_undef;
3168
3169         oldsv = *itersvp;
3170         *itersvp = sv;
3171         SvREFCNT_dec(oldsv);
3172         break;
3173
3174     default:
3175         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
3176     }
3177
3178     /* Bypass pushing &PL_sv_yes and calling pp_and(); instead
3179      * jump straight to the AND op's op_other */
3180     assert(PL_op->op_next->op_type == OP_AND);
3181     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
3182     return cLOGOPx(PL_op->op_next)->op_other;
3183
3184   retno:
3185     /* Bypass pushing &PL_sv_no and calling pp_and(); instead
3186      * jump straight to the AND op's op_next */
3187     assert(PL_op->op_next->op_type == OP_AND);
3188     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
3189     /* pp_enteriter should have pre-extended the stack */
3190     EXTEND_SKIP(PL_stack_sp, 1);
3191     /* we only need this for the rare case where the OP_AND isn't
3192      * in void context, e.g. $x = do { for (..) {...} };
3193      * but its cheaper to just push it rather than testing first
3194      */
3195     *++PL_stack_sp = &PL_sv_no;
3196     return PL_op->op_next->op_next;
3197 }
3198
3199
3200 /*
3201 A description of how taint works in pattern matching and substitution.
3202
3203 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
3204 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
3205
3206 While the pattern is being assembled/concatenated and then compiled,
3207 PL_tainted will get set (via TAINT_set) if any component of the pattern
3208 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
3209 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
3210 TAINT_get).  It will also be set if any component of the pattern matches
3211 based on locale-dependent behavior.
3212
3213 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
3214 the pattern is marked as tainted. This means that subsequent usage, such
3215 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
3216 on the new pattern too.
3217
3218 RXf_TAINTED_SEEN is used post-execution by the get magic code
3219 of $1 et al to indicate whether the returned value should be tainted.
3220 It is the responsibility of the caller of the pattern (i.e. pp_match,
3221 pp_subst etc) to set this flag for any other circumstances where $1 needs
3222 to be tainted.
3223
3224 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
3225
3226 There are three possible sources of taint
3227     * the source string
3228     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
3229     * the replacement string (or expression under /e)
3230     
3231 There are four destinations of taint and they are affected by the sources
3232 according to the rules below:
3233
3234     * the return value (not including /r):
3235         tainted by the source string and pattern, but only for the
3236         number-of-iterations case; boolean returns aren't tainted;
3237     * the modified string (or modified copy under /r):
3238         tainted by the source string, pattern, and replacement strings;
3239     * $1 et al:
3240         tainted by the pattern, and under 'use re "taint"', by the source
3241         string too;
3242     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
3243         should always be unset before executing subsequent code.
3244
3245 The overall action of pp_subst is:
3246
3247     * at the start, set bits in rxtainted indicating the taint status of
3248         the various sources.
3249
3250     * After each pattern execution, update the SUBST_TAINT_PAT bit in
3251         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
3252         pattern has subsequently become tainted via locale ops.
3253
3254     * If control is being passed to pp_substcont to execute a /e block,
3255         save rxtainted in the CXt_SUBST block, for future use by
3256         pp_substcont.
3257
3258     * Whenever control is being returned to perl code (either by falling
3259         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
3260         use the flag bits in rxtainted to make all the appropriate types of
3261         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
3262         et al will appear tainted.
3263
3264 pp_match is just a simpler version of the above.
3265
3266 */
3267
3268 PP(pp_subst)
3269 {
3270     dSP; dTARG;
3271     PMOP *pm = cPMOP;
3272     PMOP *rpm = pm;
3273     char *s;
3274     char *strend;
3275     const char *c;
3276     STRLEN clen;
3277     SSize_t iters = 0;
3278     SSize_t maxiters;
3279     bool once;
3280     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
3281                         See "how taint works" above */
3282     char *orig;
3283     U8 r_flags;
3284     REGEXP *rx = PM_GETRE(pm);
3285     regexp *prog = ReANY(rx);
3286     STRLEN len;
3287     int force_on_match = 0;
3288     const I32 oldsave = PL_savestack_ix;
3289     STRLEN slen;
3290     bool doutf8 = FALSE; /* whether replacement is in utf8 */
3291 #ifdef PERL_ANY_COW
3292     bool was_cow;
3293 #endif
3294     SV *nsv = NULL;
3295     /* known replacement string? */
3296     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
3297
3298     PERL_ASYNC_CHECK();
3299
3300     if (PL_op->op_flags & OPf_STACKED)
3301         TARG = POPs;
3302     else {
3303         if (ARGTARG)
3304             GETTARGET;
3305         else {
3306             TARG = DEFSV;
3307         }
3308         EXTEND(SP,1);
3309     }
3310
3311     SvGETMAGIC(TARG); /* must come before cow check */
3312 #ifdef PERL_ANY_COW
3313     /* note that a string might get converted to COW during matching */
3314     was_cow = cBOOL(SvIsCOW(TARG));
3315 #endif
3316     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3317 #ifndef PERL_ANY_COW
3318         if (SvIsCOW(TARG))
3319             sv_force_normal_flags(TARG,0);
3320 #endif
3321         if ((SvREADONLY(TARG)
3322                 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
3323                       || SvTYPE(TARG) > SVt_PVLV)
3324                      && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
3325             Perl_croak_no_modify();
3326     }
3327     PUTBACK;
3328
3329     orig = SvPV_nomg(TARG, len);
3330     /* note we don't (yet) force the var into being a string; if we fail
3331      * to match, we leave as-is; on successful match however, we *will*
3332      * coerce into a string, then repeat the match */
3333     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
3334         force_on_match = 1;
3335
3336     /* only replace once? */
3337     once = !(rpm->op_pmflags & PMf_GLOBAL);
3338
3339     /* See "how taint works" above */
3340     if (TAINTING_get) {
3341         rxtainted  = (
3342             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
3343           | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
3344           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
3345           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3346                 ? SUBST_TAINT_BOOLRET : 0));
3347         TAINT_NOT;
3348     }
3349
3350   force_it:
3351     if (!pm || !orig)
3352         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
3353
3354     strend = orig + len;
3355     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
3356     maxiters = 2 * slen + 10;   /* We can match twice at each
3357                                    position, once with zero-length,
3358                                    second time with non-zero. */
3359
3360     /* handle the empty pattern */
3361     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
3362         if (PL_curpm == PL_reg_curpm) {
3363             if (PL_curpm_under) {
3364                 if (PL_curpm_under == PL_reg_curpm) {
3365                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3366                 } else {
3367                     pm = PL_curpm_under;
3368                 }
3369             }
3370         } else {
3371             pm = PL_curpm;
3372         }
3373         rx = PM_GETRE(pm);
3374         prog = ReANY(rx);
3375     }
3376
3377 #ifdef PERL_SAWAMPERSAND
3378     r_flags = (    RXp_NPARENS(prog)
3379                 || PL_sawampersand
3380                 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3381                 || (rpm->op_pmflags & PMf_KEEPCOPY)
3382               )
3383           ? REXEC_COPY_STR
3384           : 0;
3385 #else
3386     r_flags = REXEC_COPY_STR;
3387 #endif
3388
3389     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
3390     {
3391         SPAGAIN;
3392         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
3393         LEAVE_SCOPE(oldsave);
3394         RETURN;
3395     }
3396     PL_curpm = pm;
3397
3398     /* known replacement string? */
3399     if (dstr) {
3400         /* replacement needing upgrading? */
3401         if (DO_UTF8(TARG) && !doutf8) {
3402              nsv = sv_newmortal();
3403              SvSetSV(nsv, dstr);
3404              sv_utf8_upgrade(nsv);
3405              c = SvPV_const(nsv, clen);
3406              doutf8 = TRUE;
3407         }
3408         else {
3409             c = SvPV_const(dstr, clen);
3410             doutf8 = DO_UTF8(dstr);
3411         }
3412
3413         if (SvTAINTED(dstr))
3414             rxtainted |= SUBST_TAINT_REPL;
3415     }
3416     else {
3417         c = NULL;
3418         doutf8 = FALSE;
3419     }
3420     
3421     /* can do inplace substitution? */
3422     if (c
3423 #ifdef PERL_ANY_COW
3424         && !was_cow
3425 #endif
3426         && (I32)clen <= RXp_MINLENRET(prog)
3427         && (  once
3428            || !(r_flags & REXEC_COPY_STR)
3429            || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
3430            )
3431         && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
3432         && (!doutf8 || SvUTF8(TARG))
3433         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3434     {
3435
3436 #ifdef PERL_ANY_COW
3437         /* string might have got converted to COW since we set was_cow */
3438         if (SvIsCOW(TARG)) {
3439           if (!force_on_match)
3440             goto have_a_cow;
3441           assert(SvVOK(TARG));
3442         }
3443 #endif
3444         if (force_on_match) {
3445             /* redo the first match, this time with the orig var
3446              * forced into being a string */
3447             force_on_match = 0;
3448             orig = SvPV_force_nomg(TARG, len);
3449             goto force_it;
3450         }
3451
3452         if (once) {
3453             char *d, *m;
3454             if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
3455                 rxtainted |= SUBST_TAINT_PAT;
3456             m = orig + RXp_OFFS(prog)[0].start;
3457             d = orig + RXp_OFFS(prog)[0].end;
3458             s = orig;
3459             if (m - s > strend - d) {  /* faster to shorten from end */
3460                 I32 i;
3461                 if (clen) {
3462                     Copy(c, m, clen, char);
3463                     m += clen;
3464                 }
3465                 i = strend - d;
3466                 if (i > 0) {
3467                     Move(d, m, i, char);
3468                     m += i;
3469                 }
3470                 *m = '\0';
3471                 SvCUR_set(TARG, m - s);
3472             }
3473             else {      /* faster from front */
3474                 I32 i = m - s;
3475                 d -= clen;
3476                 if (i > 0)
3477                     Move(s, d - i, i, char);
3478                 sv_chop(TARG, d-i);
3479                 if (clen)
3480                     Copy(c, d, clen, char);
3481             }
3482             SPAGAIN;
3483             PUSHs(&PL_sv_yes);
3484         }
3485         else {
3486             char *d, *m;
3487             d = s = RXp_OFFS(prog)[0].start + orig;
3488             do {
3489                 I32 i;
3490                 if (UNLIKELY(iters++ > maxiters))
3491                     DIE(aTHX_ "Substitution loop");
3492                 /* run time pattern taint, eg locale */
3493                 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
3494                     rxtainted |= SUBST_TAINT_PAT;
3495                 m = RXp_OFFS(prog)[0].start + orig;
3496                 if ((i = m - s)) {
3497                     if (s != d)
3498                         Move(s, d, i, char);
3499                     d += i;
3500                 }
3501                 if (clen) {
3502                     Copy(c, d, clen, char);
3503                     d += clen;
3504                 }
3505                 s = RXp_OFFS(prog)[0].end + orig;
3506             } while (CALLREGEXEC(rx, s, strend, orig,
3507                                  s == m, /* don't match same null twice */
3508                                  TARG, NULL,
3509                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3510             if (s != d) {
3511                 I32 i = strend - s;
3512                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
3513                 Move(s, d, i+1, char);          /* include the NUL */
3514             }
3515             SPAGAIN;
3516             if (PL_op->op_private & OPpTRUEBOOL)
3517                 PUSHs(iters ? &PL_sv_yes : &PL_sv_zero);
3518             else
3519                 mPUSHi(iters);
3520         }
3521     }
3522     else {
3523         bool first;
3524         char *m;
3525         SV *repl;
3526         if (force_on_match) {
3527             /* redo the first match, this time with the orig var
3528              * forced into being a string */
3529             force_on_match = 0;
3530             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3531                 /* I feel that it should be possible to avoid this mortal copy
3532                    given that the code below copies into a new destination.
3533                    However, I suspect it isn't worth the complexity of
3534                    unravelling the C<goto force_it> for the small number of
3535                    cases where it would be viable to drop into the copy code. */
3536                 TARG = sv_2mortal(newSVsv(TARG));
3537             }
3538             orig = SvPV_force_nomg(TARG, len);
3539             goto force_it;
3540         }
3541 #ifdef PERL_ANY_COW
3542       have_a_cow:
3543 #endif
3544         if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
3545             rxtainted |= SUBST_TAINT_PAT;
3546         repl = dstr;
3547         s = RXp_OFFS(prog)[0].start + orig;
3548         dstr = newSVpvn_flags(orig, s-orig,
3549                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3550         if (!c) {
3551             PERL_CONTEXT *cx;
3552             SPAGAIN;
3553             m = orig;
3554             /* note that a whole bunch of local vars are saved here for
3555              * use by pp_substcont: here's a list of them in case you're
3556              * searching for places in this sub that uses a particular var:
3557              * iters maxiters r_flags oldsave rxtainted orig dstr targ
3558              * s m strend rx once */
3559             CX_PUSHSUBST(cx);
3560             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3561         }
3562         first = TRUE;
3563         do {
3564             if (UNLIKELY(iters++ > maxiters))
3565                 DIE(aTHX_ "Substitution loop");
3566             if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
3567                 rxtainted |= SUBST_TAINT_PAT;
3568             if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
3569                 char *old_s    = s;
3570                 char *old_orig = orig;
3571                 assert(RXp_SUBOFFSET(prog) == 0);
3572
3573                 orig = RXp_SUBBEG(prog);
3574                 s = orig + (old_s - old_orig);
3575                 strend = s + (strend - old_s);
3576             }
3577             m = RXp_OFFS(prog)[0].start + orig;
3578             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3579             s = RXp_OFFS(prog)[0].end + orig;
3580             if (first) {
3581                 /* replacement already stringified */
3582               if (clen)
3583                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3584               first = FALSE;
3585             }
3586             else {
3587                 sv_catsv(dstr, repl);
3588                 if (UNLIKELY(SvTAINTED(repl)))
3589                     rxtainted |= SUBST_TAINT_REPL;
3590             }
3591             if (once)
3592                 break;
3593         } while (CALLREGEXEC(rx, s, strend, orig,
3594                              s == m,    /* Yields minend of 0 or 1 */
3595                              TARG, NULL,
3596                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3597         assert(strend >= s);
3598         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3599
3600         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3601             /* From here on down we're using the copy, and leaving the original
3602                untouched.  */
3603             TARG = dstr;
3604             SPAGAIN;
3605             PUSHs(dstr);
3606         } else {
3607 #ifdef PERL_ANY_COW
3608             /* The match may make the string COW. If so, brilliant, because
3609                that's just saved us one malloc, copy and free - the regexp has
3610                donated the old buffer, and we malloc an entirely new one, rather
3611                than the regexp malloc()ing a buffer and copying our original,
3612                only for us to throw it away here during the substitution.  */
3613             if (SvIsCOW(TARG)) {
3614                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3615             } else
3616 #endif
3617             {
3618                 SvPV_free(TARG);
3619             }
3620             SvPV_set(TARG, SvPVX(dstr));
3621             SvCUR_set(TARG, SvCUR(dstr));
3622             SvLEN_set(TARG, SvLEN(dstr));
3623             SvFLAGS(TARG) |= SvUTF8(dstr);
3624             SvPV_set(dstr, NULL);
3625
3626             SPAGAIN;
3627             mPUSHi(iters);
3628         }
3629     }
3630
3631     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3632         (void)SvPOK_only_UTF8(TARG);
3633     }
3634
3635     /* See "how taint works" above */
3636     if (TAINTING_get) {
3637         if ((rxtainted & SUBST_TAINT_PAT) ||
3638             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3639                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3640         )
3641             (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
3642
3643         if (!(rxtainted & SUBST_TAINT_BOOLRET)
3644             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3645         )
3646             SvTAINTED_on(TOPs);  /* taint return value */
3647         else
3648             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
3649
3650         /* needed for mg_set below */
3651         TAINT_set(
3652           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3653         );
3654         SvTAINT(TARG);
3655     }
3656     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3657     TAINT_NOT;
3658     LEAVE_SCOPE(oldsave);
3659     RETURN;
3660 }
3661
3662 PP(pp_grepwhile)
3663 {
3664     dSP;
3665     dPOPss;
3666
3667     if (SvTRUE_NN(sv))
3668         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3669     ++*PL_markstack_ptr;
3670     FREETMPS;
3671     LEAVE_with_name("grep_item");                                       /* exit inner scope */
3672
3673     /* All done yet? */
3674     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3675         I32 items;
3676         const U8 gimme = GIMME_V;
3677
3678         LEAVE_with_name("grep");                                        /* exit outer scope */
3679         (void)POPMARK;                          /* pop src */
3680         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3681         (void)POPMARK;                          /* pop dst */
3682         SP = PL_stack_base + POPMARK;           /* pop original mark */
3683         if (gimme == G_SCALAR) {
3684             if (PL_op->op_private & OPpTRUEBOOL)
3685                 PUSHs(items ? &PL_sv_yes : &PL_sv_zero);
3686             else {
3687                 dTARGET;
3688                 PUSHi(items);
3689             }
3690         }
3691         else if (gimme == G_ARRAY)
3692             SP += items;
3693         RETURN;
3694     }
3695     else {
3696         SV *src;
3697
3698         ENTER_with_name("grep_item");                                   /* enter inner scope */
3699         SAVEVPTR(PL_curpm);
3700
3701         src = PL_stack_base[TOPMARK];
3702         if (SvPADTMP(src)) {
3703             src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
3704             PL_tmps_floor++;
3705         }
3706         SvTEMP_off(src);
3707         DEFSV_set(src);
3708
3709         RETURNOP(cLOGOP->op_other);
3710     }
3711 }
3712
3713 /* leave_adjust_stacks():
3714  *
3715  * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
3716  * positioning them at to_sp+1 onwards, and do the equivalent of a
3717  * FREEMPS and TAINT_NOT.
3718  *
3719  * Not intended to be called in void context.
3720  *
3721  * When leaving a sub, eval, do{} or other scope, the things that need
3722  * doing to process the return args are:
3723  *    * in scalar context, only return the last arg (or PL_sv_undef if none);
3724  *    * for the types of return that return copies of their args (such
3725  *      as rvalue sub return), make a mortal copy of every return arg,
3726  *      except where we can optimise the copy away without it being
3727  *      semantically visible;
3728  *    * make sure that the arg isn't prematurely freed; in the case of an
3729  *      arg not copied, this may involve mortalising it. For example, in
3730  *      C<sub f { my $x = ...; $x }>, $x would be freed when we do
3731  *      CX_LEAVE_SCOPE(cx) unless it's protected or copied.
3732  *
3733  * What condition to use when deciding whether to pass the arg through
3734  * or make a copy, is determined by the 'pass' arg; its valid values are:
3735  *   0: rvalue sub/eval exit
3736  *   1: other rvalue scope exit
3737  *   2: :lvalue sub exit in rvalue context
3738  *   3: :lvalue sub exit in lvalue context and other lvalue scope exits
3739  *
3740  * There is a big issue with doing a FREETMPS. We would like to free any
3741  * temps created by the last statement which the sub executed, rather than
3742  * leaving them for the caller. In a situation where a sub call isn't
3743  * soon followed by a nextstate (e.g. nested recursive calls, a la
3744  * fibonacci()), temps can accumulate, causing memory and performance
3745  * issues.
3746  *
3747  * On the other hand, we don't want to free any TEMPs which are keeping
3748  * alive any return args that we skipped copying; nor do we wish to undo
3749  * any mortalising done here.
3750  *
3751  * The solution is to split the temps stack frame into two, with a cut
3752  * point delineating the two halves. We arrange that by the end of this
3753  * function, all the temps stack frame entries we wish to keep are in the
3754  * range  PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
3755  * the range  tmps_base .. PL_tmps_ix.  During the course of this
3756  * function, tmps_base starts off as PL_tmps_floor+1, then increases
3757  * whenever we find or create a temp that we know should be kept. In
3758  * general the stuff above tmps_base is undecided until we reach the end,
3759  * and we may need a sort stage for that.
3760  *
3761  * To determine whether a TEMP is keeping a return arg alive, every
3762  * arg that is kept rather than copied and which has the SvTEMP flag
3763  * set, has the flag temporarily unset, to mark it. At the end we scan
3764  * the temps stack frame above the cut for entries without SvTEMP and
3765  * keep them, while turning SvTEMP on again. Note that if we die before
3766  * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
3767  * those SVs may be slightly less efficient.
3768  *
3769  * In practice various optimisations for some common cases mean we can
3770  * avoid most of the scanning and swapping about with the temps stack.
3771  */
3772
3773 void
3774 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
3775 {
3776     dVAR;
3777     dSP;
3778     SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
3779     SSize_t nargs;
3780
3781     PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
3782
3783     TAINT_NOT;
3784
3785     if (gimme == G_ARRAY) {
3786         nargs = SP - from_sp;
3787         from_sp++;
3788     }
3789     else {
3790         assert(gimme == G_SCALAR);
3791         if (UNLIKELY(from_sp >= SP)) {
3792             /* no return args */
3793             assert(from_sp == SP);
3794             EXTEND(SP, 1);
3795             *++SP = &PL_sv_undef;
3796             to_sp = SP;
3797             nargs   = 0;
3798         }
3799         else {
3800             from_sp = SP;
3801             nargs   = 1;
3802         }
3803     }
3804
3805     /* common code for G_SCALAR and G_ARRAY */
3806
3807     tmps_base = PL_tmps_floor + 1;
3808
3809     assert(nargs >= 0);
3810     if (nargs) {
3811         /* pointer version of tmps_base. Not safe across temp stack
3812          * reallocs. */
3813         SV **tmps_basep;
3814
3815         EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
3816         tmps_basep = PL_tmps_stack + tmps_base;
3817
3818         /* process each return arg */
3819
3820         do {
3821             SV *sv = *from_sp++;
3822
3823             assert(PL_tmps_ix + nargs < PL_tmps_max);
3824 #ifdef DEBUGGING
3825             /* PADTMPs with container set magic shouldn't appear in the
3826              * wild. This assert is more important for pp_leavesublv(),
3827              * but by testing for it here, we're more likely to catch
3828              * bad cases (what with :lvalue subs not being widely
3829              * deployed). The two issues are that for something like
3830              *     sub :lvalue { $tied{foo} }
3831              * or
3832              *     sub :lvalue { substr($foo,1,2) }
3833              * pp_leavesublv() will croak if the sub returns a PADTMP,
3834              * and currently functions like pp_substr() return a mortal
3835              * rather than using their PADTMP when returning a PVLV.
3836              * This is because the PVLV will hold a ref to $foo,
3837              * so $foo would get delayed in being freed while
3838              * the PADTMP SV remained in the PAD.
3839              * So if this assert fails it means either:
3840              *  1) there is pp code similar to pp_substr that is
3841              *     returning a PADTMP instead of a mortal, and probably
3842              *     needs fixing, or
3843              *  2) pp_leavesublv is making unwarranted assumptions
3844              *     about always croaking on a PADTMP
3845              */
3846             if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
3847                 MAGIC *mg;
3848                 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
3849                     assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
3850                 }
3851             }
3852 #endif
3853
3854             if (
3855                pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3856              : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3857              : pass == 2 ? (!SvPADTMP(sv))
3858              : 1)
3859             {
3860                 /* pass through: skip copy for logic or optimisation
3861                  * reasons; instead mortalise it, except that ... */
3862                 *++to_sp = sv;
3863
3864                 if (SvTEMP(sv)) {
3865                     /* ... since this SV is an SvTEMP , we don't need to
3866                      * re-mortalise it; instead we just need to ensure
3867                      * that its existing entry in the temps stack frame
3868                      * ends up below the cut and so avoids being freed
3869                      * this time round. We mark it as needing to be kept
3870                      * by temporarily unsetting SvTEMP; then at the end,
3871                      * we shuffle any !SvTEMP entries on the tmps stack
3872                      * back below the cut.
3873                      * However, there's a significant chance that there's
3874                      * a 1:1 correspondence between the first few (or all)
3875                      * elements in the return args stack frame and those
3876                      * in the temps stack frame; e,g.:
3877                      *      sub f { ....; map {...} .... },
3878                      * or if we're exiting multiple scopes and one of the
3879                      * inner scopes has already made mortal copies of each
3880                      * return arg.
3881                      *
3882                      * If so, this arg sv will correspond to the next item
3883                      * on the tmps stack above the cut, and so can be kept
3884                      * merely by moving the cut boundary up one, rather
3885                      * than messing with SvTEMP.  If all args are 1:1 then
3886                      * we can avoid the sorting stage below completely.
3887                      *
3888                      * If there are no items above the cut on the tmps
3889                      * stack, then the SvTEMP must comne from an item
3890                      * below the cut, so there's nothing to do.
3891                      */
3892                     if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
3893                         if (sv == *tmps_basep)
3894                             tmps_basep++;
3895                         else
3896                             SvTEMP_off(sv);
3897                     }
3898                 }
3899                 else if (!SvPADTMP(sv)) {
3900                     /* mortalise arg to avoid it being freed during save
3901                      * stack unwinding. Pad tmps don't need mortalising as
3902                      * they're never freed. This is the equivalent of
3903                      * sv_2mortal(SvREFCNT_inc(sv)), except that:
3904                      *  * it assumes that the temps stack has already been
3905                      *    extended;
3906                      *  * it puts the new item at the cut rather than at
3907                      *    ++PL_tmps_ix, moving the previous occupant there
3908                      *    instead.
3909                      */
3910                     if (!SvIMMORTAL(sv)) {
3911                         SvREFCNT_inc_simple_void_NN(sv);
3912                         SvTEMP_on(sv);
3913                         /* Note that if there's nothing above the cut,
3914                          * this copies the garbage one slot above
3915                          * PL_tmps_ix onto itself. This is harmless (the
3916                          * stack's already been extended), but might in
3917                          * theory trigger warnings from tools like ASan
3918                          */
3919                         PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3920                         *tmps_basep++ = sv;
3921                     }
3922                 }
3923             }
3924             else {
3925                 /* Make a mortal copy of the SV.
3926                  * The following code is the equivalent of sv_mortalcopy()
3927                  * except that:
3928                  *  * it assumes the temps stack has already been extended;
3929                  *  * it optimises the copying for some simple SV types;
3930                  *  * it puts the new item at the cut rather than at
3931                  *    ++PL_tmps_ix, moving the previous occupant there
3932                  *    instead.
3933                  */
3934                 SV *newsv = newSV(0);
3935
3936                 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3937                 /* put it on the tmps stack early so it gets freed if we die */
3938                 *tmps_basep++ = newsv;
3939                 *++to_sp = newsv;
3940
3941                 if (SvTYPE(sv) <= SVt_IV) {
3942                     /* arg must be one of undef, IV/UV, or RV: skip
3943                      * sv_setsv_flags() and do the copy directly */
3944                     U32 dstflags;
3945                     U32 srcflags = SvFLAGS(sv);
3946
3947                     assert(!SvGMAGICAL(sv));
3948                     if (srcflags & (SVf_IOK|SVf_ROK)) {
3949                         SET_SVANY_FOR_BODYLESS_IV(newsv);
3950
3951                         if (srcflags & SVf_ROK) {
3952                             newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
3953                             /* SV type plus flags */
3954                             dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
3955                         }
3956                         else {
3957                             /* both src and dst are <= SVt_IV, so sv_any
3958                              * points to the head; so access the heads
3959                              * directly rather than going via sv_any.
3960                              */
3961                             assert(    &(sv->sv_u.svu_iv)
3962                                     == &(((XPVIV*) SvANY(sv))->xiv_iv));
3963                             assert(    &(newsv->sv_u.svu_iv)
3964                                     == &(((XPVIV*) SvANY(newsv))->xiv_iv));
3965                             newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
3966                             /* SV type plus flags */
3967                             dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
3968                                             |(srcflags & SVf_IVisUV));
3969                         }
3970                     }
3971                     else {
3972                         assert(!(srcflags & SVf_OK));
3973                         dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
3974                     }
3975                     SvFLAGS(newsv) = dstflags;
3976
3977                 }
3978                 else {
3979                     /* do the full sv_setsv() */
3980                     SSize_t old_base;
3981
3982                     SvTEMP_on(newsv);
3983                     old_base = tmps_basep - PL_tmps_stack;
3984                     SvGETMAGIC(sv);
3985                     sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
3986                     /* the mg_get or sv_setsv might have created new temps
3987                      * or realloced the tmps stack; regrow and reload */
3988                     EXTEND_MORTAL(nargs);
3989                     tmps_basep = PL_tmps_stack + old_base;
3990                     TAINT_NOT;  /* Each item is independent */
3991                 }
3992
3993             }
3994         } while (--nargs);
3995
3996         /* If there are any temps left above the cut, we need to sort
3997          * them into those to keep and those to free. The only ones to
3998          * keep are those for which we've temporarily unset SvTEMP.
3999          * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
4000          * swapping pairs as necessary. Stop when we meet in the middle.
4001          */
4002         {
4003             SV **top = PL_tmps_stack + PL_tmps_ix;
4004             while (tmps_basep <= top) {
4005                 SV *sv = *top;
4006                 if (SvTEMP(sv))
4007                     top--;
4008                 else {
4009                     SvTEMP_on(sv);
4010                     *top = *tmps_basep;
4011                     *tmps_basep = sv;
4012                     tmps_basep++;
4013                 }
4014             }
4015         }
4016
4017         tmps_base = tmps_basep - PL_tmps_stack;
4018     }
4019
4020     PL_stack_sp = to_sp;
4021
4022     /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
4023     while (PL_tmps_ix >= tmps_base) {
4024         SV* const sv = PL_tmps_stack[PL_tmps_ix--];
4025 #ifdef PERL_POISON
4026         PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
4027 #endif
4028         if (LIKELY(sv)) {
4029             SvTEMP_off(sv);
4030             SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
4031         }
4032     }
4033 }
4034
4035
4036 /* also tail-called by pp_return */
4037
4038 PP(pp_leavesub)
4039 {
4040     U8 gimme;
4041     PERL_CONTEXT *cx;
4042     SV **oldsp;
4043     OP *retop;
4044
4045     cx = CX_CUR();
4046     assert(CxTYPE(cx) == CXt_SUB);
4047
4048     if (CxMULTICALL(cx)) {
4049         /* entry zero of a stack is always PL_sv_undef, which
4050          * simplifies converting a '()' return into undef in scalar context */
4051         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
4052         return 0;
4053     }
4054
4055     gimme = cx->blk_gimme;
4056     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
4057
4058     if (gimme == G_VOID)
4059         PL_stack_sp = oldsp;
4060     else
4061         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4062
4063     CX_LEAVE_SCOPE(cx);
4064     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
4065     cx_popblock(cx);
4066     retop = cx->blk_sub.retop;
4067     CX_POP(cx);
4068
4069     return retop;
4070 }
4071
4072
4073 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
4074  * forces an abandon */
4075
4076 void
4077 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
4078 {
4079     const SSize_t fill = AvFILLp(av);
4080
4081     PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
4082
4083     if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
4084         av_clear(av);
4085         AvREIFY_only(av);
4086     }
4087     else {
4088         AV *newav = newAV();
4089         av_extend(newav, fill);
4090         AvREIFY_only(newav);
4091         PAD_SVl(0) = MUTABLE_SV(newav);
4092         SvREFCNT_dec_NN(av);
4093     }
4094 }
4095
4096
4097 PP(pp_entersub)
4098 {
4099     dSP; dPOPss;
4100     GV *gv;
4101     CV *cv;
4102     PERL_CONTEXT *cx;
4103     I32 old_savestack_ix;
4104
4105     if (UNLIKELY(!sv))
4106         goto do_die;
4107
4108     /* Locate the CV to call:
4109      * - most common case: RV->CV: f(), $ref->():
4110      *   note that if a sub is compiled before its caller is compiled,
4111      *   the stash entry will be a ref to a CV, rather than being a GV.
4112      * - second most common case: CV: $ref->method()
4113      */
4114
4115     /* a non-magic-RV -> CV ? */
4116     if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
4117         cv = MUTABLE_CV(SvRV(sv));
4118         if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
4119             goto do_ref;
4120     }
4121     else
4122         cv = MUTABLE_CV(sv);
4123
4124     /* a CV ? */
4125     if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
4126         /* handle all the weird cases */
4127         switch (SvTYPE(sv)) {
4128         case SVt_PVLV:
4129             if (!isGV_with_GP(sv))
4130                 goto do_default;
4131             /* FALLTHROUGH */
4132         case SVt_PVGV:
4133             cv = GvCVu((const GV *)sv);
4134             if (UNLIKELY(!cv)) {
4135                 HV *stash;
4136                 cv = sv_2cv(sv, &stash, &gv, 0);
4137                 if (!cv) {
4138                     old_savestack_ix = PL_savestack_ix;
4139                     goto try_autoload;
4140                 }
4141             }
4142             break;
4143
4144         default:
4145           do_default:
4146             SvGETMAGIC(sv);
4147             if (SvROK(sv)) {
4148               do_ref:
4149                 if (UNLIKELY(SvAMAGIC(sv))) {
4150                     sv = amagic_deref_call(sv, to_cv_amg);
4151                     /* Don't SPAGAIN here.  */
4152                 }
4153             }
4154             else {
4155                 const char *sym;
4156                 STRLEN len;
4157                 if (UNLIKELY(!SvOK(sv)))
4158                     DIE(aTHX_ PL_no_usym, "a subroutine");
4159
4160                 if (UNLIKELY(sv == &PL_sv_yes)) { /* unfound import, ignore */
4161                     if (PL_op->op_flags & OPf_STACKED) /* hasargs */
4162                         SP = PL_stack_base + POPMARK;
4163                     else
4164                         (void)POPMARK;
4165                     if (GIMME_V == G_SCALAR)
4166                         PUSHs(&PL_sv_undef);
4167                     RETURN;
4168                 }
4169
4170                 sym = SvPV_nomg_const(sv, len);
4171                 if (PL_op->op_private & HINT_STRICT_REFS)
4172                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
4173                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
4174                 break;
4175             }
4176             cv = MUTABLE_CV(SvRV(sv));
4177             if (LIKELY(SvTYPE(cv) == SVt_PVCV))
4178                 break;
4179             /* FALLTHROUGH */
4180         case SVt_PVHV:
4181         case SVt_PVAV:
4182           do_die:
4183             DIE(aTHX_ "Not a CODE reference");
4184         }
4185     }
4186
4187     /* At this point we want to save PL_savestack_ix, either by doing a
4188      * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
4189      * CV we will be using (so we don't know whether its XS, so we can't
4190      * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
4191      * the save stack. So remember where we are currently on the save
4192      * stack, and later update the CX or scopestack entry accordingly. */
4193     old_savestack_ix = PL_savestack_ix;
4194
4195     /* these two fields are in a union. If they ever become separate,
4196      * we have to test for both of them being null below */
4197     assert(cv);
4198     assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
4199     while (UNLIKELY(!CvROOT(cv))) {
4200         GV* autogv;
4201         SV* sub_name;
4202
4203         /* anonymous or undef'd function leaves us no recourse */
4204         if (CvLEXICAL(cv) && CvHASGV(cv))
4205             DIE(aTHX_ "Undefined subroutine &%" SVf " called",
4206                        SVfARG(cv_name(cv, NULL, 0)));
4207         if (CvANON(cv) || !CvHASGV(cv)) {
4208             DIE(aTHX_ "Undefined subroutine called");
4209         }
4210
4211         /* autoloaded stub? */
4212         if (cv != GvCV(gv = CvGV(cv))) {
4213             cv = GvCV(gv);
4214         }
4215         /* should call AUTOLOAD now? */
4216         else {
4217           try_autoload:
4218             autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
4219                                      (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
4220                                     |(PL_op->op_flags & OPf_REF
4221                                        ? GV_AUTOLOAD_ISMETHOD
4222                                        : 0));
4223             cv = autogv ? GvCV(autogv) : NULL;
4224         }
4225         if (!cv) {
4226             sub_name = sv_newmortal();
4227             gv_efullname3(sub_name, gv, NULL);
4228             DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
4229         }
4230     }
4231
4232     /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
4233     if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
4234         DIE(aTHX_ "Closure prototype called");
4235
4236     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
4237             && !CvNODEBUG(cv)))
4238     {
4239          Perl_get_db_sub(aTHX_ &sv, cv);
4240          if (CvISXSUB(cv))
4241              PL_curcopdb = PL_curcop;
4242          if (CvLVALUE(cv)) {
4243              /* check for lsub that handles lvalue subroutines */
4244              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
4245              /* if lsub not found then fall back to DB::sub */
4246              if (!cv) cv = GvCV(PL_DBsub);
4247          } else {
4248              cv = GvCV(PL_DBsub);
4249          }
4250
4251         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
4252             DIE(aTHX_ "No DB::sub routine defined");
4253     }
4254
4255     if (!(CvISXSUB(cv))) {
4256         /* This path taken at least 75% of the time   */
4257         dMARK;
4258         PADLIST *padlist;
4259         I32 depth;
4260         bool hasargs;
4261         U8 gimme;
4262
4263         /* keep PADTMP args alive throughout the call (we need to do this
4264          * because @_ isn't refcounted). Note that we create the mortals
4265          * in the caller's tmps frame, so they won't be freed until after
4266          * we return from the sub.
4267          */
4268         {
4269             SV **svp = MARK;
4270             while (svp < SP) {
4271                 SV *sv = *++svp;
4272                 if (!sv)
4273                     continue;
4274                 if (SvPADTMP(sv))
4275                     *svp = sv = sv_mortalcopy(sv);
4276                 SvTEMP_off(sv);
4277             }
4278         }
4279
4280         gimme = GIMME_V;
4281         cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
4282         hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
4283         cx_pushsub(cx, cv, PL_op->op_next, hasargs);
4284
4285         padlist = CvPADLIST(cv);
4286         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
4287             pad_push(padlist, depth);
4288         PAD_SET_CUR_NOSAVE(padlist, depth);
4289         if (LIKELY(hasargs)) {
4290             AV *const av = MUTABLE_AV(PAD_SVl(0));
4291             SSize_t items;
4292             AV **defavp;
4293
4294             defavp = &GvAV(PL_defgv);
4295             cx->blk_sub.savearray = *defavp;
4296             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
4297
4298             /* it's the responsibility of whoever leaves a sub to ensure
4299              * that a clean, empty AV is left in pad[0]. This is normally
4300              * done by cx_popsub() */
4301             assert(!AvREAL(av) && AvFILLp(av) == -1);
4302
4303             items = SP - MARK;
4304             if (UNLIKELY(items - 1 > AvMAX(av))) {
4305                 SV **ary = AvALLOC(av);
4306                 Renew(ary, items, SV*);
4307                 AvMAX(av) = items - 1;
4308                 AvALLOC(av) = ary;
4309                 AvARRAY(av) = ary;
4310             }
4311
4312             Copy(MARK+1,AvARRAY(av),items,SV*);
4313             AvFILLp(av) = items - 1;
4314         }
4315         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
4316             !CvLVALUE(cv)))
4317             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
4318                 SVfARG(cv_name(cv, NULL, 0)));
4319         /* warning must come *after* we fully set up the context
4320          * stuff so that __WARN__ handlers can safely dounwind()
4321          * if they want to
4322          */
4323         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
4324                 && ckWARN(WARN_RECURSION)
4325                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4326             sub_crush_depth(cv);
4327         RETURNOP(CvSTART(cv));
4328     }
4329     else {
4330         SSize_t markix = TOPMARK;
4331         bool is_scalar;
4332
4333         ENTER;
4334         /* pretend we did the ENTER earlier */
4335         PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
4336