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