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