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