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