This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
S_padhv_rv2hv_common(): reorganise code
[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 is_tied;
977     bool is_bool;
978     MAGIC *mg;
979     dSP;
980     IV  i;
981     SV *sv;
982
983     assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
984
985     if (gimme == G_ARRAY) {
986         hv_pushkv(hv);
987         return NORMAL;
988     }
989
990     if (is_keys)
991         /* 'keys %h' masquerading as '%h': reset iterator */
992         (void)hv_iterinit(hv);
993
994     is_bool = (     PL_op->op_private & OPpTRUEBOOL
995               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
996                   && block_gimme() == G_VOID));
997     is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
998
999     if (UNLIKELY(is_tied)) {
1000         if (is_keys && !is_bool) {
1001             i = 0;
1002             while (hv_iternext(hv))
1003                 i++;
1004             goto push_i;
1005         }
1006         else {
1007             sv = magic_scalarpack(hv, mg);
1008             goto push_sv;
1009         }
1010     }
1011     else {
1012         i = HvUSEDKEYS(hv);
1013         if (is_bool) {
1014             sv = i ? &PL_sv_yes : &PL_sv_zero;
1015           push_sv:
1016             PUSHs(sv);
1017         }
1018         else {
1019           push_i:
1020             if (has_targ) {
1021                 dTARGET;
1022                 PUSHi(i);
1023             }
1024             else
1025                 mPUSHi(i);
1026         }
1027     }
1028
1029     PUTBACK;
1030     return NORMAL;
1031 }
1032
1033
1034 /* This is also called directly by pp_lvavref.  */
1035 PP(pp_padav)
1036 {
1037     dSP; dTARGET;
1038     U8 gimme;
1039     assert(SvTYPE(TARG) == SVt_PVAV);
1040     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1041         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1042             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1043     EXTEND(SP, 1);
1044
1045     if (PL_op->op_flags & OPf_REF) {
1046         PUSHs(TARG);
1047         RETURN;
1048     }
1049     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1050         const I32 flags = is_lvalue_sub();
1051         if (flags && !(flags & OPpENTERSUB_INARGS)) {
1052             if (GIMME_V == G_SCALAR)
1053                 /* diag_listed_as: Can't return %s to lvalue scalar context */
1054                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1055             PUSHs(TARG);
1056             RETURN;
1057        }
1058     }
1059
1060     gimme = GIMME_V;
1061     if (gimme == G_ARRAY)
1062         return S_pushav(aTHX_ (AV*)TARG);
1063
1064     if (gimme == G_SCALAR) {
1065         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1066         if (!maxarg)
1067             PUSHs(&PL_sv_zero);
1068         else if (PL_op->op_private & OPpTRUEBOOL)
1069             PUSHs(&PL_sv_yes);
1070         else
1071             mPUSHi(maxarg);
1072     }
1073     RETURN;
1074 }
1075
1076
1077 PP(pp_padhv)
1078 {
1079     dSP; dTARGET;
1080     U8 gimme;
1081
1082     assert(SvTYPE(TARG) == SVt_PVHV);
1083     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1084         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1085             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1086
1087     EXTEND(SP, 1);
1088
1089     if (PL_op->op_flags & OPf_REF) {
1090         PUSHs(TARG);
1091         RETURN;
1092     }
1093     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1094         const I32 flags = is_lvalue_sub();
1095         if (flags && !(flags & OPpENTERSUB_INARGS)) {
1096             if (GIMME_V == G_SCALAR)
1097                 /* diag_listed_as: Can't return %s to lvalue scalar context */
1098                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
1099             PUSHs(TARG);
1100             RETURN;
1101         }
1102     }
1103
1104     gimme = GIMME_V;
1105
1106     return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
1107                         cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1108                         0 /* has_targ*/);
1109 }
1110
1111
1112 /* also used for: pp_rv2hv() */
1113 /* also called directly by pp_lvavref */
1114
1115 PP(pp_rv2av)
1116 {
1117     dSP; dTOPss;
1118     const U8 gimme = GIMME_V;
1119     static const char an_array[] = "an ARRAY";
1120     static const char a_hash[] = "a HASH";
1121     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1122                           || PL_op->op_type == OP_LVAVREF;
1123     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
1124
1125     SvGETMAGIC(sv);
1126     if (SvROK(sv)) {
1127         if (UNLIKELY(SvAMAGIC(sv))) {
1128             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
1129         }
1130         sv = SvRV(sv);
1131         if (UNLIKELY(SvTYPE(sv) != type))
1132             /* diag_listed_as: Not an ARRAY reference */
1133             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
1134         else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1135                 && PL_op->op_private & OPpLVAL_INTRO))
1136             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
1137     }
1138     else if (UNLIKELY(SvTYPE(sv) != type)) {
1139             GV *gv;
1140         
1141             if (!isGV_with_GP(sv)) {
1142                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
1143                                      type, &sp);
1144                 if (!gv)
1145                     RETURN;
1146             }
1147             else {
1148                 gv = MUTABLE_GV(sv);
1149             }
1150             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
1151             if (PL_op->op_private & OPpLVAL_INTRO)
1152                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
1153     }
1154     if (PL_op->op_flags & OPf_REF) {
1155                 SETs(sv);
1156                 RETURN;
1157     }
1158     else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
1159               const I32 flags = is_lvalue_sub();
1160               if (flags && !(flags & OPpENTERSUB_INARGS)) {
1161                 if (gimme != G_ARRAY)
1162                     goto croak_cant_return;
1163                 SETs(sv);
1164                 RETURN;
1165               }
1166     }
1167
1168     if (is_pp_rv2av) {
1169         AV *const av = MUTABLE_AV(sv);
1170
1171         if (gimme == G_ARRAY) {
1172             SP--;
1173             PUTBACK;
1174             return S_pushav(aTHX_ av);
1175         }
1176
1177         if (gimme == G_SCALAR) {
1178             const SSize_t maxarg = AvFILL(av) + 1;
1179             if (PL_op->op_private & OPpTRUEBOOL)
1180                 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
1181             else {
1182                 dTARGET;
1183                 SETi(maxarg);
1184             }
1185         }
1186     }
1187     else {
1188         SP--; PUTBACK;
1189         return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
1190                         cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
1191                         1 /* has_targ*/);
1192     }
1193     RETURN;
1194
1195  croak_cant_return:
1196     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
1197                is_pp_rv2av ? "array" : "hash");
1198     RETURN;
1199 }
1200
1201 STATIC void
1202 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
1203 {
1204     PERL_ARGS_ASSERT_DO_ODDBALL;
1205
1206     if (*oddkey) {
1207         if (ckWARN(WARN_MISC)) {
1208             const char *err;
1209             if (oddkey == firstkey &&
1210                 SvROK(*oddkey) &&
1211                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
1212                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
1213             {
1214                 err = "Reference found where even-sized list expected";
1215             }
1216             else
1217                 err = "Odd number of elements in hash assignment";
1218             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1219         }
1220
1221     }
1222 }
1223
1224
1225 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
1226  * are common to both the LHS and RHS of an aassign, and replace them
1227  * with copies. All these copies are made before the actual list assign is
1228  * done.
1229  *
1230  * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
1231  * element ($b) to the first LH element ($a), modifies $a; when the
1232  * second assignment is done, the second RH element now has the wrong
1233  * value. So we initially replace the RHS with ($b, mortalcopy($a)).
1234  * Note that we don't need to make a mortal copy of $b.
1235  *
1236  * The algorithm below works by, for every RHS element, mark the
1237  * corresponding LHS target element with SVf_BREAK. Then if the RHS
1238  * element is found with SVf_BREAK set, it means it would have been
1239  * modified, so make a copy.
1240  * Note that by scanning both LHS and RHS in lockstep, we avoid
1241  * unnecessary copies (like $b above) compared with a naive
1242  * "mark all LHS; copy all marked RHS; unmark all LHS".
1243  *
1244  * If the LHS element is a 'my' declaration' and has a refcount of 1, then
1245  * it can't be common and can be skipped.
1246  *
1247  * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
1248  * that we thought we didn't need to call S_aassign_copy_common(), but we
1249  * have anyway for sanity checking. If we find we need to copy, then panic.
1250  */
1251
1252 PERL_STATIC_INLINE void
1253 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
1254         SV **firstrelem, SV **lastrelem
1255 #ifdef DEBUGGING
1256         , bool fake
1257 #endif
1258 )
1259 {
1260     dVAR;
1261     SV **relem;
1262     SV **lelem;
1263     SSize_t lcount = lastlelem - firstlelem + 1;
1264     bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
1265     bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
1266     bool copy_all = FALSE;
1267
1268     assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
1269     assert(firstlelem < lastlelem); /* at least 2 LH elements */
1270     assert(firstrelem < lastrelem); /* at least 2 RH elements */
1271
1272
1273     lelem = firstlelem;
1274     /* we never have to copy the first RH element; it can't be corrupted
1275      * by assigning something to the corresponding first LH element.
1276      * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
1277      */
1278     relem = firstrelem + 1;
1279
1280     for (; relem <= lastrelem; relem++) {
1281         SV *svr;
1282
1283         /* mark next LH element */
1284
1285         if (--lcount >= 0) {
1286             SV *svl = *lelem++;
1287
1288             if (UNLIKELY(!svl)) {/* skip AV alias marker */
1289                 assert (lelem <= lastlelem);
1290                 svl = *lelem++;
1291                 lcount--;
1292             }
1293
1294             assert(svl);
1295             if (SvSMAGICAL(svl)) {
1296                 copy_all = TRUE;
1297             }
1298             if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
1299                 if (!marked)
1300                     return;
1301                 /* this LH element will consume all further args;
1302                  * no need to mark any further LH elements (if any).
1303                  * But we still need to scan any remaining RHS elements;
1304                  * set lcount negative to distinguish from  lcount == 0,
1305                  * so the loop condition continues being true
1306                  */
1307                 lcount = -1;
1308                 lelem--; /* no need to unmark this element */
1309             }
1310             else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
1311                 SvFLAGS(svl) |= SVf_BREAK;
1312                 marked = TRUE;
1313             }
1314             else if (!marked) {
1315                 /* don't check RH element if no SVf_BREAK flags set yet */
1316                 if (!lcount)
1317                     break;
1318                 continue;
1319             }
1320         }
1321
1322         /* see if corresponding RH element needs copying */
1323
1324         assert(marked);
1325         svr = *relem;
1326         assert(svr);
1327
1328         if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
1329             U32 brk = (SvFLAGS(svr) & SVf_BREAK);
1330
1331 #ifdef DEBUGGING
1332             if (fake) {
1333                 /* op_dump(PL_op); */
1334                 Perl_croak(aTHX_
1335                     "panic: aassign skipped needed copy of common RH elem %"
1336                         UVuf, (UV)(relem - firstrelem));
1337             }
1338 #endif
1339
1340             TAINT_NOT;  /* Each item is independent */
1341
1342             /* Dear TODO test in t/op/sort.t, I love you.
1343                (It's relying on a panic, not a "semi-panic" from newSVsv()
1344                and then an assertion failure below.)  */
1345             if (UNLIKELY(SvIS_FREED(svr))) {
1346                 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1347                            (void*)svr);
1348             }
1349             /* avoid break flag while copying; otherwise COW etc
1350              * disabled... */
1351             SvFLAGS(svr) &= ~SVf_BREAK;
1352             /* Not newSVsv(), as it does not allow copy-on-write,
1353                resulting in wasteful copies.
1354                Also, we use SV_NOSTEAL in case the SV is used more than
1355                once, e.g.  (...) = (f())[0,0]
1356                Where the same SV appears twice on the RHS without a ref
1357                count bump.  (Although I suspect that the SV won't be
1358                stealable here anyway - DAPM).
1359                */
1360             *relem = sv_mortalcopy_flags(svr,
1361                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1362             /* ... but restore afterwards in case it's needed again,
1363              * e.g. ($a,$b,$c) = (1,$a,$a)
1364              */
1365             SvFLAGS(svr) |= brk;
1366         }
1367
1368         if (!lcount)
1369             break;
1370     }
1371
1372     if (!marked)
1373         return;
1374
1375     /*unmark LHS */
1376
1377     while (lelem > firstlelem) {
1378         SV * const svl = *(--lelem);
1379         if (svl)
1380             SvFLAGS(svl) &= ~SVf_BREAK;
1381     }
1382 }
1383
1384
1385
1386 PP(pp_aassign)
1387 {
1388     dVAR; dSP;
1389     SV **lastlelem = PL_stack_sp;
1390     SV **lastrelem = PL_stack_base + POPMARK;
1391     SV **firstrelem = PL_stack_base + POPMARK + 1;
1392     SV **firstlelem = lastrelem + 1;
1393
1394     SV **relem;
1395     SV **lelem;
1396     U8 gimme;
1397     /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
1398      * only need to save locally, not on the save stack */
1399     U16 old_delaymagic = PL_delaymagic;
1400 #ifdef DEBUGGING
1401     bool fake = 0;
1402 #endif
1403
1404     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1405
1406     /* If there's a common identifier on both sides we have to take
1407      * special care that assigning the identifier on the left doesn't
1408      * clobber a value on the right that's used later in the list.
1409      */
1410
1411     /* at least 2 LH and RH elements, or commonality isn't an issue */
1412     if (firstlelem < lastlelem && firstrelem < lastrelem) {
1413         for (relem = firstrelem+1; relem <= lastrelem; relem++) {
1414             if (SvGMAGICAL(*relem))
1415                 goto do_scan;
1416         }
1417         for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1418             if (*lelem && SvSMAGICAL(*lelem))
1419                 goto do_scan;
1420         }
1421         if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
1422             if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1423                 /* skip the scan if all scalars have a ref count of 1 */
1424                 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1425                     SV *sv = *lelem;
1426                     if (!sv || SvREFCNT(sv) == 1)
1427                         continue;
1428                     if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1429                         goto do_scan;
1430                     break;
1431                 }
1432             }
1433             else {
1434             do_scan:
1435                 S_aassign_copy_common(aTHX_
1436                                       firstlelem, lastlelem, firstrelem, lastrelem
1437 #ifdef DEBUGGING
1438                     , fake
1439 #endif
1440                 );
1441             }
1442         }
1443     }
1444 #ifdef DEBUGGING
1445     else {
1446         /* on debugging builds, do the scan even if we've concluded we
1447          * don't need to, then panic if we find commonality. Note that the
1448          * scanner assumes at least 2 elements */
1449         if (firstlelem < lastlelem && firstrelem < lastrelem) {
1450             fake = 1;
1451             goto do_scan;
1452         }
1453     }
1454 #endif
1455
1456     gimme = GIMME_V;
1457     relem = firstrelem;
1458     lelem = firstlelem;
1459
1460     if (relem > lastrelem)
1461         goto no_relems;
1462
1463     /* first lelem loop while there are still relems */
1464     while (LIKELY(lelem <= lastlelem)) {
1465         bool alias = FALSE;
1466         SV *lsv = *lelem++;
1467
1468         TAINT_NOT; /* Each item stands on its own, taintwise. */
1469
1470         assert(relem <= lastrelem);
1471         if (UNLIKELY(!lsv)) {
1472             alias = TRUE;
1473             lsv = *lelem++;
1474             ASSUME(SvTYPE(lsv) == SVt_PVAV);
1475         }
1476
1477         switch (SvTYPE(lsv)) {
1478         case SVt_PVAV: {
1479             SV **svp;
1480             SSize_t i;
1481             SSize_t tmps_base;
1482             SSize_t nelems = lastrelem - relem + 1;
1483             AV *ary = MUTABLE_AV(lsv);
1484
1485             /* Assigning to an aggregate is tricky. First there is the
1486              * issue of commonality, e.g. @a = ($a[0]). Since the
1487              * stack isn't refcounted, clearing @a prior to storing
1488              * elements will free $a[0]. Similarly with
1489              *    sub FETCH { $status[$_[1]] } @status = @tied[0,1];
1490              *
1491              * The way to avoid these issues is to make the copy of each
1492              * SV (and we normally store a *copy* in the array) *before*
1493              * clearing the array. But this has a problem in that
1494              * if the code croaks during copying, the not-yet-stored copies
1495              * could leak. One way to avoid this is to make all the copies
1496              * mortal, but that's quite expensive.
1497              *
1498              * The current solution to these issues is to use a chunk
1499              * of the tmps stack as a temporary refcounted-stack. SVs
1500              * will be put on there during processing to avoid leaks,
1501              * but will be removed again before the end of this block,
1502              * so free_tmps() is never normally called. Also, the
1503              * sv_refcnt of the SVs doesn't have to be manipulated, since
1504              * the ownership of 1 reference count is transferred directly
1505              * from the tmps stack to the AV when the SV is stored.
1506              *
1507              * We disarm slots in the temps stack by storing PL_sv_undef
1508              * there: it doesn't matter if that SV's refcount is
1509              * repeatedly decremented during a croak. But usually this is
1510              * only an interim measure. By the end of this code block
1511              * we try where possible to not leave any PL_sv_undef's on the
1512              * tmps stack e.g. by shuffling newer entries down.
1513              *
1514              * There is one case where we don't copy: non-magical
1515              * SvTEMP(sv)'s with a ref count of 1. The only owner of these
1516              * is on the tmps stack, so its safe to directly steal the SV
1517              * rather than copying. This is common in things like function
1518              * returns, map etc, which all return a list of such SVs.
1519              *
1520              * Note however something like @a = (f())[0,0], where there is
1521              * a danger of the same SV being shared:  this avoided because
1522              * when the SV is stored as $a[0], its ref count gets bumped,
1523              * so the RC==1 test fails and the second element is copied
1524              * instead.
1525              *
1526              * We also use one slot in the tmps stack to hold an extra
1527              * ref to the array, to ensure it doesn't get prematurely
1528              * freed. Again, this is removed before the end of this block.
1529              *
1530              * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
1531              * @a = ($a[0]) case, but the current implementation uses the
1532              * same algorithm regardless, so ignores that flag. (It *is*
1533              * used in the hash branch below, however).
1534             */
1535
1536             /* Reserve slots for ary, plus the elems we're about to copy,
1537              * then protect ary and temporarily void the remaining slots
1538              * with &PL_sv_undef */
1539             EXTEND_MORTAL(nelems + 1);
1540             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
1541             tmps_base = PL_tmps_ix + 1;
1542             for (i = 0; i < nelems; i++)
1543                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1544             PL_tmps_ix += nelems;
1545
1546             /* Make a copy of each RHS elem and save on the tmps_stack
1547              * (or pass through where we can optimise away the copy) */
1548
1549             if (UNLIKELY(alias)) {
1550                 U32 lval = (gimme == G_ARRAY)
1551                                 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1552                 for (svp = relem; svp <= lastrelem; svp++) {
1553                     SV *rsv = *svp;
1554
1555                     SvGETMAGIC(rsv);
1556                     if (!SvROK(rsv))
1557                         DIE(aTHX_ "Assigned value is not a reference");
1558                     if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
1559                    /* diag_listed_as: Assigned value is not %s reference */
1560                         DIE(aTHX_
1561                            "Assigned value is not a SCALAR reference");
1562                     if (lval)
1563                         *svp = rsv = sv_mortalcopy(rsv);
1564                     /* XXX else check for weak refs?  */
1565                     rsv = SvREFCNT_inc_NN(SvRV(rsv));
1566                     assert(tmps_base <= PL_tmps_max);
1567                     PL_tmps_stack[tmps_base++] = rsv;
1568                 }
1569             }
1570             else {
1571                 for (svp = relem; svp <= lastrelem; svp++) {
1572                     SV *rsv = *svp;
1573
1574                     if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1575                         /* can skip the copy */
1576                         SvREFCNT_inc_simple_void_NN(rsv);
1577                         SvTEMP_off(rsv);
1578                     }
1579                     else {
1580                         SV *nsv;
1581                         /* do get before newSV, in case it dies and leaks */
1582                         SvGETMAGIC(rsv);
1583                         nsv = newSV(0);
1584                         /* see comment in S_aassign_copy_common about
1585                          * SV_NOSTEAL */
1586                         sv_setsv_flags(nsv, rsv,
1587                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1588                         rsv = *svp = nsv;
1589                     }
1590
1591                     assert(tmps_base <= PL_tmps_max);
1592                     PL_tmps_stack[tmps_base++] = rsv;
1593                 }
1594             }
1595
1596             if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
1597                 av_clear(ary);
1598
1599             /* store in the array, the SVs that are in the tmps stack */
1600
1601             tmps_base -= nelems;
1602
1603             if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
1604                 /* for arrays we can't cheat with, use the official API */
1605                 av_extend(ary, nelems - 1);
1606                 for (i = 0; i < nelems; i++) {
1607                     SV **svp = &(PL_tmps_stack[tmps_base + i]);
1608                     SV *rsv = *svp;
1609                     /* A tied store won't take ownership of rsv, so keep
1610                      * the 1 refcnt on the tmps stack; otherwise disarm
1611                      * the tmps stack entry */
1612                     if (av_store(ary, i, rsv))
1613                         *svp = &PL_sv_undef;
1614                     /* av_store() may have added set magic to rsv */;
1615                     SvSETMAGIC(rsv);
1616                 }
1617                 /* disarm ary refcount: see comments below about leak */
1618                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1619             }
1620             else {
1621                 /* directly access/set the guts of the AV */
1622                 SSize_t fill = nelems - 1;
1623                 if (fill > AvMAX(ary))
1624                     av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
1625                                     &AvARRAY(ary));
1626                 AvFILLp(ary) = fill;
1627                 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
1628                 /* Quietly remove all the SVs from the tmps stack slots,
1629                  * since ary has now taken ownership of the refcnt.
1630                  * Also remove ary: which will now leak if we die before
1631                  * the SvREFCNT_dec_NN(ary) below */
1632                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1633                     Move(&PL_tmps_stack[tmps_base + nelems],
1634                          &PL_tmps_stack[tmps_base - 1],
1635                          PL_tmps_ix - (tmps_base + nelems) + 1,
1636                          SV*);
1637                 PL_tmps_ix -= (nelems + 1);
1638             }
1639
1640             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1641                 /* its assumed @ISA set magic can't die and leak ary */
1642                 SvSETMAGIC(MUTABLE_SV(ary));
1643             SvREFCNT_dec_NN(ary);
1644
1645             relem = lastrelem + 1;
1646             goto no_relems;
1647         }
1648
1649         case SVt_PVHV: {                                /* normal hash */
1650
1651             SV **svp;
1652             bool dirty_tmps;
1653             SSize_t i;
1654             SSize_t tmps_base;
1655             SSize_t nelems = lastrelem - relem + 1;
1656             HV *hash = MUTABLE_HV(lsv);
1657
1658             if (UNLIKELY(nelems & 1)) {
1659                 do_oddball(lastrelem, relem);
1660                 /* we have firstlelem to reuse, it's not needed any more */
1661                 *++lastrelem = &PL_sv_undef;
1662                 nelems++;
1663             }
1664
1665             /* See the SVt_PVAV branch above for a long description of
1666              * how the following all works. The main difference for hashes
1667              * is that we treat keys and values separately (and have
1668              * separate loops for them): as for arrays, values are always
1669              * copied (except for the SvTEMP optimisation), since they
1670              * need to be stored in the hash; while keys are only
1671              * processed where they might get prematurely freed or
1672              * whatever. */
1673
1674             /* tmps stack slots:
1675              * * reserve a slot for the hash keepalive;
1676              * * reserve slots for the hash values we're about to copy;
1677              * * preallocate for the keys we'll possibly copy or refcount bump
1678              *   later;
1679              * then protect hash and temporarily void the remaining
1680              * value slots with &PL_sv_undef */
1681             EXTEND_MORTAL(nelems + 1);
1682
1683              /* convert to number of key/value pairs */
1684              nelems >>= 1;
1685
1686             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
1687             tmps_base = PL_tmps_ix + 1;
1688             for (i = 0; i < nelems; i++)
1689                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1690             PL_tmps_ix += nelems;
1691
1692             /* Make a copy of each RHS hash value and save on the tmps_stack
1693              * (or pass through where we can optimise away the copy) */
1694
1695             for (svp = relem + 1; svp <= lastrelem; svp += 2) {
1696                 SV *rsv = *svp;
1697
1698                 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1699                     /* can skip the copy */
1700                     SvREFCNT_inc_simple_void_NN(rsv);
1701                     SvTEMP_off(rsv);
1702                 }
1703                 else {
1704                     SV *nsv;
1705                     /* do get before newSV, in case it dies and leaks */
1706                     SvGETMAGIC(rsv);
1707                     nsv = newSV(0);
1708                     /* see comment in S_aassign_copy_common about
1709                      * SV_NOSTEAL */
1710                     sv_setsv_flags(nsv, rsv,
1711                             (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1712                     rsv = *svp = nsv;
1713                 }
1714
1715                 assert(tmps_base <= PL_tmps_max);
1716                 PL_tmps_stack[tmps_base++] = rsv;
1717             }
1718             tmps_base -= nelems;
1719
1720
1721             /* possibly protect keys */
1722
1723             if (UNLIKELY(gimme == G_ARRAY)) {
1724                 /* handle e.g.
1725                 *     @a = ((%h = ($$r, 1)), $r = "x");
1726                 *     $_++ for %h = (1,2,3,4);
1727                 */
1728                 EXTEND_MORTAL(nelems);
1729                 for (svp = relem; svp <= lastrelem; svp += 2)
1730                     *svp = sv_mortalcopy_flags(*svp,
1731                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1732             }
1733             else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
1734                 /* for possible commonality, e.g.
1735                  *       %h = ($h{a},1)
1736                  * avoid premature freeing RHS keys by mortalising
1737                  * them.
1738                  * For a magic element, make a copy so that its magic is
1739                  * called *before* the hash is emptied (which may affect
1740                  * a tied value for example).
1741                  * In theory we should check for magic keys in all
1742                  * cases, not just under OPpASSIGN_COMMON_AGG, but in
1743                  * practice, !OPpASSIGN_COMMON_AGG implies only
1744                  * constants or padtmps on the RHS.
1745                  */
1746                 EXTEND_MORTAL(nelems);
1747                 for (svp = relem; svp <= lastrelem; svp += 2) {
1748                     SV *rsv = *svp;
1749                     if (UNLIKELY(SvGMAGICAL(rsv))) {
1750                         SSize_t n;
1751                         *svp = sv_mortalcopy_flags(*svp,
1752                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1753                         /* allow other branch to continue pushing
1754                          * onto tmps stack without checking each time */
1755                         n = (lastrelem - relem) >> 1;
1756                         EXTEND_MORTAL(n);
1757                     }
1758                     else
1759                         PL_tmps_stack[++PL_tmps_ix] =
1760                                     SvREFCNT_inc_simple_NN(rsv);
1761                 }
1762             }
1763
1764             if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
1765                 hv_clear(hash);
1766
1767             /* now assign the keys and values to the hash */
1768
1769             dirty_tmps = FALSE;
1770
1771             if (UNLIKELY(gimme == G_ARRAY)) {
1772                 /* @a = (%h = (...)) etc */
1773                 SV **svp;
1774                 SV **topelem = relem;
1775
1776                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1777                     SV *key = *svp++;
1778                     SV *val = *svp;
1779                     /* remove duplicates from list we return */
1780                     if (!hv_exists_ent(hash, key, 0)) {
1781                         /* copy key back: possibly to an earlier
1782                          * stack location if we encountered dups earlier,
1783                          * The values will be updated later
1784                          */
1785                         *topelem = key;
1786                         topelem += 2;
1787                     }
1788                     /* A tied store won't take ownership of val, so keep
1789                      * the 1 refcnt on the tmps stack; otherwise disarm
1790                      * the tmps stack entry */
1791                     if (hv_store_ent(hash, key, val, 0))
1792                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1793                     else
1794                         dirty_tmps = TRUE;
1795                     /* hv_store_ent() may have added set magic to val */;
1796                     SvSETMAGIC(val);
1797                 }
1798                 if (topelem < svp) {
1799                     /* at this point we have removed the duplicate key/value
1800                      * pairs from the stack, but the remaining values may be
1801                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1802                      * the (a 2), but the stack now probably contains
1803                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1804                      * obliterates the earlier key. So refresh all values. */
1805                     lastrelem = topelem - 1;
1806                     while (relem < lastrelem) {
1807                         HE *he;
1808                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1809                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1810                     }
1811                 }
1812             }
1813             else {
1814                 SV **svp;
1815                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1816                     SV *key = *svp++;
1817                     SV *val = *svp;
1818                     if (hv_store_ent(hash, key, val, 0))
1819                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1820                     else
1821                         dirty_tmps = TRUE;
1822                     /* hv_store_ent() may have added set magic to val */;
1823                     SvSETMAGIC(val);
1824                 }
1825             }
1826
1827             if (dirty_tmps) {
1828                 /* there are still some 'live' recounts on the tmps stack
1829                  * - usually caused by storing into a tied hash. So let
1830                  * free_tmps() do the proper but slow job later.
1831                  * Just disarm hash refcount: see comments below about leak
1832                  */
1833                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1834             }
1835             else {
1836                 /* Quietly remove all the SVs from the tmps stack slots,
1837                  * since hash has now taken ownership of the refcnt.
1838                  * Also remove hash: which will now leak if we die before
1839                  * the SvREFCNT_dec_NN(hash) below */
1840                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1841                     Move(&PL_tmps_stack[tmps_base + nelems],
1842                          &PL_tmps_stack[tmps_base - 1],
1843                          PL_tmps_ix - (tmps_base + nelems) + 1,
1844                          SV*);
1845                 PL_tmps_ix -= (nelems + 1);
1846             }
1847
1848             SvREFCNT_dec_NN(hash);
1849
1850             relem = lastrelem + 1;
1851             goto no_relems;
1852         }
1853
1854         default:
1855             if (!SvIMMORTAL(lsv)) {
1856                 SV *ref;
1857
1858                 if (UNLIKELY(
1859                   SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
1860                   (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
1861                 ))
1862                     Perl_warner(aTHX_
1863                        packWARN(WARN_MISC),
1864                       "Useless assignment to a temporary"
1865                     );
1866
1867                 /* avoid freeing $$lsv if it might be needed for further
1868                  * elements, e.g. ($ref, $foo) = (1, $$ref) */
1869                 if (   SvROK(lsv)
1870                     && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
1871                     && lelem <= lastlelem
1872                 ) {
1873                     SSize_t ix;
1874                     SvREFCNT_inc_simple_void_NN(ref);
1875                     /* an unrolled sv_2mortal */
1876                     ix = ++PL_tmps_ix;
1877                     if (UNLIKELY(ix >= PL_tmps_max))
1878                         /* speculatively grow enough to cover other
1879                          * possible refs */
1880                          (void)tmps_grow_p(ix + (lastlelem - lelem));
1881                     PL_tmps_stack[ix] = ref;
1882                 }
1883
1884                 sv_setsv(lsv, *relem);
1885                 *relem = lsv;
1886                 SvSETMAGIC(lsv);
1887             }
1888             if (++relem > lastrelem)
1889                 goto no_relems;
1890             break;
1891         } /* switch */
1892     } /* while */
1893
1894
1895   no_relems:
1896
1897     /* simplified lelem loop for when there are no relems left */
1898     while (LIKELY(lelem <= lastlelem)) {
1899         SV *lsv = *lelem++;
1900
1901         TAINT_NOT; /* Each item stands on its own, taintwise. */
1902
1903         if (UNLIKELY(!lsv)) {
1904             lsv = *lelem++;
1905             ASSUME(SvTYPE(lsv) == SVt_PVAV);
1906         }
1907
1908         switch (SvTYPE(lsv)) {
1909         case SVt_PVAV:
1910             if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
1911                 av_clear((AV*)lsv);
1912                 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1913                     SvSETMAGIC(lsv);
1914             }
1915             break;
1916
1917         case SVt_PVHV:
1918             if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
1919                 hv_clear((HV*)lsv);
1920             break;
1921
1922         default:
1923             if (!SvIMMORTAL(lsv)) {
1924                 sv_set_undef(lsv);
1925                 SvSETMAGIC(lsv);
1926                 *relem++ = lsv;
1927             }
1928             break;
1929         } /* switch */
1930     } /* while */
1931
1932     TAINT_NOT; /* result of list assign isn't tainted */
1933
1934     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1935         /* Will be used to set PL_tainting below */
1936         Uid_t tmp_uid  = PerlProc_getuid();
1937         Uid_t tmp_euid = PerlProc_geteuid();
1938         Gid_t tmp_gid  = PerlProc_getgid();
1939         Gid_t tmp_egid = PerlProc_getegid();
1940
1941         /* XXX $> et al currently silently ignore failures */
1942         if (PL_delaymagic & DM_UID) {
1943 #ifdef HAS_SETRESUID
1944             PERL_UNUSED_RESULT(
1945                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1946                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1947                          (Uid_t)-1));
1948 #else
1949 #  ifdef HAS_SETREUID
1950             PERL_UNUSED_RESULT(
1951                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1952                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1953 #  else
1954 #    ifdef HAS_SETRUID
1955             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1956                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1957                 PL_delaymagic &= ~DM_RUID;
1958             }
1959 #    endif /* HAS_SETRUID */
1960 #    ifdef HAS_SETEUID
1961             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1962                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1963                 PL_delaymagic &= ~DM_EUID;
1964             }
1965 #    endif /* HAS_SETEUID */
1966             if (PL_delaymagic & DM_UID) {
1967                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1968                     DIE(aTHX_ "No setreuid available");
1969                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1970             }
1971 #  endif /* HAS_SETREUID */
1972 #endif /* HAS_SETRESUID */
1973
1974             tmp_uid  = PerlProc_getuid();
1975             tmp_euid = PerlProc_geteuid();
1976         }
1977         /* XXX $> et al currently silently ignore failures */
1978         if (PL_delaymagic & DM_GID) {
1979 #ifdef HAS_SETRESGID
1980             PERL_UNUSED_RESULT(
1981                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1982                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1983                           (Gid_t)-1));
1984 #else
1985 #  ifdef HAS_SETREGID
1986             PERL_UNUSED_RESULT(
1987                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1988                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1989 #  else
1990 #    ifdef HAS_SETRGID
1991             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1992                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1993                 PL_delaymagic &= ~DM_RGID;
1994             }
1995 #    endif /* HAS_SETRGID */
1996 #    ifdef HAS_SETEGID
1997             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1998                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1999                 PL_delaymagic &= ~DM_EGID;
2000             }
2001 #    endif /* HAS_SETEGID */
2002             if (PL_delaymagic & DM_GID) {
2003                 if (PL_delaymagic_gid != PL_delaymagic_egid)
2004                     DIE(aTHX_ "No setregid available");
2005                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
2006             }
2007 #  endif /* HAS_SETREGID */
2008 #endif /* HAS_SETRESGID */
2009
2010             tmp_gid  = PerlProc_getgid();
2011             tmp_egid = PerlProc_getegid();
2012         }
2013         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
2014 #ifdef NO_TAINT_SUPPORT
2015         PERL_UNUSED_VAR(tmp_uid);
2016         PERL_UNUSED_VAR(tmp_euid);
2017         PERL_UNUSED_VAR(tmp_gid);
2018         PERL_UNUSED_VAR(tmp_egid);
2019 #endif
2020     }
2021     PL_delaymagic = old_delaymagic;
2022
2023     if (gimme == G_VOID)
2024         SP = firstrelem - 1;
2025     else if (gimme == G_SCALAR) {
2026         SP = firstrelem;
2027         EXTEND(SP,1);
2028         if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2029             SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2030         else {
2031             dTARGET;
2032             SETi(firstlelem - firstrelem);
2033         }
2034     }
2035     else
2036         SP = relem - 1;
2037
2038     RETURN;
2039 }
2040
2041 PP(pp_qr)
2042 {
2043     dSP;
2044     PMOP * const pm = cPMOP;
2045     REGEXP * rx = PM_GETRE(pm);
2046     regexp *prog = ReANY(rx);
2047     SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
2048     SV * const rv = sv_newmortal();
2049     CV **cvp;
2050     CV *cv;
2051
2052     SvUPGRADE(rv, SVt_IV);
2053     /* For a subroutine describing itself as "This is a hacky workaround" I'm
2054        loathe to use it here, but it seems to be the right fix. Or close.
2055        The key part appears to be that it's essential for pp_qr to return a new
2056        object (SV), which implies that there needs to be an effective way to
2057        generate a new SV from the existing SV that is pre-compiled in the
2058        optree.  */
2059     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
2060     SvROK_on(rv);
2061
2062     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
2063     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
2064         *cvp = cv_clone(cv);
2065         SvREFCNT_dec_NN(cv);
2066     }
2067
2068     if (pkg) {
2069         HV *const stash = gv_stashsv(pkg, GV_ADD);
2070         SvREFCNT_dec_NN(pkg);
2071         (void)sv_bless(rv, stash);
2072     }
2073
2074     if (UNLIKELY(RXp_ISTAINTED(prog))) {
2075         SvTAINTED_on(rv);
2076         SvTAINTED_on(SvRV(rv));
2077     }
2078     XPUSHs(rv);
2079     RETURN;
2080 }
2081
2082 PP(pp_match)
2083 {
2084     dSP; dTARG;
2085     PMOP *pm = cPMOP;
2086     PMOP *dynpm = pm;
2087     const char *s;
2088     const char *strend;
2089     SSize_t curpos = 0; /* initial pos() or current $+[0] */
2090     I32 global;
2091     U8 r_flags = 0;
2092     const char *truebase;                       /* Start of string  */
2093     REGEXP *rx = PM_GETRE(pm);
2094     regexp *prog = ReANY(rx);
2095     bool rxtainted;
2096     const U8 gimme = GIMME_V;
2097     STRLEN len;
2098     const I32 oldsave = PL_savestack_ix;
2099     I32 had_zerolen = 0;
2100     MAGIC *mg = NULL;
2101
2102     if (PL_op->op_flags & OPf_STACKED)
2103         TARG = POPs;
2104     else {
2105         if (ARGTARG)
2106             GETTARGET;
2107         else {
2108             TARG = DEFSV;
2109         }
2110         EXTEND(SP,1);
2111     }
2112
2113     PUTBACK;                            /* EVAL blocks need stack_sp. */
2114     /* Skip get-magic if this is a qr// clone, because regcomp has
2115        already done it. */
2116     truebase = prog->mother_re
2117          ? SvPV_nomg_const(TARG, len)
2118          : SvPV_const(TARG, len);
2119     if (!truebase)
2120         DIE(aTHX_ "panic: pp_match");
2121     strend = truebase + len;
2122     rxtainted = (RXp_ISTAINTED(prog) ||
2123                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
2124     TAINT_NOT;
2125
2126     /* We need to know this in case we fail out early - pos() must be reset */
2127     global = dynpm->op_pmflags & PMf_GLOBAL;
2128
2129     /* PMdf_USED is set after a ?? matches once */
2130     if (
2131 #ifdef USE_ITHREADS
2132         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2133 #else
2134         pm->op_pmflags & PMf_USED
2135 #endif
2136     ) {
2137         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
2138         goto nope;
2139     }
2140
2141     /* handle the empty pattern */
2142     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
2143         if (PL_curpm == PL_reg_curpm) {
2144             if (PL_curpm_under) {
2145                 if (PL_curpm_under == PL_reg_curpm) {
2146                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2147                 } else {
2148                     pm = PL_curpm_under;
2149                 }
2150             }
2151         } else {
2152             pm = PL_curpm;
2153         }
2154         rx = PM_GETRE(pm);
2155         prog = ReANY(rx);
2156     }
2157
2158     if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
2159         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
2160                                               UVuf " < %" IVdf ")\n",
2161                                               (UV)len, (IV)RXp_MINLEN(prog)));
2162         goto nope;
2163     }
2164
2165     /* get pos() if //g */
2166     if (global) {
2167         mg = mg_find_mglob(TARG);
2168         if (mg && mg->mg_len >= 0) {
2169             curpos = MgBYTEPOS(mg, TARG, truebase, len);
2170             /* last time pos() was set, it was zero-length match */
2171             if (mg->mg_flags & MGf_MINMATCH)
2172                 had_zerolen = 1;
2173         }
2174     }
2175
2176 #ifdef PERL_SAWAMPERSAND
2177     if (       RXp_NPARENS(prog)
2178             || PL_sawampersand
2179             || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2180             || (dynpm->op_pmflags & PMf_KEEPCOPY)
2181     )
2182 #endif
2183     {
2184         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
2185         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
2186          * only on the first iteration. Therefore we need to copy $' as well
2187          * as $&, to make the rest of the string available for captures in
2188          * subsequent iterations */
2189         if (! (global && gimme == G_ARRAY))
2190             r_flags |= REXEC_COPY_SKIP_POST;
2191     };
2192 #ifdef PERL_SAWAMPERSAND
2193     if (dynpm->op_pmflags & PMf_KEEPCOPY)
2194         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
2195         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
2196 #endif
2197
2198     s = truebase;
2199
2200   play_it_again:
2201     if (global)
2202         s = truebase + curpos;
2203
2204     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
2205                      had_zerolen, TARG, NULL, r_flags))
2206         goto nope;
2207
2208     PL_curpm = pm;
2209     if (dynpm->op_pmflags & PMf_ONCE)
2210 #ifdef USE_ITHREADS
2211         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
2212 #else
2213         dynpm->op_pmflags |= PMf_USED;
2214 #endif
2215
2216     if (rxtainted)
2217         RXp_MATCH_TAINTED_on(prog);
2218     TAINT_IF(RXp_MATCH_TAINTED(prog));
2219
2220     /* update pos */
2221
2222     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
2223         if (!mg)
2224             mg = sv_magicext_mglob(TARG);
2225         MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
2226         if (RXp_ZERO_LEN(prog))
2227             mg->mg_flags |= MGf_MINMATCH;
2228         else
2229             mg->mg_flags &= ~MGf_MINMATCH;
2230     }
2231
2232     if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
2233         LEAVE_SCOPE(oldsave);
2234         RETPUSHYES;
2235     }
2236
2237     /* push captures on stack */
2238
2239     {
2240         const I32 nparens = RXp_NPARENS(prog);
2241         I32 i = (global && !nparens) ? 1 : 0;
2242
2243         SPAGAIN;                        /* EVAL blocks could move the stack. */
2244         EXTEND(SP, nparens + i);
2245         EXTEND_MORTAL(nparens + i);
2246         for (i = !i; i <= nparens; i++) {
2247             PUSHs(sv_newmortal());
2248             if (LIKELY((RXp_OFFS(prog)[i].start != -1)
2249                      && RXp_OFFS(prog)[i].end   != -1 ))
2250             {
2251                 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
2252                 const char * const s = RXp_OFFS(prog)[i].start + truebase;
2253                 if (UNLIKELY(  RXp_OFFS(prog)[i].end   < 0
2254                             || RXp_OFFS(prog)[i].start < 0
2255                             || len < 0
2256                             || len > strend - s)
2257                 )
2258                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
2259                         "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
2260                         (long) i, (long) RXp_OFFS(prog)[i].start,
2261                         (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
2262                 sv_setpvn(*SP, s, len);
2263                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
2264                     SvUTF8_on(*SP);
2265             }
2266         }
2267         if (global) {
2268             curpos = (UV)RXp_OFFS(prog)[0].end;
2269             had_zerolen = RXp_ZERO_LEN(prog);
2270             PUTBACK;                    /* EVAL blocks may use stack */
2271             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2272             goto play_it_again;
2273         }
2274         LEAVE_SCOPE(oldsave);
2275         RETURN;
2276     }
2277     NOT_REACHED; /* NOTREACHED */
2278
2279   nope:
2280     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
2281         if (!mg)
2282             mg = mg_find_mglob(TARG);
2283         if (mg)
2284             mg->mg_len = -1;
2285     }
2286     LEAVE_SCOPE(oldsave);
2287     if (gimme == G_ARRAY)
2288         RETURN;
2289     RETPUSHNO;
2290 }
2291
2292 OP *
2293 Perl_do_readline(pTHX)
2294 {
2295     dSP; dTARGETSTACKED;
2296     SV *sv;
2297     STRLEN tmplen = 0;
2298     STRLEN offset;
2299     PerlIO *fp;
2300     IO * const io = GvIO(PL_last_in_gv);
2301     const I32 type = PL_op->op_type;
2302     const U8 gimme = GIMME_V;
2303
2304     if (io) {
2305         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2306         if (mg) {
2307             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
2308             if (gimme == G_SCALAR) {
2309                 SPAGAIN;
2310                 SvSetSV_nosteal(TARG, TOPs);
2311                 SETTARG;
2312             }
2313             return NORMAL;
2314         }
2315     }
2316     fp = NULL;
2317     if (io) {
2318         fp = IoIFP(io);
2319         if (!fp) {
2320             if (IoFLAGS(io) & IOf_ARGV) {
2321                 if (IoFLAGS(io) & IOf_START) {
2322                     IoLINES(io) = 0;
2323                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
2324                         IoFLAGS(io) &= ~IOf_START;
2325                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
2326                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
2327                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
2328                         SvSETMAGIC(GvSV(PL_last_in_gv));
2329                         fp = IoIFP(io);
2330                         goto have_fp;
2331                     }
2332                 }
2333                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2334                 if (!fp) { /* Note: fp != IoIFP(io) */
2335                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
2336                 }
2337             }
2338             else if (type == OP_GLOB)
2339                 fp = Perl_start_glob(aTHX_ POPs, io);
2340         }
2341         else if (type == OP_GLOB)
2342             SP--;
2343         else if (IoTYPE(io) == IoTYPE_WRONLY) {
2344             report_wrongway_fh(PL_last_in_gv, '>');
2345         }
2346     }
2347     if (!fp) {
2348         if ((!io || !(IoFLAGS(io) & IOf_START))
2349             && ckWARN(WARN_CLOSED)
2350             && type != OP_GLOB)
2351         {
2352             report_evil_fh(PL_last_in_gv);
2353         }
2354         if (gimme == G_SCALAR) {
2355             /* undef TARG, and push that undefined value */
2356             if (type != OP_RCATLINE) {
2357                 sv_set_undef(TARG);
2358             }
2359             PUSHTARG;
2360         }
2361         RETURN;
2362     }
2363   have_fp:
2364     if (gimme == G_SCALAR) {
2365         sv = TARG;
2366         if (type == OP_RCATLINE && SvGMAGICAL(sv))
2367             mg_get(sv);
2368         if (SvROK(sv)) {
2369             if (type == OP_RCATLINE)
2370                 SvPV_force_nomg_nolen(sv);
2371             else
2372                 sv_unref(sv);
2373         }
2374         else if (isGV_with_GP(sv)) {
2375             SvPV_force_nomg_nolen(sv);
2376         }
2377         SvUPGRADE(sv, SVt_PV);
2378         tmplen = SvLEN(sv);     /* remember if already alloced */
2379         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
2380             /* try short-buffering it. Please update t/op/readline.t
2381              * if you change the growth length.
2382              */
2383             Sv_Grow(sv, 80);
2384         }
2385         offset = 0;
2386         if (type == OP_RCATLINE && SvOK(sv)) {
2387             if (!SvPOK(sv)) {
2388                 SvPV_force_nomg_nolen(sv);
2389             }
2390             offset = SvCUR(sv);
2391         }
2392     }
2393     else {
2394         sv = sv_2mortal(newSV(80));
2395         offset = 0;
2396     }
2397
2398     /* This should not be marked tainted if the fp is marked clean */
2399 #define MAYBE_TAINT_LINE(io, sv) \
2400     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
2401         TAINT;                          \
2402         SvTAINTED_on(sv);               \
2403     }
2404
2405 /* delay EOF state for a snarfed empty file */
2406 #define SNARF_EOF(gimme,rs,io,sv) \
2407     (gimme != G_SCALAR || SvCUR(sv)                                     \
2408      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
2409
2410     for (;;) {
2411         PUTBACK;
2412         if (!sv_gets(sv, fp, offset)
2413             && (type == OP_GLOB
2414                 || SNARF_EOF(gimme, PL_rs, io, sv)
2415                 || PerlIO_error(fp)))
2416         {
2417             PerlIO_clearerr(fp);
2418             if (IoFLAGS(io) & IOf_ARGV) {
2419                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2420                 if (fp)
2421                     continue;
2422                 (void)do_close(PL_last_in_gv, FALSE);
2423             }
2424             else if (type == OP_GLOB) {
2425                 if (!do_close(PL_last_in_gv, FALSE)) {
2426                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
2427                                    "glob failed (child exited with status %d%s)",
2428                                    (int)(STATUS_CURRENT >> 8),
2429                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
2430                 }
2431             }
2432             if (gimme == G_SCALAR) {
2433                 if (type != OP_RCATLINE) {
2434                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
2435                     SvOK_off(TARG);
2436                 }
2437                 SPAGAIN;
2438                 PUSHTARG;
2439             }
2440             MAYBE_TAINT_LINE(io, sv);
2441             RETURN;
2442         }
2443         MAYBE_TAINT_LINE(io, sv);
2444         IoLINES(io)++;
2445         IoFLAGS(io) |= IOf_NOLINE;
2446         SvSETMAGIC(sv);
2447         SPAGAIN;
2448         XPUSHs(sv);
2449         if (type == OP_GLOB) {
2450             const char *t1;
2451             Stat_t statbuf;
2452
2453             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
2454                 char * const tmps = SvEND(sv) - 1;
2455                 if (*tmps == *SvPVX_const(PL_rs)) {
2456                     *tmps = '\0';
2457                     SvCUR_set(sv, SvCUR(sv) - 1);
2458                 }
2459             }
2460             for (t1 = SvPVX_const(sv); *t1; t1++)
2461 #ifdef __VMS
2462                 if (strchr("*%?", *t1))
2463 #else
2464                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
2465 #endif
2466                         break;
2467             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
2468                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
2469                 continue;
2470             }
2471         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
2472              if (ckWARN(WARN_UTF8)) {
2473                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
2474                 const STRLEN len = SvCUR(sv) - offset;
2475                 const U8 *f;
2476
2477                 if (!is_utf8_string_loc(s, len, &f))
2478                     /* Emulate :encoding(utf8) warning in the same case. */
2479                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
2480                                 "utf8 \"\\x%02X\" does not map to Unicode",
2481                                 f < (U8*)SvEND(sv) ? *f : 0);
2482              }
2483         }
2484         if (gimme == G_ARRAY) {
2485             if (SvLEN(sv) - SvCUR(sv) > 20) {
2486                 SvPV_shrink_to_cur(sv);
2487             }
2488             sv = sv_2mortal(newSV(80));
2489             continue;
2490         }
2491         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2492             /* try to reclaim a bit of scalar space (only on 1st alloc) */
2493             const STRLEN new_len
2494                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2495             SvPV_renew(sv, new_len);
2496         }
2497         RETURN;
2498     }
2499 }
2500
2501 PP(pp_helem)
2502 {
2503     dSP;
2504     HE* he;
2505     SV **svp;
2506     SV * const keysv = POPs;
2507     HV * const hv = MUTABLE_HV(POPs);
2508     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2509     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2510     SV *sv;
2511     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2512     bool preeminent = TRUE;
2513
2514     if (SvTYPE(hv) != SVt_PVHV)
2515         RETPUSHUNDEF;
2516
2517     if (localizing) {
2518         MAGIC *mg;
2519         HV *stash;
2520
2521         /* If we can determine whether the element exist,
2522          * Try to preserve the existenceness of a tied hash
2523          * element by using EXISTS and DELETE if possible.
2524          * Fallback to FETCH and STORE otherwise. */
2525         if (SvCANEXISTDELETE(hv))
2526             preeminent = hv_exists_ent(hv, keysv, 0);
2527     }
2528
2529     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2530     svp = he ? &HeVAL(he) : NULL;
2531     if (lval) {
2532         if (!svp || !*svp || *svp == &PL_sv_undef) {
2533             SV* lv;
2534             SV* key2;
2535             if (!defer) {
2536                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2537             }
2538             lv = sv_newmortal();
2539             sv_upgrade(lv, SVt_PVLV);
2540             LvTYPE(lv) = 'y';
2541             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2542             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
2543             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2544             LvTARGLEN(lv) = 1;
2545             PUSHs(lv);
2546             RETURN;
2547         }
2548         if (localizing) {
2549             if (HvNAME_get(hv) && isGV(*svp))
2550                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2551             else if (preeminent)
2552                 save_helem_flags(hv, keysv, svp,
2553                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2554             else
2555                 SAVEHDELETE(hv, keysv);
2556         }
2557         else if (PL_op->op_private & OPpDEREF) {
2558             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2559             RETURN;
2560         }
2561     }
2562     sv = (svp && *svp ? *svp : &PL_sv_undef);
2563     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2564      * was to make C<local $tied{foo} = $tied{foo}> possible.
2565      * However, it seems no longer to be needed for that purpose, and
2566      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2567      * would loop endlessly since the pos magic is getting set on the
2568      * mortal copy and lost. However, the copy has the effect of
2569      * triggering the get magic, and losing it altogether made things like
2570      * c<$tied{foo};> in void context no longer do get magic, which some
2571      * code relied on. Also, delayed triggering of magic on @+ and friends
2572      * meant the original regex may be out of scope by now. So as a
2573      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2574      * being called too many times). */
2575     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2576         mg_get(sv);
2577     PUSHs(sv);
2578     RETURN;
2579 }
2580
2581
2582 /* a stripped-down version of Perl_softref2xv() for use by
2583  * pp_multideref(), which doesn't use PL_op->op_flags */
2584
2585 STATIC GV *
2586 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2587                 const svtype type)
2588 {
2589     if (PL_op->op_private & HINT_STRICT_REFS) {
2590         if (SvOK(sv))
2591             Perl_die(aTHX_ PL_no_symref_sv, sv,
2592                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2593         else
2594             Perl_die(aTHX_ PL_no_usym, what);
2595     }
2596     if (!SvOK(sv))
2597         Perl_die(aTHX_ PL_no_usym, what);
2598     return gv_fetchsv_nomg(sv, GV_ADD, type);
2599 }
2600
2601
2602 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2603  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
2604  *
2605  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2606  * Each of these either contains a set of actions, or an argument, such as
2607  * an IV to use as an array index, or a lexical var to retrieve.
2608  * Several actions re stored per UV; we keep shifting new actions off the
2609  * one UV, and only reload when it becomes zero.
2610  */
2611
2612 PP(pp_multideref)
2613 {
2614     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2615     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2616     UV actions = items->uv;
2617
2618     assert(actions);
2619     /* this tells find_uninit_var() where we're up to */
2620     PL_multideref_pc = items;
2621
2622     while (1) {
2623         /* there are three main classes of action; the first retrieve
2624          * the initial AV or HV from a variable or the stack; the second
2625          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2626          * the third an unrolled (/DREFHV, rv2hv, helem).
2627          */
2628         switch (actions & MDEREF_ACTION_MASK) {
2629
2630         case MDEREF_reload:
2631             actions = (++items)->uv;
2632             continue;
2633
2634         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
2635             sv = PAD_SVl((++items)->pad_offset);
2636             goto do_AV_aelem;
2637
2638         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
2639             sv = UNOP_AUX_item_sv(++items);
2640             assert(isGV_with_GP(sv));
2641             sv = (SV*)GvAVn((GV*)sv);
2642             goto do_AV_aelem;
2643
2644         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
2645             {
2646                 dSP;
2647                 sv = POPs;
2648                 PUTBACK;
2649                 goto do_AV_rv2av_aelem;
2650             }
2651
2652         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
2653             sv = UNOP_AUX_item_sv(++items);
2654             assert(isGV_with_GP(sv));
2655             sv = GvSVn((GV*)sv);
2656             goto do_AV_vivify_rv2av_aelem;
2657
2658         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
2659             sv = PAD_SVl((++items)->pad_offset);
2660             /* FALLTHROUGH */
2661
2662         do_AV_vivify_rv2av_aelem:
2663         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
2664             /* this is the OPpDEREF action normally found at the end of
2665              * ops like aelem, helem, rv2sv */
2666             sv = vivify_ref(sv, OPpDEREF_AV);
2667             /* FALLTHROUGH */
2668
2669         do_AV_rv2av_aelem:
2670             /* this is basically a copy of pp_rv2av when it just has the
2671              * sKR/1 flags */
2672             SvGETMAGIC(sv);
2673             if (LIKELY(SvROK(sv))) {
2674                 if (UNLIKELY(SvAMAGIC(sv))) {
2675                     sv = amagic_deref_call(sv, to_av_amg);
2676                 }
2677                 sv = SvRV(sv);
2678                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2679                     DIE(aTHX_ "Not an ARRAY reference");
2680             }
2681             else if (SvTYPE(sv) != SVt_PVAV) {
2682                 if (!isGV_with_GP(sv))
2683                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2684                 sv = MUTABLE_SV(GvAVn((GV*)sv));
2685             }
2686             /* FALLTHROUGH */
2687
2688         do_AV_aelem:
2689             {
2690                 /* retrieve the key; this may be either a lexical or package
2691                  * var (whose index/ptr is stored as an item) or a signed
2692                  * integer constant stored as an item.
2693                  */
2694                 SV *elemsv;
2695                 IV elem = 0; /* to shut up stupid compiler warnings */
2696
2697
2698                 assert(SvTYPE(sv) == SVt_PVAV);
2699
2700                 switch (actions & MDEREF_INDEX_MASK) {
2701                 case MDEREF_INDEX_none:
2702                     goto finish;
2703                 case MDEREF_INDEX_const:
2704                     elem  = (++items)->iv;
2705                     break;
2706                 case MDEREF_INDEX_padsv:
2707                     elemsv = PAD_SVl((++items)->pad_offset);
2708                     goto check_elem;
2709                 case MDEREF_INDEX_gvsv:
2710                     elemsv = UNOP_AUX_item_sv(++items);
2711                     assert(isGV_with_GP(elemsv));
2712                     elemsv = GvSVn((GV*)elemsv);
2713                 check_elem:
2714                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2715                                             && ckWARN(WARN_MISC)))
2716                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2717                                 "Use of reference \"%" SVf "\" as array index",
2718                                 SVfARG(elemsv));
2719                     /* the only time that S_find_uninit_var() needs this
2720                      * is to determine which index value triggered the
2721                      * undef warning. So just update it here. Note that
2722                      * since we don't save and restore this var (e.g. for
2723                      * tie or overload execution), its value will be
2724                      * meaningless apart from just here */
2725                     PL_multideref_pc = items;
2726                     elem = SvIV(elemsv);
2727                     break;
2728                 }
2729
2730
2731                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2732
2733                 if (!(actions & MDEREF_FLAG_last)) {
2734                     SV** svp = av_fetch((AV*)sv, elem, 1);
2735                     if (!svp || ! (sv=*svp))
2736                         DIE(aTHX_ PL_no_aelem, elem);
2737                     break;
2738                 }
2739
2740                 if (PL_op->op_private &
2741                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2742                 {
2743                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2744                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2745                     }
2746                     else {
2747                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2748                         sv = av_delete((AV*)sv, elem, discard);
2749                         if (discard)
2750                             return NORMAL;
2751                         if (!sv)
2752                             sv = &PL_sv_undef;
2753                     }
2754                 }
2755                 else {
2756                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2757                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2758                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2759                     bool preeminent = TRUE;
2760                     AV *const av = (AV*)sv;
2761                     SV** svp;
2762
2763                     if (UNLIKELY(localizing)) {
2764                         MAGIC *mg;
2765                         HV *stash;
2766
2767                         /* If we can determine whether the element exist,
2768                          * Try to preserve the existenceness of a tied array
2769                          * element by using EXISTS and DELETE if possible.
2770                          * Fallback to FETCH and STORE otherwise. */
2771                         if (SvCANEXISTDELETE(av))
2772                             preeminent = av_exists(av, elem);
2773                     }
2774
2775                     svp = av_fetch(av, elem, lval && !defer);
2776
2777                     if (lval) {
2778                         if (!svp || !(sv = *svp)) {
2779                             IV len;
2780                             if (!defer)
2781                                 DIE(aTHX_ PL_no_aelem, elem);
2782                             len = av_tindex(av);
2783                             sv = sv_2mortal(newSVavdefelem(av,
2784                             /* Resolve a negative index now, unless it points
2785                              * before the beginning of the array, in which
2786                              * case record it for error reporting in
2787                              * magic_setdefelem. */
2788                                 elem < 0 && len + elem >= 0
2789                                     ? len + elem : elem, 1));
2790                         }
2791                         else {
2792                             if (UNLIKELY(localizing)) {
2793                                 if (preeminent) {
2794                                     save_aelem(av, elem, svp);
2795                                     sv = *svp; /* may have changed */
2796                                 }
2797                                 else
2798                                     SAVEADELETE(av, elem);
2799                             }
2800                         }
2801                     }
2802                     else {
2803                         sv = (svp ? *svp : &PL_sv_undef);
2804                         /* see note in pp_helem() */
2805                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2806                             mg_get(sv);
2807                     }
2808                 }
2809
2810             }
2811           finish:
2812             {
2813                 dSP;
2814                 XPUSHs(sv);
2815                 RETURN;
2816             }
2817             /* NOTREACHED */
2818
2819
2820
2821
2822         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
2823             sv = PAD_SVl((++items)->pad_offset);
2824             goto do_HV_helem;
2825
2826         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
2827             sv = UNOP_AUX_item_sv(++items);
2828             assert(isGV_with_GP(sv));
2829             sv = (SV*)GvHVn((GV*)sv);
2830             goto do_HV_helem;
2831
2832         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
2833             {
2834                 dSP;
2835                 sv = POPs;
2836                 PUTBACK;
2837                 goto do_HV_rv2hv_helem;
2838             }
2839
2840         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
2841             sv = UNOP_AUX_item_sv(++items);
2842             assert(isGV_with_GP(sv));
2843             sv = GvSVn((GV*)sv);
2844             goto do_HV_vivify_rv2hv_helem;
2845
2846         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
2847             sv = PAD_SVl((++items)->pad_offset);
2848             /* FALLTHROUGH */
2849
2850         do_HV_vivify_rv2hv_helem:
2851         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
2852             /* this is the OPpDEREF action normally found at the end of
2853              * ops like aelem, helem, rv2sv */
2854             sv = vivify_ref(sv, OPpDEREF_HV);
2855             /* FALLTHROUGH */
2856
2857         do_HV_rv2hv_helem:
2858             /* this is basically a copy of pp_rv2hv when it just has the
2859              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2860
2861             SvGETMAGIC(sv);
2862             if (LIKELY(SvROK(sv))) {
2863                 if (UNLIKELY(SvAMAGIC(sv))) {
2864                     sv = amagic_deref_call(sv, to_hv_amg);
2865                 }
2866                 sv = SvRV(sv);
2867                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2868                     DIE(aTHX_ "Not a HASH reference");
2869             }
2870             else if (SvTYPE(sv) != SVt_PVHV) {
2871                 if (!isGV_with_GP(sv))
2872                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2873                 sv = MUTABLE_SV(GvHVn((GV*)sv));
2874             }
2875             /* FALLTHROUGH */
2876
2877         do_HV_helem:
2878             {
2879                 /* retrieve the key; this may be either a lexical / package
2880                  * var or a string constant, whose index/ptr is stored as an
2881                  * item
2882                  */
2883                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2884
2885                 assert(SvTYPE(sv) == SVt_PVHV);
2886
2887                 switch (actions & MDEREF_INDEX_MASK) {
2888                 case MDEREF_INDEX_none:
2889                     goto finish;
2890
2891                 case MDEREF_INDEX_const:
2892                     keysv = UNOP_AUX_item_sv(++items);
2893                     break;
2894
2895                 case MDEREF_INDEX_padsv:
2896                     keysv = PAD_SVl((++items)->pad_offset);
2897                     break;
2898
2899                 case MDEREF_INDEX_gvsv:
2900                     keysv = UNOP_AUX_item_sv(++items);
2901                     keysv = GvSVn((GV*)keysv);
2902                     break;
2903                 }
2904
2905                 /* see comment above about setting this var */
2906                 PL_multideref_pc = items;
2907
2908
2909                 /* ensure that candidate CONSTs have been HEKified */
2910                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2911                        || SvTYPE(keysv) >= SVt_PVMG
2912                        || !SvOK(keysv)
2913                        || SvROK(keysv)
2914                        || SvIsCOW_shared_hash(keysv));
2915
2916                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2917
2918                 if (!(actions & MDEREF_FLAG_last)) {
2919                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2920                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2921                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2922                     break;
2923                 }
2924
2925                 if (PL_op->op_private &
2926                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2927                 {
2928                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2929                         sv = hv_exists_ent((HV*)sv, keysv, 0)
2930                                                 ? &PL_sv_yes : &PL_sv_no;
2931                     }
2932                     else {
2933                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2934                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2935                         if (discard)
2936                             return NORMAL;
2937                         if (!sv)
2938                             sv = &PL_sv_undef;
2939                     }
2940                 }
2941                 else {
2942                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2943                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2944                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2945                     bool preeminent = TRUE;
2946                     SV **svp;
2947                     HV * const hv = (HV*)sv;
2948                     HE* he;
2949
2950                     if (UNLIKELY(localizing)) {
2951                         MAGIC *mg;
2952                         HV *stash;
2953
2954                         /* If we can determine whether the element exist,
2955                          * Try to preserve the existenceness of a tied hash
2956                          * element by using EXISTS and DELETE if possible.
2957                          * Fallback to FETCH and STORE otherwise. */
2958                         if (SvCANEXISTDELETE(hv))
2959                             preeminent = hv_exists_ent(hv, keysv, 0);
2960                     }
2961
2962                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2963                     svp = he ? &HeVAL(he) : NULL;
2964
2965
2966                     if (lval) {
2967                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2968                             SV* lv;
2969                             SV* key2;
2970                             if (!defer)
2971                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2972                             lv = sv_newmortal();
2973                             sv_upgrade(lv, SVt_PVLV);
2974                             LvTYPE(lv) = 'y';
2975                             sv_magic(lv, key2 = newSVsv(keysv),
2976                                                 PERL_MAGIC_defelem, NULL, 0);
2977                             /* sv_magic() increments refcount */
2978                             SvREFCNT_dec_NN(key2);
2979                             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2980                             LvTARGLEN(lv) = 1;
2981                             sv = lv;
2982                         }
2983                         else {
2984                             if (localizing) {
2985                                 if (HvNAME_get(hv) && isGV(sv))
2986                                     save_gp(MUTABLE_GV(sv),
2987                                         !(PL_op->op_flags & OPf_SPECIAL));
2988                                 else if (preeminent) {
2989                                     save_helem_flags(hv, keysv, svp,
2990                                          (PL_op->op_flags & OPf_SPECIAL)
2991                                             ? 0 : SAVEf_SETMAGIC);
2992                                     sv = *svp; /* may have changed */
2993                                 }
2994                                 else
2995                                     SAVEHDELETE(hv, keysv);
2996                             }
2997                         }
2998                     }
2999                     else {
3000                         sv = (svp && *svp ? *svp : &PL_sv_undef);
3001                         /* see note in pp_helem() */
3002                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
3003                             mg_get(sv);
3004                     }
3005                 }
3006                 goto finish;
3007             }
3008
3009         } /* switch */
3010
3011         actions >>= MDEREF_SHIFT;
3012     } /* while */
3013     /* NOTREACHED */
3014 }
3015
3016
3017 PP(pp_iter)
3018 {
3019     PERL_CONTEXT *cx;
3020     SV *oldsv;
3021     SV **itersvp;
3022
3023     SV *sv;
3024     AV *av;
3025     IV ix;
3026     IV inc;
3027
3028     cx = CX_CUR();
3029     itersvp = CxITERVAR(cx);
3030     assert(itersvp);
3031
3032     switch (CxTYPE(cx)) {
3033
3034     case CXt_LOOP_LAZYSV: /* string increment */
3035     {
3036         SV* cur = cx->blk_loop.state_u.lazysv.cur;
3037         SV *end = cx->blk_loop.state_u.lazysv.end;
3038         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
3039            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
3040         STRLEN maxlen = 0;
3041         const char *max = SvPV_const(end, maxlen);
3042         if (DO_UTF8(end) && IN_UNI_8_BIT)
3043             maxlen = sv_len_utf8_nomg(end);
3044         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
3045             goto retno;
3046
3047         oldsv = *itersvp;
3048         /* NB: on the first iteration, oldsv will have a ref count of at
3049          * least 2 (one extra from blk_loop.itersave), so the GV or pad
3050          * slot will get localised; on subsequent iterations the RC==1
3051          * optimisation may kick in and the SV will be reused. */
3052          if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3053             /* safe to reuse old SV */
3054             sv_setsv(oldsv, cur);
3055         }
3056         else
3057         {
3058             /* we need a fresh SV every time so that loop body sees a
3059              * completely new SV for closures/references to work as
3060              * they used to */
3061             *itersvp = newSVsv(cur);
3062             SvREFCNT_dec(oldsv);
3063         }
3064         if (strEQ(SvPVX_const(cur), max))
3065             sv_setiv(cur, 0); /* terminate next time */
3066         else
3067             sv_inc(cur);
3068         break;
3069     }
3070
3071     case CXt_LOOP_LAZYIV: /* integer increment */
3072     {
3073         IV cur = cx->blk_loop.state_u.lazyiv.cur;
3074         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
3075             goto retno;
3076
3077         oldsv = *itersvp;
3078         /* see NB comment above */
3079         if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3080             /* safe to reuse old SV */
3081
3082             if (    (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
3083                  == SVt_IV)
3084             {
3085                 /* Cheap SvIOK_only().
3086                  * Assert that flags which SvIOK_only() would test or
3087                  * clear can't be set, because we're SVt_IV */
3088                 assert(!(SvFLAGS(oldsv) &
3089                     (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
3090                 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
3091                 /* SvIV_set() where sv_any points to head */
3092                 oldsv->sv_u.svu_iv = cur;
3093
3094             }
3095             else
3096                 sv_setiv(oldsv, cur);
3097         }
3098         else
3099         {
3100             /* we need a fresh SV every time so that loop body sees a
3101              * completely new SV for closures/references to work as they
3102              * used to */
3103             *itersvp = newSViv(cur);
3104             SvREFCNT_dec(oldsv);
3105         }
3106
3107         if (UNLIKELY(cur == IV_MAX)) {
3108             /* Handle end of range at IV_MAX */
3109             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
3110         } else
3111             ++cx->blk_loop.state_u.lazyiv.cur;
3112         break;
3113     }
3114
3115     case CXt_LOOP_LIST: /* for (1,2,3) */
3116
3117         assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
3118         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3119         ix = (cx->blk_loop.state_u.stack.ix += inc);
3120         if (UNLIKELY(inc > 0
3121                         ? ix > cx->blk_oldsp
3122                         : ix <= cx->blk_loop.state_u.stack.basesp)
3123         )
3124             goto retno;
3125
3126         sv = PL_stack_base[ix];
3127         av = NULL;
3128         goto loop_ary_common;
3129
3130     case CXt_LOOP_ARY: /* for (@ary) */
3131
3132         av = cx->blk_loop.state_u.ary.ary;
3133         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3134         ix = (cx->blk_loop.state_u.ary.ix += inc);
3135         if (UNLIKELY(inc > 0
3136                         ? ix > AvFILL(av)
3137                         : ix < 0)
3138         )
3139             goto retno;
3140
3141         if (UNLIKELY(SvRMAGICAL(av))) {
3142             SV * const * const svp = av_fetch(av, ix, FALSE);
3143             sv = svp ? *svp : NULL;
3144         }
3145         else {
3146             sv = AvARRAY(av)[ix];
3147         }
3148
3149       loop_ary_common:
3150
3151         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
3152             SvSetMagicSV(*itersvp, sv);
3153             break;
3154         }
3155
3156         if (LIKELY(sv)) {
3157             if (UNLIKELY(SvIS_FREED(sv))) {
3158                 *itersvp = NULL;
3159                 Perl_croak(aTHX_ "Use of freed value in iteration");
3160             }
3161             if (SvPADTMP(sv)) {
3162                 sv = newSVsv(sv);
3163             }
3164             else {
3165                 SvTEMP_off(sv);
3166                 SvREFCNT_inc_simple_void_NN(sv);
3167             }
3168         }
3169         else if (av) {
3170             sv = newSVavdefelem(av, ix, 0);
3171         }
3172         else
3173             sv = &PL_sv_undef;
3174
3175         oldsv = *itersvp;
3176         *itersvp = sv;
3177         SvREFCNT_dec(oldsv);
3178         break;
3179
3180     default:
3181         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
3182     }
3183
3184     /* Bypass pushing &PL_sv_yes and calling pp_and(); instead
3185      * jump straight to the AND op's op_other */
3186     assert(PL_op->op_next->op_type == OP_AND);
3187     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
3188     return cLOGOPx(PL_op->op_next)->op_other;
3189
3190   retno:
3191     /* Bypass pushing &PL_sv_no and calling pp_and(); instead
3192      * jump straight to the AND op's op_next */
3193     assert(PL_op->op_next->op_type == OP_AND);
3194     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
3195     /* pp_enteriter should have pre-extended the stack */
3196     EXTEND_SKIP(PL_stack_sp, 1);
3197     /* we only need this for the rare case where the OP_AND isn't
3198      * in void context, e.g. $x = do { for (..) {...} };
3199      * but its cheaper to just push it rather than testing first
3200      */
3201     *++PL_stack_sp = &PL_sv_no;
3202     return PL_op->op_next->op_next;
3203 }
3204
3205
3206 /*
3207 A description of how taint works in pattern matching and substitution.
3208
3209 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
3210 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
3211
3212 While the pattern is being assembled/concatenated and then compiled,
3213 PL_tainted will get set (via TAINT_set) if any component of the pattern
3214 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
3215 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
3216 TAINT_get).  It will also be set if any component of the pattern matches
3217 based on locale-dependent behavior.
3218
3219 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
3220 the pattern is marked as tainted. This means that subsequent usage, such
3221 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
3222 on the new pattern too.
3223
3224 RXf_TAINTED_SEEN is used post-execution by the get magic code
3225 of $1 et al to indicate whether the returned value should be tainted.
3226 It is the responsibility of the caller of the pattern (i.e. pp_match,
3227 pp_subst etc) to set this flag for any other circumstances where $1 needs
3228 to be tainted.
3229
3230 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
3231
3232 There are three possible sources of taint
3233     * the source string
3234     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
3235     * the replacement string (or expression under /e)
3236     
3237 There are four destinations of taint and they are affected by the sources
3238 according to the rules below:
3239
3240     * the return value (not including /r):
3241         tainted by the source string and pattern, but only for the
3242         number-of-iterations case; boolean returns aren't tainted;
3243     * the modified string (or modified copy under /r):
3244         tainted by the source string, pattern, and replacement strings;
3245     * $1 et al:
3246         tainted by the pattern, and under 'use re "taint"', by the source
3247         string too;
3248     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
3249         should always be unset before executing subsequent code.
3250
3251 The overall action of pp_subst is:
3252
3253     * at the start, set bits in rxtainted indicating the taint status of
3254         the various sources.
3255
3256     * After each pattern execution, update the SUBST_TAINT_PAT bit in
3257         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
3258         pattern has subsequently become tainted via locale ops.
3259
3260     * If control is being passed to pp_substcont to execute a /e block,
3261         save rxtainted in the CXt_SUBST block, for future use by
3262         pp_substcont.
3263
3264     * Whenever control is being returned to perl code (either by falling
3265         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
3266         use the flag bits in rxtainted to make all the appropriate types of
3267         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
3268         et al will appear tainted.
3269
3270 pp_match is just a simpler version of the above.
3271
3272 */
3273
3274 PP(pp_subst)
3275 {
3276     dSP; dTARG;
3277     PMOP *pm = cPMOP;
3278     PMOP *rpm = pm;
3279     char *s;
3280     char *strend;
3281     const char *c;
3282     STRLEN clen;
3283     SSize_t iters = 0;
3284     SSize_t maxiters;
3285     bool once;
3286     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
3287                         See "how taint works" above */
3288     char *orig;
3289     U8 r_flags;
3290     REGEXP *rx = PM_GETRE(pm);
3291     regexp *prog = ReANY(rx);
3292     STRLEN len;
3293     int force_on_match = 0;
3294     const I32 oldsave = PL_savestack_ix;
3295     STRLEN slen;
3296     bool doutf8 = FALSE; /* whether replacement is in utf8 */
3297 #ifdef PERL_ANY_COW
3298     bool was_cow;
3299 #endif
3300     SV *nsv = NULL;
3301     /* known replacement string? */
3302     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
3303
3304     PERL_ASYNC_CHECK();
3305
3306     if (PL_op->op_flags & OPf_STACKED)
3307         TARG = POPs;
3308     else {
3309         if (ARGTARG)
3310             GETTARGET;
3311         else {
3312             TARG = DEFSV;
3313         }
3314         EXTEND(SP,1);
3315     }
3316
3317     SvGETMAGIC(TARG); /* must come before cow check */
3318 #ifdef PERL_ANY_COW
3319     /* note that a string might get converted to COW during matching */
3320     was_cow = cBOOL(SvIsCOW(TARG));
3321 #endif
3322     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3323 #ifndef PERL_ANY_COW
3324         if (SvIsCOW(TARG))
3325             sv_force_normal_flags(TARG,0);
3326 #endif
3327         if ((SvREADONLY(TARG)
3328                 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
3329                       || SvTYPE(TARG) > SVt_PVLV)
3330                      && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
3331             Perl_croak_no_modify();
3332     }
3333     PUTBACK;
3334
3335     orig = SvPV_nomg(TARG, len);
3336     /* note we don't (yet) force the var into being a string; if we fail
3337      * to match, we leave as-is; on successful match however, we *will*
3338      * coerce into a string, then repeat the match */
3339     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
3340         force_on_match = 1;
3341
3342     /* only replace once? */
3343     once = !(rpm->op_pmflags & PMf_GLOBAL);
3344
3345     /* See "how taint works" above */
3346     if (TAINTING_get) {
3347         rxtainted  = (
3348             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
3349           | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
3350           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
3351           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3352                 ? SUBST_TAINT_BOOLRET : 0));
3353         TAINT_NOT;
3354     }
3355
3356   force_it:
3357     if (!pm || !orig)
3358         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
3359
3360     strend = orig + len;
3361     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
3362     maxiters = 2 * slen + 10;   /* We can match twice at each
3363                                    position, once with zero-length,
3364                                    second time with non-zero. */
3365
3366     /* handle the empty pattern */
3367     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
3368         if (PL_curpm == PL_reg_curpm) {
3369             if (PL_curpm_under) {
3370                 if (PL_curpm_under == PL_reg_curpm) {
3371                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3372                 } else {
3373                     pm = PL_curpm_under;
3374                 }
3375             }
3376         } else {
3377             pm = PL_curpm;
3378         }
3379         rx = PM_GETRE(pm);
3380         prog = ReANY(rx);
3381     }
3382
3383 #ifdef PERL_SAWAMPERSAND
3384     r_flags = (    RXp_NPARENS(prog)
3385                 || PL_sawampersand
3386                 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3387                 || (rpm->op_pmflags & PMf_KEEPCOPY)
3388               )
3389           ? REXEC_COPY_STR
3390           : 0;
3391 #else
3392     r_flags = REXEC_COPY_STR;
3393 #endif
3394
3395     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
3396     {
3397         SPAGAIN;
3398         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
3399         LEAVE_SCOPE(oldsave);
3400         RETURN;
3401     }
3402     PL_curpm = pm;
3403
3404     /* known replacement string? */
3405     if (dstr) {
3406         /* replacement needing upgrading? */
3407         if (DO_UTF8(TARG) && !doutf8) {
3408              nsv = sv_newmortal();
3409              SvSetSV(nsv, dstr);
3410              sv_utf8_upgrade(nsv);
3411              c = SvPV_const(nsv, clen);
3412              doutf8 = TRUE;
3413         }
3414         else {
3415             c = SvPV_const(dstr, clen);
3416             doutf8 = DO_UTF8(dstr);
3417         }
3418
3419         if (SvTAINTED(dstr))
3420             rxtainted |= SUBST_TAINT_REPL;
3421     }
3422     else {
3423         c = NULL;
3424         doutf8 = FALSE;
3425     }
3426     
3427     /* can do inplace substitution? */
3428     if (c
3429 #ifdef PERL_ANY_COW
3430         && !was_cow
3431 #endif
3432         && (I32)clen <= RXp_MINLENRET(prog)
3433         && (  once
3434            || !(r_flags & REXEC_COPY_STR)
3435            || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
3436            )
3437         && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
3438         && (!doutf8 || SvUTF8(TARG))
3439         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3440     {
3441
3442 #ifdef PERL_ANY_COW
3443         /* string might have got converted to COW since we set was_cow */
3444         if (SvIsCOW(TARG)) {
3445           if (!force_on_match)
3446             goto have_a_cow;
3447           assert(SvVOK(TARG));
3448         }
3449 #endif
3450         if (force_on_match) {
3451             /* redo the first match, this time with the orig var
3452              * forced into being a string */
3453             force_on_match = 0;
3454             orig = SvPV_force_nomg(TARG, len);
3455             goto force_it;
3456         }
3457
3458         if (once) {
3459             char *d, *m;
3460             if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
3461                 rxtainted |= SUBST_TAINT_PAT;
3462             m = orig + RXp_OFFS(prog)[0].start;
3463             d = orig + RXp_OFFS(prog)[0].end;
3464             s = orig;
3465             if (m - s > strend - d) {  /* faster to shorten from end */
3466                 I32 i;
3467                 if (clen) {
3468                     Copy(c, m, clen, char);
3469                     m += clen;
3470                 }
3471                 i = strend - d;
3472                 if (i > 0) {
3473                     Move(d, m, i, char);
3474                     m += i;
3475                 }
3476                 *m = '\0';
3477                 SvCUR_set(TARG, m - s);
3478             }
3479             else {      /* faster from front */
3480                 I32 i = m - s;
3481                 d -= clen;
3482                 if (i > 0)
3483                     Move(s, d - i, i, char);
3484                 sv_chop(TARG, d-i);
3485                 if (clen)
3486                     Copy(c, d, clen, char);
3487             }
3488             SPAGAIN;
3489             PUSHs(&PL_sv_yes);
3490         }
3491         else {
3492             char *d, *m;
3493             d = s = RXp_OFFS(prog)[0].start + orig;
3494             do {
3495                 I32 i;
3496                 if (UNLIKELY(iters++ > maxiters))
3497                     DIE(aTHX_ "Substitution loop");
3498                 /* run time pattern taint, eg locale */
3499                 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
3500                     rxtainted |= SUBST_TAINT_PAT;
3501                 m = RXp_OFFS(prog)[0].start + orig;
3502                 if ((i = m - s)) {
3503                     if (s != d)
3504                         Move(s, d, i, char);
3505                     d += i;
3506                 }
3507                 if (clen) {
3508                     Copy(c, d, clen, char);
3509                     d += clen;
3510                 }
3511                 s = RXp_OFFS(prog)[0].end + orig;
3512             } while (CALLREGEXEC(rx, s, strend, orig,
3513                                  s == m, /* don't match same null twice */
3514                                  TARG, NULL,
3515                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3516             if (s != d) {
3517                 I32 i = strend - s;
3518                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
3519                 Move(s, d, i+1, char);          /* include the NUL */
3520             }
3521             SPAGAIN;
3522             if (PL_op->op_private & OPpTRUEBOOL)
3523                 PUSHs(iters ? &PL_sv_yes : &PL_sv_zero);
3524             else
3525                 mPUSHi(iters);
3526         }
3527     }
3528     else {
3529         bool first;
3530         char *m;
3531         SV *repl;
3532         if (force_on_match) {
3533             /* redo the first match, this time with the orig var
3534              * forced into being a string */
3535             force_on_match = 0;
3536             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3537                 /* I feel that it should be possible to avoid this mortal copy
3538                    given that the code below copies into a new destination.
3539                    However, I suspect it isn't worth the complexity of
3540                    unravelling the C<goto force_it> for the small number of
3541                    cases where it would be viable to drop into the copy code. */
3542                 TARG = sv_2mortal(newSVsv(TARG));
3543             }
3544             orig = SvPV_force_nomg(TARG, len);
3545             goto force_it;
3546         }
3547 #ifdef PERL_ANY_COW
3548       have_a_cow:
3549 #endif
3550         if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
3551             rxtainted |= SUBST_TAINT_PAT;
3552         repl = dstr;
3553         s = RXp_OFFS(prog)[0].start + orig;
3554         dstr = newSVpvn_flags(orig, s-orig,
3555                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3556         if (!c) {
3557             PERL_CONTEXT *cx;
3558             SPAGAIN;
3559             m = orig;
3560             /* note that a whole bunch of local vars are saved here for
3561              * use by pp_substcont: here's a list of them in case you're
3562              * searching for places in this sub that uses a particular var:
3563              * iters maxiters r_flags oldsave rxtainted orig dstr targ
3564              * s m strend rx once */
3565             CX_PUSHSUBST(cx);
3566             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3567         }
3568         first = TRUE;
3569         do {
3570             if (UNLIKELY(iters++ > maxiters))
3571                 DIE(aTHX_ "Substitution loop");
3572             if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
3573                 rxtainted |= SUBST_TAINT_PAT;
3574             if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
3575                 char *old_s    = s;
3576                 char *old_orig = orig;
3577                 assert(RXp_SUBOFFSET(prog) == 0);
3578
3579                 orig = RXp_SUBBEG(prog);
3580                 s = orig + (old_s - old_orig);
3581                 strend = s + (strend - old_s);
3582             }
3583             m = RXp_OFFS(prog)[0].start + orig;
3584             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3585             s = RXp_OFFS(prog)[0].end + orig;
3586             if (first) {
3587                 /* replacement already stringified */
3588               if (clen)
3589                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3590               first = FALSE;
3591             }
3592             else {
3593                 sv_catsv(dstr, repl);
3594                 if (UNLIKELY(SvTAINTED(repl)))
3595                     rxtainted |= SUBST_TAINT_REPL;
3596             }
3597             if (once)
3598                 break;
3599         } while (CALLREGEXEC(rx, s, strend, orig,
3600                              s == m,    /* Yields minend of 0 or 1 */
3601                              TARG, NULL,
3602                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3603         assert(strend >= s);
3604         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3605
3606         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3607             /* From here on down we're using the copy, and leaving the original
3608                untouched.  */
3609             TARG = dstr;
3610             SPAGAIN;
3611             PUSHs(dstr);
3612         } else {
3613 #ifdef PERL_ANY_COW
3614             /* The match may make the string COW. If so, brilliant, because
3615                that's just saved us one malloc, copy and free - the regexp has
3616                donated the old buffer, and we malloc an entirely new one, rather
3617                than the regexp malloc()ing a buffer and copying our original,
3618                only for us to throw it away here during the substitution.  */
3619             if (SvIsCOW(TARG)) {
3620                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3621             } else
3622 #endif
3623             {
3624                 SvPV_free(TARG);
3625             }
3626             SvPV_set(TARG, SvPVX(dstr));
3627             SvCUR_set(TARG, SvCUR(dstr));
3628             SvLEN_set(TARG, SvLEN(dstr));
3629             SvFLAGS(TARG) |= SvUTF8(dstr);
3630             SvPV_set(dstr, NULL);
3631
3632             SPAGAIN;
3633             mPUSHi(iters);
3634         }
3635     }
3636
3637     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3638         (void)SvPOK_only_UTF8(TARG);
3639     }
3640
3641     /* See "how taint works" above */
3642     if (TAINTING_get) {
3643         if ((rxtainted & SUBST_TAINT_PAT) ||
3644             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3645                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3646         )
3647             (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
3648
3649         if (!(rxtainted & SUBST_TAINT_BOOLRET)
3650             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3651         )
3652             SvTAINTED_on(TOPs);  /* taint return value */
3653         else
3654             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
3655
3656         /* needed for mg_set below */
3657         TAINT_set(
3658           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3659         );
3660         SvTAINT(TARG);
3661     }
3662     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3663     TAINT_NOT;
3664     LEAVE_SCOPE(oldsave);
3665     RETURN;
3666 }
3667
3668 PP(pp_grepwhile)
3669 {
3670     dSP;
3671     dPOPss;
3672
3673     if (SvTRUE_NN(sv))
3674         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3675     ++*PL_markstack_ptr;
3676     FREETMPS;
3677     LEAVE_with_name("grep_item");                                       /* exit inner scope */
3678
3679     /* All done yet? */
3680     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3681         I32 items;
3682         const U8 gimme = GIMME_V;
3683
3684         LEAVE_with_name("grep");                                        /* exit outer scope */
3685         (void)POPMARK;                          /* pop src */
3686         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3687         (void)POPMARK;                          /* pop dst */
3688         SP = PL_stack_base + POPMARK;           /* pop original mark */
3689         if (gimme == G_SCALAR) {
3690             if (PL_op->op_private & OPpTRUEBOOL)
3691                 PUSHs(items ? &PL_sv_yes : &PL_sv_zero);
3692             else {
3693                 dTARGET;
3694                 PUSHi(items);
3695             }
3696         }
3697         else if (gimme == G_ARRAY)
3698             SP += items;
3699         RETURN;
3700     }
3701     else {
3702         SV *src;
3703
3704         ENTER_with_name("grep_item");                                   /* enter inner scope */
3705         SAVEVPTR(PL_curpm);
3706
3707         src = PL_stack_base[TOPMARK];
3708         if (SvPADTMP(src)) {
3709             src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
3710             PL_tmps_floor++;
3711         }
3712         SvTEMP_off(src);
3713         DEFSV_set(src);
3714
3715         RETURNOP(cLOGOP->op_other);
3716     }
3717 }
3718
3719 /* leave_adjust_stacks():
3720  *
3721  * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
3722  * positioning them at to_sp+1 onwards, and do the equivalent of a
3723  * FREEMPS and TAINT_NOT.
3724  *
3725  * Not intended to be called in void context.
3726  *
3727  * When leaving a sub, eval, do{} or other scope, the things that need
3728  * doing to process the return args are:
3729  *    * in scalar context, only return the last arg (or PL_sv_undef if none);
3730  *    * for the types of return that return copies of their args (such
3731  *      as rvalue sub return), make a mortal copy of every return arg,
3732  *      except where we can optimise the copy away without it being
3733  *      semantically visible;
3734  *    * make sure that the arg isn't prematurely freed; in the case of an
3735  *      arg not copied, this may involve mortalising it. For example, in
3736  *      C<sub f { my $x = ...; $x }>, $x would be freed when we do
3737  *      CX_LEAVE_SCOPE(cx) unless it's protected or copied.
3738  *
3739  * What condition to use when deciding whether to pass the arg through
3740  * or make a copy, is determined by the 'pass' arg; its valid values are:
3741  *   0: rvalue sub/eval exit
3742  *   1: other rvalue scope exit
3743  *   2: :lvalue sub exit in rvalue context
3744  *   3: :lvalue sub exit in lvalue context and other lvalue scope exits
3745  *
3746  * There is a big issue with doing a FREETMPS. We would like to free any
3747  * temps created by the last statement which the sub executed, rather than
3748  * leaving them for the caller. In a situation where a sub call isn't
3749  * soon followed by a nextstate (e.g. nested recursive calls, a la
3750  * fibonacci()), temps can accumulate, causing memory and performance
3751  * issues.
3752  *
3753  * On the other hand, we don't want to free any TEMPs which are keeping
3754  * alive any return args that we skipped copying; nor do we wish to undo
3755  * any mortalising done here.
3756  *
3757  * The solution is to split the temps stack frame into two, with a cut
3758  * point delineating the two halves. We arrange that by the end of this
3759  * function, all the temps stack frame entries we wish to keep are in the
3760  * range  PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
3761  * the range  tmps_base .. PL_tmps_ix.  During the course of this
3762  * function, tmps_base starts off as PL_tmps_floor+1, then increases
3763  * whenever we find or create a temp that we know should be kept. In
3764  * general the stuff above tmps_base is undecided until we reach the end,
3765  * and we may need a sort stage for that.
3766  *
3767  * To determine whether a TEMP is keeping a return arg alive, every
3768  * arg that is kept rather than copied and which has the SvTEMP flag
3769  * set, has the flag temporarily unset, to mark it. At the end we scan
3770  * the temps stack frame above the cut for entries without SvTEMP and
3771  * keep them, while turning SvTEMP on again. Note that if we die before
3772  * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
3773  * those SVs may be slightly less efficient.
3774  *
3775  * In practice various optimisations for some common cases mean we can
3776  * avoid most of the scanning and swapping about with the temps stack.
3777  */
3778
3779 void
3780 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
3781 {
3782     dVAR;
3783     dSP;
3784     SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
3785     SSize_t nargs;
3786
3787     PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
3788
3789     TAINT_NOT;
3790
3791     if (gimme == G_ARRAY) {
3792         nargs = SP - from_sp;
3793         from_sp++;
3794     }
3795     else {
3796         assert(gimme == G_SCALAR);
3797         if (UNLIKELY(from_sp >= SP)) {
3798             /* no return args */
3799             assert(from_sp == SP);
3800             EXTEND(SP, 1);
3801             *++SP = &PL_sv_undef;
3802             to_sp = SP;
3803             nargs   = 0;
3804         }
3805         else {
3806             from_sp = SP;
3807             nargs   = 1;
3808         }
3809     }
3810
3811     /* common code for G_SCALAR and G_ARRAY */
3812
3813     tmps_base = PL_tmps_floor + 1;
3814
3815     assert(nargs >= 0);
3816     if (nargs) {
3817         /* pointer version of tmps_base. Not safe across temp stack
3818          * reallocs. */
3819         SV **tmps_basep;
3820
3821         EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
3822         tmps_basep = PL_tmps_stack + tmps_base;
3823
3824         /* process each return arg */
3825
3826         do {
3827             SV *sv = *from_sp++;
3828
3829             assert(PL_tmps_ix + nargs < PL_tmps_max);
3830 #ifdef DEBUGGING
3831             /* PADTMPs with container set magic shouldn't appear in the
3832              * wild. This assert is more important for pp_leavesublv(),
3833              * but by testing for it here, we're more likely to catch
3834              * bad cases (what with :lvalue subs not being widely
3835              * deployed). The two issues are that for something like
3836              *     sub :lvalue { $tied{foo} }
3837              * or
3838              *     sub :lvalue { substr($foo,1,2) }
3839              * pp_leavesublv() will croak if the sub returns a PADTMP,
3840              * and currently functions like pp_substr() return a mortal
3841              * rather than using their PADTMP when returning a PVLV.
3842              * This is because the PVLV will hold a ref to $foo,
3843              * so $foo would get delayed in being freed while
3844              * the PADTMP SV remained in the PAD.
3845              * So if this assert fails it means either:
3846              *  1) there is pp code similar to pp_substr that is
3847              *     returning a PADTMP instead of a mortal, and probably
3848              *     needs fixing, or
3849              *  2) pp_leavesublv is making unwarranted assumptions
3850              *     about always croaking on a PADTMP
3851              */
3852             if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
3853                 MAGIC *mg;
3854                 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
3855                     assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
3856                 }
3857             }
3858 #endif
3859
3860             if (
3861                pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3862              : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3863              : pass == 2 ? (!SvPADTMP(sv))
3864              : 1)
3865             {
3866                 /* pass through: skip copy for logic or optimisation
3867                  * reasons; instead mortalise it, except that ... */
3868                 *++to_sp = sv;
3869
3870                 if (SvTEMP(sv)) {
3871                     /* ... since this SV is an SvTEMP , we don't need to
3872                      * re-mortalise it; instead we just need to ensure
3873                      * that its existing entry in the temps stack frame
3874                      * ends up below the cut and so avoids being freed
3875                      * this time round. We mark it as needing to be kept
3876                      * by temporarily unsetting SvTEMP; then at the end,
3877                      * we shuffle any !SvTEMP entries on the tmps stack
3878                      * back below the cut.
3879                      * However, there's a significant chance that there's
3880                      * a 1:1 correspondence between the first few (or all)
3881                      * elements in the return args stack frame and those
3882                      * in the temps stack frame; e,g.:
3883                      *      sub f { ....; map {...} .... },
3884                      * or if we're exiting multiple scopes and one of the
3885                      * inner scopes has already made mortal copies of each
3886                      * return arg.
3887                      *
3888                      * If so, this arg sv will correspond to the next item
3889                      * on the tmps stack above the cut, and so can be kept
3890                      * merely by moving the cut boundary up one, rather
3891                      * than messing with SvTEMP.  If all args are 1:1 then
3892                      * we can avoid the sorting stage below completely.
3893                      *
3894                      * If there are no items above the cut on the tmps
3895                      * stack, then the SvTEMP must comne from an item
3896                      * below the cut, so there's nothing to do.
3897                      */
3898                     if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
3899                         if (sv == *tmps_basep)
3900                             tmps_basep++;
3901                         else
3902                             SvTEMP_off(sv);
3903                     }
3904                 }
3905                 else if (!SvPADTMP(sv)) {
3906                     /* mortalise arg to avoid it being freed during save
3907                      * stack unwinding. Pad tmps don't need mortalising as
3908                      * they're never freed. This is the equivalent of
3909                      * sv_2mortal(SvREFCNT_inc(sv)), except that:
3910                      *  * it assumes that the temps stack has already been
3911                      *    extended;
3912                      *  * it puts the new item at the cut rather than at
3913                      *    ++PL_tmps_ix, moving the previous occupant there
3914                      *    instead.
3915                      */
3916                     if (!SvIMMORTAL(sv)) {
3917                         SvREFCNT_inc_simple_void_NN(sv);
3918                         SvTEMP_on(sv);
3919                         /* Note that if there's nothing above the cut,
3920                          * this copies the garbage one slot above
3921                          * PL_tmps_ix onto itself. This is harmless (the
3922                          * stack's already been extended), but might in
3923                          * theory trigger warnings from tools like ASan
3924                          */
3925                         PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3926                         *tmps_basep++ = sv;
3927                     }
3928                 }
3929             }
3930             else {
3931                 /* Make a mortal copy of the SV.
3932                  * The following code is the equivalent of sv_mortalcopy()
3933                  * except that:
3934                  *  * it assumes the temps stack has already been extended;
3935                  *  * it optimises the copying for some simple SV types;
3936                  *  * it puts the new item at the cut rather than at
3937                  *    ++PL_tmps_ix, moving the previous occupant there
3938                  *    instead.
3939                  */
3940                 SV *newsv = newSV(0);
3941
3942                 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3943                 /* put it on the tmps stack early so it gets freed if we die */
3944                 *tmps_basep++ = newsv;
3945                 *++to_sp = newsv;
3946
3947                 if (SvTYPE(sv) <= SVt_IV) {
3948                     /* arg must be one of undef, IV/UV, or RV: skip
3949                      * sv_setsv_flags() and do the copy directly */
3950                     U32 dstflags;
3951                     U32 srcflags = SvFLAGS(sv);
3952
3953                     assert(!SvGMAGICAL(sv));
3954                     if (srcflags & (SVf_IOK|SVf_ROK)) {
3955                         SET_SVANY_FOR_BODYLESS_IV(newsv);
3956
3957                         if (srcflags & SVf_ROK) {
3958                             newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
3959                             /* SV type plus flags */
3960                             dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
3961                         }
3962                         else {
3963                             /* both src and dst are <= SVt_IV, so sv_any
3964                              * points to the head; so access the heads
3965                              * directly rather than going via sv_any.
3966                              */
3967                             assert(    &(sv->sv_u.svu_iv)
3968                                     == &(((XPVIV*) SvANY(sv))->xiv_iv));
3969                             assert(    &(newsv->sv_u.svu_iv)
3970                                     == &(((XPVIV*) SvANY(newsv))->xiv_iv));
3971                             newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
3972                             /* SV type plus flags */
3973                             dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
3974                                             |(srcflags & SVf_IVisUV));
3975                         }
3976                     }
3977                     else {
3978                         assert(!(srcflags & SVf_OK));
3979                         dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
3980                     }
3981                     SvFLAGS(newsv) = dstflags;
3982
3983                 }
3984                 else {
3985                     /* do the full sv_setsv() */
3986                     SSize_t old_base;
3987
3988                     SvTEMP_on(newsv);
3989                     old_base = tmps_basep - PL_tmps_stack;
3990                     SvGETMAGIC(sv);
3991                     sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
3992                     /* the mg_get or sv_setsv might have created new temps
3993                      * or realloced the tmps stack; regrow and reload */
3994                     EXTEND_MORTAL(nargs);
3995                     tmps_basep = PL_tmps_stack + old_base;
3996                     TAINT_NOT;  /* Each item is independent */
3997                 }
3998
3999             }
4000         } while (--nargs);
4001
4002         /* If there are any temps left above the cut, we need to sort
4003          * them into those to keep and those to free. The only ones to
4004          * keep are those for which we've temporarily unset SvTEMP.
4005          * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
4006          * swapping pairs as necessary. Stop when we meet in the middle.
4007          */
4008         {
4009             SV **top = PL_tmps_stack + PL_tmps_ix;
4010             while (tmps_basep <= top) {
4011                 SV *sv = *top;
4012                 if (SvTEMP(sv))
4013                     top--;
4014                 else {
4015                     SvTEMP_on(sv);
4016                     *top = *tmps_basep;
4017                     *tmps_basep = sv;
4018                     tmps_basep++;
4019                 }
4020             }
4021         }
4022
4023         tmps_base = tmps_basep - PL_tmps_stack;
4024     }
4025
4026     PL_stack_sp = to_sp;
4027
4028     /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
4029     while (PL_tmps_ix >= tmps_base) {
4030         SV* const sv = PL_tmps_stack[PL_tmps_ix--];
4031 #ifdef PERL_POISON
4032         PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
4033 #endif
4034         if (LIKELY(sv)) {
4035             SvTEMP_off(sv);
4036             SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
4037         }
4038     }
4039 }
4040
4041
4042 /* also tail-called by pp_return */
4043
4044 PP(pp_leavesub)
4045 {
4046     U8 gimme;
4047     PERL_CONTEXT *cx;
4048     SV **oldsp;
4049     OP *retop;
4050
4051     cx = CX_CUR();
4052     assert(CxTYPE(cx) == CXt_SUB);
4053
4054     if (CxMULTICALL(cx)) {
4055         /* entry zero of a stack is always PL_sv_undef, which
4056          * simplifies converting a '()' return into undef in scalar context */
4057         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
4058         return 0;
4059     }
4060
4061     gimme = cx->blk_gimme;
4062     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
4063
4064     if (gimme == G_VOID)
4065         PL_stack_sp = oldsp;
4066     else
4067         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4068
4069     CX_LEAVE_SCOPE(cx);
4070     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
4071     cx_popblock(cx);
4072     retop = cx->blk_sub.retop;
4073     CX_POP(cx);
4074
4075     return retop;
4076 }
4077
4078
4079 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
4080  * forces an abandon */
4081
4082 void
4083 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
4084 {
4085     const SSize_t fill = AvFILLp(av);
4086
4087     PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
4088
4089     if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
4090         av_clear(av);
4091         AvREIFY_only(av);
4092     }
4093     else {
4094         AV *newav = newAV();
4095         av_extend(newav, fill);
4096         AvREIFY_only(newav);
4097         PAD_SVl(0) = MUTABLE_SV(newav);
4098         SvREFCNT_dec_NN(av);
4099     }
4100 }
4101
4102
4103 PP(pp_entersub)
4104 {
4105     dSP; dPOPss;
4106     GV *gv;
4107     CV *cv;
4108     PERL_CONTEXT *cx;
4109     I32 old_savestack_ix;
4110
4111     if (UNLIKELY(!sv))
4112         goto do_die;
4113
4114     /* Locate the CV to call:
4115      * - most common case: RV->CV: f(), $ref->():
4116      *   note that if a sub is compiled before its caller is compiled,
4117      *   the stash entry will be a ref to a CV, rather than being a GV.
4118      * - second most common case: CV: $ref->method()
4119      */
4120
4121     /* a non-magic-RV -> CV ? */
4122     if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
4123         cv = MUTABLE_CV(SvRV(sv));
4124         if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
4125             goto do_ref;
4126     }
4127     else
4128         cv = MUTABLE_CV(sv);
4129
4130     /* a CV ? */
4131     if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
4132         /* handle all the weird cases */
4133         switch (SvTYPE(sv)) {
4134         case SVt_PVLV:
4135             if (!isGV_with_GP(sv))
4136                 goto do_default;
4137             /* FALLTHROUGH */
4138         case SVt_PVGV:
4139             cv = GvCVu((const GV *)sv);
4140             if (UNLIKELY(!cv)) {
4141                 HV *stash;
4142                 cv = sv_2cv(sv, &stash, &gv, 0);
4143                 if (!cv) {
4144                     old_savestack_ix = PL_savestack_ix;
4145                     goto try_autoload;
4146                 }
4147             }
4148             break;
4149
4150         default:
4151           do_default:
4152             SvGETMAGIC(sv);
4153             if (SvROK(sv)) {
4154               do_ref:
4155                 if (UNLIKELY(SvAMAGIC(sv))) {
4156                     sv = amagic_deref_call(sv, to_cv_amg);
4157                     /* Don't SPAGAIN here.  */
4158                 }
4159             }
4160             else {
4161                 const char *sym;
4162                 STRLEN len;
4163                 if (UNLIKELY(!SvOK(sv)))
4164                     DIE(aTHX_ PL_no_usym, "a subroutine");
4165
4166                 if (UNLIKELY(sv == &PL_sv_yes)) { /* unfound import, ignore */
4167                     if (PL_op->op_flags & OPf_STACKED) /* hasargs */
4168                         SP = PL_stack_base + POPMARK;
4169                     else
4170                         (void)POPMARK;
4171                     if (GIMME_V == G_SCALAR)
4172                         PUSHs(&PL_sv_undef);
4173                     RETURN;
4174                 }
4175
4176                 sym = SvPV_nomg_const(sv, len);
4177                 if (PL_op->op_private & HINT_STRICT_REFS)
4178                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
4179                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
4180                 break;
4181             }
4182             cv = MUTABLE_CV(SvRV(sv));
4183             if (LIKELY(SvTYPE(cv) == SVt_PVCV))
4184                 break;
4185             /* FALLTHROUGH */
4186         case SVt_PVHV:
4187         case SVt_PVAV:
4188           do_die:
4189             DIE(aTHX_ "Not a CODE reference");
4190         }
4191     }
4192
4193     /* At this point we want to save PL_savestack_ix, either by doing a
4194      * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
4195      * CV we will be using (so we don't know whether its XS, so we can't
4196      * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
4197      * the save stack. So remember where we are currently on the save
4198      * stack, and later update the CX or scopestack entry accordingly. */
4199     old_savestack_ix = PL_savestack_ix;
4200
4201     /* these two fields are in a union. If they ever become separate,
4202      * we have to test for both of them being null below */
4203     assert(cv);
4204     assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
4205     while (UNLIKELY(!CvROOT(cv))) {
4206         GV* autogv;
4207         SV* sub_name;
4208
4209         /* anonymous or undef'd function leaves us no recourse */
4210         if (CvLEXICAL(cv) && CvHASGV(cv))
4211             DIE(aTHX_ "Undefined subroutine &%" SVf " called",
4212                        SVfARG(cv_name(cv, NULL, 0)));
4213         if (CvANON(cv) || !CvHASGV(cv)) {
4214             DIE(aTHX_ "Undefined subroutine called");
4215         }
4216
4217         /* autoloaded stub? */
4218         if (cv != GvCV(gv = CvGV(cv))) {
4219             cv = GvCV(gv);
4220         }
4221         /* should call AUTOLOAD now? */
4222         else {
4223           try_autoload:
4224             autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
4225                                      (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
4226                                     |(PL_op->op_flags & OPf_REF
4227                                        ? GV_AUTOLOAD_ISMETHOD
4228                                        : 0));
4229             cv = autogv ? GvCV(autogv) : NULL;
4230         }
4231         if (!cv) {
4232             sub_name = sv_newmortal();
4233             gv_efullname3(sub_name, gv, NULL);
4234             DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
4235         }
4236     }
4237
4238     /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
4239     if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
4240         DIE(aTHX_ "Closure prototype called");
4241
4242     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
4243             && !CvNODEBUG(cv)))
4244     {
4245          Perl_get_db_sub(aTHX_ &sv, cv);
4246          if (CvISXSUB(cv))
4247              PL_curcopdb = PL_curcop;
4248          if (CvLVALUE(cv)) {
4249              /* check for lsub that handles lvalue subroutines */
4250              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
4251              /* if lsub not found then fall back to DB::sub */
4252              if (!cv) cv = GvCV(PL_DBsub);
4253          } else {
4254              cv = GvCV(PL_DBsub);
4255          }
4256
4257         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
4258             DIE(aTHX_ "No DB::sub routine defined");
4259     }
4260
4261     if (!(CvISXSUB(cv))) {
4262         /* This path taken at least 75% of the time   */
4263         dMARK;
4264         PADLIST *padlist;
4265         I32 depth;
4266         bool hasargs;
4267         U8 gimme;
4268
4269         /* keep PADTMP args alive throughout the call (we need to do this
4270          * because @_ isn't refcounted). Note that we create the mortals
4271          * in the caller's tmps frame, so they won't be freed until after
4272          * we return from the sub.
4273          */
4274         {
4275             SV **svp = MARK;
4276             while (svp < SP) {
4277                 SV *sv = *++svp;
4278                 if (!sv)
4279                     continue;
4280                 if (SvPADTMP(sv))
4281                     *svp = sv = sv_mortalcopy(sv);
4282                 SvTEMP_off(sv);
4283             }
4284         }
4285
4286         gimme = GIMME_V;
4287         cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
4288         hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
4289         cx_pushsub(cx, cv, PL_op->op_next, hasargs);
4290
4291         padlist = CvPADLIST(cv);
4292         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
4293             pad_push(padlist, depth);
4294         PAD_SET_CUR_NOSAVE(padlist, depth);
4295         if (LIKELY(hasargs)) {
4296             AV *const av = MUTABLE_AV(PAD_SVl(0));
4297             SSize_t items;
4298             AV **defavp;
4299
4300             defavp = &GvAV(PL_defgv);
4301             cx->blk_sub.savearray = *defavp;
4302             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
4303
4304             /* it's the responsibility of whoever leaves a sub to ensure
4305              * that a clean, empty AV is left in pad[0]. This is normally
4306              * done by cx_popsub() */
4307             assert(!AvREAL(av) && AvFILLp(av) == -1);
4308
4309             items = SP - MARK;
4310             if (UNLIKELY(items - 1 > AvMAX(av))) {
4311                 SV **ary = AvALLOC(av);
4312                 Renew(ary, items, SV*);
4313                 AvMAX(av) = items - 1;
4314                 AvALLOC(av) = ary;
4315                 AvARRAY(av) = ary;
4316             }
4317
4318             Copy(MARK+1,AvARRAY(av),items,SV*);
4319             AvFILLp(av) = items - 1;
4320         }
4321         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
4322             !CvLVALUE(cv)))
4323             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
4324                 SVfARG(cv_name(cv, NULL, 0)));
4325         /* warning must come *after* we fully set up the context
4326          * stuff so that __WARN__ handlers can safely dounwind()
4327          * if they want to
4328          */
4329         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
4330                 && ckWARN(WARN_RECURSION)
4331                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4332             sub_crush_depth(cv);
4333         RETURNOP(CvSTART(cv));
4334     }
4335     else {
4336         SSize_t markix = TOPMARK;
4337         bool is_scalar;
4338
4339         ENTER;
4340         /* pretend we did the ENTER earlier */
4341         PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
4342
4343         SAVETMPS;
4344         PUTBACK;
4345
4346         if (UNLIKELY(((PL_op->op_private
4347                & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
4348              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
4349             !CvLVALUE(cv)))
4350             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
4351                 SVfARG(cv_name(cv, NULL, 0)));
4352
4353