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