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