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