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