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