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