This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b08643fcc14028c8f319ff9a9a3da8e064b3d144
[perl5.git] / pp_hot.c
1 /*    pp_hot.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13  * shaking the air.
14  *
15  *                  Awake!  Awake!  Fear, Fire, Foes!  Awake!
16  *                               Fire, Foes!  Awake!
17  *
18  *     [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
19  */
20
21 /* This file contains 'hot' pp ("push/pop") functions that
22  * execute the opcodes that make up a perl program. A typical pp function
23  * expects to find its arguments on the stack, and usually pushes its
24  * results onto the stack, hence the 'pp' terminology. Each OP structure
25  * contains a pointer to the relevant pp_foo() function.
26  *
27  * By 'hot', we mean common ops whose execution speed is critical.
28  * By gathering them together into a single file, we encourage
29  * CPU cache hits on hot code. Also it could be taken as a warning not to
30  * change any code in this file unless you're sure it won't affect
31  * performance.
32  */
33
34 #include "EXTERN.h"
35 #define PERL_IN_PP_HOT_C
36 #include "perl.h"
37
38 /* Hot code. */
39
40 PP(pp_const)
41 {
42     dVAR;
43     dSP;
44     XPUSHs(cSVOP_sv);
45     RETURN;
46 }
47
48 PP(pp_nextstate)
49 {
50     dVAR;
51     PL_curcop = (COP*)PL_op;
52     TAINT_NOT;          /* Each statement is presumed innocent */
53     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
54     FREETMPS;
55     PERL_ASYNC_CHECK();
56     return NORMAL;
57 }
58
59 PP(pp_gvsv)
60 {
61     dVAR;
62     dSP;
63     EXTEND(SP,1);
64     if (PL_op->op_private & OPpLVAL_INTRO)
65         PUSHs(save_scalar(cGVOP_gv));
66     else
67         PUSHs(GvSVn(cGVOP_gv));
68     RETURN;
69 }
70
71 PP(pp_null)
72 {
73     dVAR;
74     return NORMAL;
75 }
76
77 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
78 PP(pp_pushmark)
79 {
80     dVAR;
81     PUSHMARK(PL_stack_sp);
82     return NORMAL;
83 }
84
85 PP(pp_stringify)
86 {
87     dVAR; dSP; dTARGET;
88     SV * const sv = TOPs;
89     SETs(TARG);
90     sv_copypv(TARG, sv);
91     SvSETMAGIC(TARG);
92     /* no PUTBACK, SETs doesn't inc/dec SP */
93     return NORMAL;
94 }
95
96 PP(pp_gv)
97 {
98     dVAR; dSP;
99     XPUSHs(MUTABLE_SV(cGVOP_gv));
100     RETURN;
101 }
102
103 PP(pp_and)
104 {
105     dVAR;
106     PERL_ASYNC_CHECK();
107     {
108         /* SP is not used to remove a variable that is saved across the
109           sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
110           register or load/store vs direct mem ops macro is introduced, this
111           should be a define block between direct PL_stack_sp and dSP operations,
112           presently, using PL_stack_sp is bias towards CISC cpus */
113         SV * const sv = *PL_stack_sp;
114         if (!SvTRUE_NN(sv))
115             return NORMAL;
116         else {
117             if (PL_op->op_type == OP_AND)
118                 --PL_stack_sp;
119             return cLOGOP->op_other;
120         }
121     }
122 }
123
124 PP(pp_sassign)
125 {
126     dVAR; dSP;
127     /* sassign keeps its args in the optree traditionally backwards.
128        So we pop them differently.
129     */
130     SV *left = POPs; SV *right = TOPs;
131
132     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
133         SV * const temp = left;
134         left = right; right = temp;
135     }
136     if (TAINTING_get && TAINT_get && !SvTAINTED(right))
137         TAINT_NOT;
138     if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
139         SV * const cv = SvRV(right);
140         const U32 cv_type = SvTYPE(cv);
141         const bool is_gv = isGV_with_GP(left);
142         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
143
144         if (!got_coderef) {
145             assert(SvROK(cv));
146         }
147
148         /* Can do the optimisation if left (LVALUE) is not a typeglob,
149            right (RVALUE) is a reference to something, and we're in void
150            context. */
151         if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
152             /* Is the target symbol table currently empty?  */
153             GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
154             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
155                 /* Good. Create a new proxy constant subroutine in the target.
156                    The gv becomes a(nother) reference to the constant.  */
157                 SV *const value = SvRV(cv);
158
159                 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
160                 SvPCS_IMPORTED_on(gv);
161                 SvRV_set(gv, value);
162                 SvREFCNT_inc_simple_void(value);
163                 SETs(left);
164                 RETURN;
165             }
166         }
167
168         /* Need to fix things up.  */
169         if (!is_gv) {
170             /* Need to fix GV.  */
171             left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
172         }
173
174         if (!got_coderef) {
175             /* We've been returned a constant rather than a full subroutine,
176                but they expect a subroutine reference to apply.  */
177             if (SvROK(cv)) {
178                 ENTER_with_name("sassign_coderef");
179                 SvREFCNT_inc_void(SvRV(cv));
180                 /* newCONSTSUB takes a reference count on the passed in SV
181                    from us.  We set the name to NULL, otherwise we get into
182                    all sorts of fun as the reference to our new sub is
183                    donated to the GV that we're about to assign to.
184                 */
185                 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
186                                                       SvRV(cv))));
187                 SvREFCNT_dec_NN(cv);
188                 LEAVE_with_name("sassign_coderef");
189             } else {
190                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
191                    is that
192                    First:   ops for \&{"BONK"}; return us the constant in the
193                             symbol table
194                    Second:  ops for *{"BONK"} cause that symbol table entry
195                             (and our reference to it) to be upgraded from RV
196                             to typeblob)
197                    Thirdly: We get here. cv is actually PVGV now, and its
198                             GvCV() is actually the subroutine we're looking for
199
200                    So change the reference so that it points to the subroutine
201                    of that typeglob, as that's what they were after all along.
202                 */
203                 GV *const upgraded = MUTABLE_GV(cv);
204                 CV *const source = GvCV(upgraded);
205
206                 assert(source);
207                 assert(CvFLAGS(source) & CVf_CONST);
208
209                 SvREFCNT_inc_void(source);
210                 SvREFCNT_dec_NN(upgraded);
211                 SvRV_set(right, MUTABLE_SV(source));
212             }
213         }
214
215     }
216     if (
217       SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
218       (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
219     )
220         Perl_warner(aTHX_
221             packWARN(WARN_MISC), "Useless assignment to a temporary"
222         );
223     SvSetMagicSV(left, right);
224     SETs(left);
225     RETURN;
226 }
227
228 PP(pp_cond_expr)
229 {
230     dVAR; dSP;
231     PERL_ASYNC_CHECK();
232     if (SvTRUEx(POPs))
233         RETURNOP(cLOGOP->op_other);
234     else
235         RETURNOP(cLOGOP->op_next);
236 }
237
238 PP(pp_unstack)
239 {
240     dVAR;
241     PERL_ASYNC_CHECK();
242     TAINT_NOT;          /* Each statement is presumed innocent */
243     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
244     FREETMPS;
245     if (!(PL_op->op_flags & OPf_SPECIAL)) {
246         I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
247         LEAVE_SCOPE(oldsave);
248     }
249     return NORMAL;
250 }
251
252 PP(pp_concat)
253 {
254   dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
255   {
256     dPOPTOPssrl;
257     bool lbyte;
258     STRLEN rlen;
259     const char *rpv = NULL;
260     bool rbyte = FALSE;
261     bool rcopied = FALSE;
262
263     if (TARG == right && right != left) { /* $r = $l.$r */
264         rpv = SvPV_nomg_const(right, rlen);
265         rbyte = !DO_UTF8(right);
266         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
267         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
268         rcopied = TRUE;
269     }
270
271     if (TARG != left) { /* not $l .= $r */
272         STRLEN llen;
273         const char* const lpv = SvPV_nomg_const(left, llen);
274         lbyte = !DO_UTF8(left);
275         sv_setpvn(TARG, lpv, llen);
276         if (!lbyte)
277             SvUTF8_on(TARG);
278         else
279             SvUTF8_off(TARG);
280     }
281     else { /* $l .= $r */
282         if (!SvOK(TARG)) {
283             if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
284                 report_uninit(right);
285             sv_setpvs(left, "");
286         }
287         SvPV_force_nomg_nolen(left);
288         lbyte = !DO_UTF8(left);
289         if (IN_BYTES)
290             SvUTF8_off(TARG);
291     }
292
293     if (!rcopied) {
294         if (left == right)
295             /* $r.$r: do magic twice: tied might return different 2nd time */
296             SvGETMAGIC(right);
297         rpv = SvPV_nomg_const(right, rlen);
298         rbyte = !DO_UTF8(right);
299     }
300     if (lbyte != rbyte) {
301         /* sv_utf8_upgrade_nomg() may reallocate the stack */
302         PUTBACK;
303         if (lbyte)
304             sv_utf8_upgrade_nomg(TARG);
305         else {
306             if (!rcopied)
307                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
308             sv_utf8_upgrade_nomg(right);
309             rpv = SvPV_nomg_const(right, rlen);
310         }
311         SPAGAIN;
312     }
313     sv_catpvn_nomg(TARG, rpv, rlen);
314
315     SETTARG;
316     RETURN;
317   }
318 }
319
320 /* push the elements of av onto the stack.
321  * XXX Note that padav has similar code but without the mg_get().
322  * I suspect that the mg_get is no longer needed, but while padav
323  * differs, it can't share this function */
324
325 STATIC void
326 S_pushav(pTHX_ AV* const av)
327 {
328     dSP;
329     const I32 maxarg = AvFILL(av) + 1;
330     EXTEND(SP, maxarg);
331     if (SvRMAGICAL(av)) {
332         U32 i;
333         for (i=0; i < (U32)maxarg; i++) {
334             SV ** const svp = av_fetch(av, i, FALSE);
335             /* See note in pp_helem, and bug id #27839 */
336             SP[i+1] = svp
337                 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
338                 : &PL_sv_undef;
339         }
340     }
341     else {
342         Copy(AvARRAY(av), SP+1, maxarg, SV*);
343     }
344     SP += maxarg;
345     PUTBACK;
346 }
347
348
349 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
350
351 PP(pp_padrange)
352 {
353     dVAR; dSP;
354     PADOFFSET base = PL_op->op_targ;
355     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
356     int i;
357     if (PL_op->op_flags & OPf_SPECIAL) {
358         /* fake the RHS of my ($x,$y,..) = @_ */
359         PUSHMARK(SP);
360         S_pushav(aTHX_ GvAVn(PL_defgv));
361         SPAGAIN;
362     }
363
364     /* note, this is only skipped for compile-time-known void cxt */
365     if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
366         EXTEND(SP, count);
367         PUSHMARK(SP);
368         for (i = 0; i <count; i++)
369             *++SP = PAD_SV(base+i);
370     }
371     if (PL_op->op_private & OPpLVAL_INTRO) {
372         SV **svp = &(PAD_SVl(base));
373         const UV payload = (UV)(
374                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
375                     | (count << SAVE_TIGHT_SHIFT)
376                     | SAVEt_CLEARPADRANGE);
377         assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
378         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
379         {
380             dSS_ADD;
381             SS_ADD_UV(payload);
382             SS_ADD_END(1);
383         }
384
385         for (i = 0; i <count; i++)
386             SvPADSTALE_off(*svp++); /* mark lexical as active */
387     }
388     RETURN;
389 }
390
391
392 PP(pp_padsv)
393 {
394     dVAR; dSP;
395     EXTEND(SP, 1);
396     {
397         OP * const op = PL_op;
398         /* access PL_curpad once */
399         SV ** const padentry = &(PAD_SVl(op->op_targ));
400         {
401             dTARG;
402             TARG = *padentry;
403             PUSHs(TARG);
404             PUTBACK; /* no pop/push after this, TOPs ok */
405         }
406         if (op->op_flags & OPf_MOD) {
407             if (op->op_private & OPpLVAL_INTRO)
408                 if (!(op->op_private & OPpPAD_STATE))
409                     save_clearsv(padentry);
410             if (op->op_private & OPpDEREF) {
411                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
412                    than TARG reduces the scope of TARG, so it does not
413                    span the call to save_clearsv, resulting in smaller
414                    machine code. */
415                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
416             }
417         }
418         return op->op_next;
419     }
420 }
421
422 PP(pp_readline)
423 {
424     dVAR;
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         }
442     }
443     return do_readline();
444 }
445
446 PP(pp_eq)
447 {
448     dVAR; dSP;
449     SV *left, *right;
450
451     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
452     right = POPs;
453     left  = TOPs;
454     SETs(boolSV(
455         (SvIOK_notUV(left) && SvIOK_notUV(right))
456         ? (SvIVX(left) == SvIVX(right))
457         : ( do_ncmp(left, right) == 0)
458     ));
459     RETURN;
460 }
461
462 PP(pp_preinc)
463 {
464     dVAR; dSP;
465     const bool inc =
466         PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
467     if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
468         Perl_croak_no_modify();
469     if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
470         && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
471     {
472         SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
473         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
474     }
475     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
476         if (inc) sv_inc(TOPs);
477         else sv_dec(TOPs);
478     SvSETMAGIC(TOPs);
479     return NORMAL;
480 }
481
482 PP(pp_or)
483 {
484     dVAR; dSP;
485     PERL_ASYNC_CHECK();
486     if (SvTRUE(TOPs))
487         RETURN;
488     else {
489         if (PL_op->op_type == OP_OR)
490             --SP;
491         RETURNOP(cLOGOP->op_other);
492     }
493 }
494
495 PP(pp_defined)
496 {
497     dVAR; dSP;
498     SV* sv;
499     bool defined;
500     const int op_type = PL_op->op_type;
501     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
502
503     if (is_dor) {
504         PERL_ASYNC_CHECK();
505         sv = TOPs;
506         if (!sv || !SvANY(sv)) {
507             if (op_type == OP_DOR)
508                 --SP;
509             RETURNOP(cLOGOP->op_other);
510         }
511     }
512     else {
513         /* OP_DEFINED */
514         sv = POPs;
515         if (!sv || !SvANY(sv))
516             RETPUSHNO;
517     }
518
519     defined = FALSE;
520     switch (SvTYPE(sv)) {
521     case SVt_PVAV:
522         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
523             defined = TRUE;
524         break;
525     case SVt_PVHV:
526         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
527             defined = TRUE;
528         break;
529     case SVt_PVCV:
530         if (CvROOT(sv) || CvXSUB(sv))
531             defined = TRUE;
532         break;
533     default:
534         SvGETMAGIC(sv);
535         if (SvOK(sv))
536             defined = TRUE;
537         break;
538     }
539
540     if (is_dor) {
541         if(defined) 
542             RETURN; 
543         if(op_type == OP_DOR)
544             --SP;
545         RETURNOP(cLOGOP->op_other);
546     }
547     /* assuming OP_DEFINED */
548     if(defined) 
549         RETPUSHYES;
550     RETPUSHNO;
551 }
552
553 PP(pp_add)
554 {
555     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
556     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
557     svr = TOPs;
558     svl = TOPm1s;
559
560     useleft = USE_LEFT(svl);
561 #ifdef PERL_PRESERVE_IVUV
562     /* We must see if we can perform the addition with integers if possible,
563        as the integer code detects overflow while the NV code doesn't.
564        If either argument hasn't had a numeric conversion yet attempt to get
565        the IV. It's important to do this now, rather than just assuming that
566        it's not IOK as a PV of "9223372036854775806" may not take well to NV
567        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
568        integer in case the second argument is IV=9223372036854775806
569        We can (now) rely on sv_2iv to do the right thing, only setting the
570        public IOK flag if the value in the NV (or PV) slot is truly integer.
571
572        A side effect is that this also aggressively prefers integer maths over
573        fp maths for integer values.
574
575        How to detect overflow?
576
577        C 99 section 6.2.6.1 says
578
579        The range of nonnegative values of a signed integer type is a subrange
580        of the corresponding unsigned integer type, and the representation of
581        the same value in each type is the same. A computation involving
582        unsigned operands can never overflow, because a result that cannot be
583        represented by the resulting unsigned integer type is reduced modulo
584        the number that is one greater than the largest value that can be
585        represented by the resulting type.
586
587        (the 9th paragraph)
588
589        which I read as "unsigned ints wrap."
590
591        signed integer overflow seems to be classed as "exception condition"
592
593        If an exceptional condition occurs during the evaluation of an
594        expression (that is, if the result is not mathematically defined or not
595        in the range of representable values for its type), the behavior is
596        undefined.
597
598        (6.5, the 5th paragraph)
599
600        I had assumed that on 2s complement machines signed arithmetic would
601        wrap, hence coded pp_add and pp_subtract on the assumption that
602        everything perl builds on would be happy.  After much wailing and
603        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
604        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
605        unsigned code below is actually shorter than the old code. :-)
606     */
607
608     if (SvIV_please_nomg(svr)) {
609         /* Unless the left argument is integer in range we are going to have to
610            use NV maths. Hence only attempt to coerce the right argument if
611            we know the left is integer.  */
612         UV auv = 0;
613         bool auvok = FALSE;
614         bool a_valid = 0;
615
616         if (!useleft) {
617             auv = 0;
618             a_valid = auvok = 1;
619             /* left operand is undef, treat as zero. + 0 is identity,
620                Could SETi or SETu right now, but space optimise by not adding
621                lots of code to speed up what is probably a rarish case.  */
622         } else {
623             /* Left operand is defined, so is it IV? */
624             if (SvIV_please_nomg(svl)) {
625                 if ((auvok = SvUOK(svl)))
626                     auv = SvUVX(svl);
627                 else {
628                     const IV aiv = SvIVX(svl);
629                     if (aiv >= 0) {
630                         auv = aiv;
631                         auvok = 1;      /* Now acting as a sign flag.  */
632                     } else { /* 2s complement assumption for IV_MIN */
633                         auv = (UV)-aiv;
634                     }
635                 }
636                 a_valid = 1;
637             }
638         }
639         if (a_valid) {
640             bool result_good = 0;
641             UV result;
642             UV buv;
643             bool buvok = SvUOK(svr);
644         
645             if (buvok)
646                 buv = SvUVX(svr);
647             else {
648                 const IV biv = SvIVX(svr);
649                 if (biv >= 0) {
650                     buv = biv;
651                     buvok = 1;
652                 } else
653                     buv = (UV)-biv;
654             }
655             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
656                else "IV" now, independent of how it came in.
657                if a, b represents positive, A, B negative, a maps to -A etc
658                a + b =>  (a + b)
659                A + b => -(a - b)
660                a + B =>  (a - b)
661                A + B => -(a + b)
662                all UV maths. negate result if A negative.
663                add if signs same, subtract if signs differ. */
664
665             if (auvok ^ buvok) {
666                 /* Signs differ.  */
667                 if (auv >= buv) {
668                     result = auv - buv;
669                     /* Must get smaller */
670                     if (result <= auv)
671                         result_good = 1;
672                 } else {
673                     result = buv - auv;
674                     if (result <= buv) {
675                         /* result really should be -(auv-buv). as its negation
676                            of true value, need to swap our result flag  */
677                         auvok = !auvok;
678                         result_good = 1;
679                     }
680                 }
681             } else {
682                 /* Signs same */
683                 result = auv + buv;
684                 if (result >= auv)
685                     result_good = 1;
686             }
687             if (result_good) {
688                 SP--;
689                 if (auvok)
690                     SETu( result );
691                 else {
692                     /* Negate result */
693                     if (result <= (UV)IV_MIN)
694                         SETi( -(IV)result );
695                     else {
696                         /* result valid, but out of range for IV.  */
697                         SETn( -(NV)result );
698                     }
699                 }
700                 RETURN;
701             } /* Overflow, drop through to NVs.  */
702         }
703     }
704 #endif
705     {
706         NV value = SvNV_nomg(svr);
707         (void)POPs;
708         if (!useleft) {
709             /* left operand is undef, treat as zero. + 0.0 is identity. */
710             SETn(value);
711             RETURN;
712         }
713         SETn( value + SvNV_nomg(svl) );
714         RETURN;
715     }
716 }
717
718 PP(pp_aelemfast)
719 {
720     dVAR; dSP;
721     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
722         ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
723     const U32 lval = PL_op->op_flags & OPf_MOD;
724     SV** const svp = av_fetch(av, PL_op->op_private, lval);
725     SV *sv = (svp ? *svp : &PL_sv_undef);
726     EXTEND(SP, 1);
727     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
728         mg_get(sv);
729     PUSHs(sv);
730     RETURN;
731 }
732
733 PP(pp_join)
734 {
735     dVAR; dSP; dMARK; dTARGET;
736     MARK++;
737     do_join(TARG, *MARK, MARK, SP);
738     SP = MARK;
739     SETs(TARG);
740     RETURN;
741 }
742
743 PP(pp_pushre)
744 {
745     dVAR; dSP;
746 #ifdef DEBUGGING
747     /*
748      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
749      * will be enough to hold an OP*.
750      */
751     SV* const sv = sv_newmortal();
752     sv_upgrade(sv, SVt_PVLV);
753     LvTYPE(sv) = '/';
754     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
755     XPUSHs(sv);
756 #else
757     XPUSHs(MUTABLE_SV(PL_op));
758 #endif
759     RETURN;
760 }
761
762 /* Oversized hot code. */
763
764 PP(pp_print)
765 {
766     dVAR; dSP; dMARK; dORIGMARK;
767     PerlIO *fp;
768     MAGIC *mg;
769     GV * const gv
770         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
771     IO *io = GvIO(gv);
772
773     if (io
774         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
775     {
776       had_magic:
777         if (MARK == ORIGMARK) {
778             /* If using default handle then we need to make space to
779              * pass object as 1st arg, so move other args up ...
780              */
781             MEXTEND(SP, 1);
782             ++MARK;
783             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
784             ++SP;
785         }
786         return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
787                                 mg,
788                                 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
789                                  | (PL_op->op_type == OP_SAY
790                                     ? TIED_METHOD_SAY : 0)), sp - mark);
791     }
792     if (!io) {
793         if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
794             && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
795             goto had_magic;
796         report_evil_fh(gv);
797         SETERRNO(EBADF,RMS_IFI);
798         goto just_say_no;
799     }
800     else if (!(fp = IoOFP(io))) {
801         if (IoIFP(io))
802             report_wrongway_fh(gv, '<');
803         else
804             report_evil_fh(gv);
805         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
806         goto just_say_no;
807     }
808     else {
809         SV * const ofs = GvSV(PL_ofsgv); /* $, */
810         MARK++;
811         if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
812             while (MARK <= SP) {
813                 if (!do_print(*MARK, fp))
814                     break;
815                 MARK++;
816                 if (MARK <= SP) {
817                     /* don't use 'ofs' here - it may be invalidated by magic callbacks */
818                     if (!do_print(GvSV(PL_ofsgv), fp)) {
819                         MARK--;
820                         break;
821                     }
822                 }
823             }
824         }
825         else {
826             while (MARK <= SP) {
827                 if (!do_print(*MARK, fp))
828                     break;
829                 MARK++;
830             }
831         }
832         if (MARK <= SP)
833             goto just_say_no;
834         else {
835             if (PL_op->op_type == OP_SAY) {
836                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
837                     goto just_say_no;
838             }
839             else if (PL_ors_sv && SvOK(PL_ors_sv))
840                 if (!do_print(PL_ors_sv, fp)) /* $\ */
841                     goto just_say_no;
842
843             if (IoFLAGS(io) & IOf_FLUSH)
844                 if (PerlIO_flush(fp) == EOF)
845                     goto just_say_no;
846         }
847     }
848     SP = ORIGMARK;
849     XPUSHs(&PL_sv_yes);
850     RETURN;
851
852   just_say_no:
853     SP = ORIGMARK;
854     XPUSHs(&PL_sv_undef);
855     RETURN;
856 }
857
858 PP(pp_rv2av)
859 {
860     dVAR; dSP; dTOPss;
861     const I32 gimme = GIMME_V;
862     static const char an_array[] = "an ARRAY";
863     static const char a_hash[] = "a HASH";
864     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
865     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
866
867     SvGETMAGIC(sv);
868     if (SvROK(sv)) {
869         if (SvAMAGIC(sv)) {
870             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
871         }
872         sv = SvRV(sv);
873         if (SvTYPE(sv) != type)
874             /* diag_listed_as: Not an ARRAY reference */
875             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
876         else if (PL_op->op_flags & OPf_MOD
877                 && PL_op->op_private & OPpLVAL_INTRO)
878             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
879     }
880     else if (SvTYPE(sv) != type) {
881             GV *gv;
882         
883             if (!isGV_with_GP(sv)) {
884                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
885                                      type, &sp);
886                 if (!gv)
887                     RETURN;
888             }
889             else {
890                 gv = MUTABLE_GV(sv);
891             }
892             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
893             if (PL_op->op_private & OPpLVAL_INTRO)
894                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
895     }
896     if (PL_op->op_flags & OPf_REF) {
897                 SETs(sv);
898                 RETURN;
899     }
900     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
901               const I32 flags = is_lvalue_sub();
902               if (flags && !(flags & OPpENTERSUB_INARGS)) {
903                 if (gimme != G_ARRAY)
904                     goto croak_cant_return;
905                 SETs(sv);
906                 RETURN;
907               }
908     }
909
910     if (is_pp_rv2av) {
911         AV *const av = MUTABLE_AV(sv);
912         /* The guts of pp_rv2av, with no intending change to preserve history
913            (until such time as we get tools that can do blame annotation across
914            whitespace changes.  */
915         if (gimme == G_ARRAY) {
916             SP--;
917             PUTBACK;
918             S_pushav(aTHX_ av);
919             SPAGAIN;
920         }
921         else if (gimme == G_SCALAR) {
922             dTARGET;
923             const I32 maxarg = AvFILL(av) + 1;
924             SETi(maxarg);
925         }
926     } else {
927         /* The guts of pp_rv2hv  */
928         if (gimme == G_ARRAY) { /* array wanted */
929             *PL_stack_sp = sv;
930             return Perl_do_kv(aTHX);
931         }
932         else if ((PL_op->op_private & OPpTRUEBOOL
933               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
934                  && block_gimme() == G_VOID  ))
935               && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
936             SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
937         else if (gimme == G_SCALAR) {
938             dTARGET;
939             TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
940             SPAGAIN;
941             SETTARG;
942         }
943     }
944     RETURN;
945
946  croak_cant_return:
947     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
948                is_pp_rv2av ? "array" : "hash");
949     RETURN;
950 }
951
952 STATIC void
953 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
954 {
955     dVAR;
956
957     PERL_ARGS_ASSERT_DO_ODDBALL;
958
959     if (*oddkey) {
960         if (ckWARN(WARN_MISC)) {
961             const char *err;
962             if (oddkey == firstkey &&
963                 SvROK(*oddkey) &&
964                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
965                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
966             {
967                 err = "Reference found where even-sized list expected";
968             }
969             else
970                 err = "Odd number of elements in hash assignment";
971             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
972         }
973
974     }
975 }
976
977 PP(pp_aassign)
978 {
979     dVAR; dSP;
980     SV **lastlelem = PL_stack_sp;
981     SV **lastrelem = PL_stack_base + POPMARK;
982     SV **firstrelem = PL_stack_base + POPMARK + 1;
983     SV **firstlelem = lastrelem + 1;
984
985     SV **relem;
986     SV **lelem;
987
988     SV *sv;
989     AV *ary;
990
991     I32 gimme;
992     HV *hash;
993     I32 i;
994     int magic;
995     U32 lval = 0;
996
997     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
998     gimme = GIMME_V;
999     if (gimme == G_ARRAY)
1000         lval = PL_op->op_flags & OPf_MOD || LVRET;
1001
1002     /* If there's a common identifier on both sides we have to take
1003      * special care that assigning the identifier on the left doesn't
1004      * clobber a value on the right that's used later in the list.
1005      * Don't bother if LHS is just an empty hash or array.
1006      */
1007
1008     if (    (PL_op->op_private & OPpASSIGN_COMMON)
1009         &&  (
1010                firstlelem != lastlelem
1011             || ! ((sv = *firstlelem))
1012             || SvMAGICAL(sv)
1013             || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1014             || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1015             || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1016             )
1017     ) {
1018         EXTEND_MORTAL(lastrelem - firstrelem + 1);
1019         for (relem = firstrelem; relem <= lastrelem; relem++) {
1020             if ((sv = *relem)) {
1021                 TAINT_NOT;      /* Each item is independent */
1022
1023                 /* Dear TODO test in t/op/sort.t, I love you.
1024                    (It's relying on a panic, not a "semi-panic" from newSVsv()
1025                    and then an assertion failure below.)  */
1026                 if (SvIS_FREED(sv)) {
1027                     Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1028                                (void*)sv);
1029                 }
1030                 /* Not newSVsv(), as it does not allow copy-on-write,
1031                    resulting in wasteful copies.  We need a second copy of
1032                    a temp here, hence the SV_NOSTEAL.  */
1033                 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1034                                                |SV_NOSTEAL);
1035             }
1036         }
1037     }
1038
1039     relem = firstrelem;
1040     lelem = firstlelem;
1041     ary = NULL;
1042     hash = NULL;
1043
1044     while (lelem <= lastlelem) {
1045         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1046         sv = *lelem++;
1047         switch (SvTYPE(sv)) {
1048         case SVt_PVAV:
1049             ary = MUTABLE_AV(sv);
1050             magic = SvMAGICAL(ary) != 0;
1051             ENTER;
1052             SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1053             av_clear(ary);
1054             av_extend(ary, lastrelem - relem);
1055             i = 0;
1056             while (relem <= lastrelem) {        /* gobble up all the rest */
1057                 SV **didstore;
1058                 assert(*relem);
1059                 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1060                 sv = newSV(0);
1061                 sv_setsv_nomg(sv, *relem);
1062                 *(relem++) = sv;
1063                 didstore = av_store(ary,i++,sv);
1064                 if (magic) {
1065                     if (!didstore)
1066                         sv_2mortal(sv);
1067                     if (SvSMAGICAL(sv))
1068                         mg_set(sv);
1069                 }
1070                 TAINT_NOT;
1071             }
1072             if (PL_delaymagic & DM_ARRAY_ISA)
1073                 SvSETMAGIC(MUTABLE_SV(ary));
1074             LEAVE;
1075             break;
1076         case SVt_PVHV: {                                /* normal hash */
1077                 SV *tmpstr;
1078                 int odd;
1079                 int duplicates = 0;
1080                 SV** topelem = relem;
1081                 SV **firsthashrelem = relem;
1082
1083                 hash = MUTABLE_HV(sv);
1084                 magic = SvMAGICAL(hash) != 0;
1085
1086                 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1087                 if ( odd ) {
1088                     do_oddball(lastrelem, firsthashrelem);
1089                     /* we have firstlelem to reuse, it's not needed anymore
1090                      */
1091                     *(lastrelem+1) = &PL_sv_undef;
1092                 }
1093
1094                 ENTER;
1095                 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1096                 hv_clear(hash);
1097                 while (relem < lastrelem+odd) { /* gobble up all the rest */
1098                     HE *didstore;
1099                     assert(*relem);
1100                     /* Copy the key if aassign is called in lvalue context,
1101                        to avoid having the next op modify our rhs.  Copy
1102                        it also if it is gmagical, lest it make the
1103                        hv_store_ent call below croak, leaking the value. */
1104                     sv = lval || SvGMAGICAL(*relem)
1105                          ? sv_mortalcopy(*relem)
1106                          : *relem;
1107                     relem++;
1108                     assert(*relem);
1109                     SvGETMAGIC(*relem);
1110                     tmpstr = newSV(0);
1111                     sv_setsv_nomg(tmpstr,*relem++);     /* value */
1112                     if (gimme == G_ARRAY) {
1113                         if (hv_exists_ent(hash, sv, 0))
1114                             /* key overwrites an existing entry */
1115                             duplicates += 2;
1116                         else {
1117                             /* copy element back: possibly to an earlier
1118                              * stack location if we encountered dups earlier,
1119                              * possibly to a later stack location if odd */
1120                             *topelem++ = sv;
1121                             *topelem++ = tmpstr;
1122                         }
1123                     }
1124                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1125                     if (magic) {
1126                         if (!didstore) sv_2mortal(tmpstr);
1127                         SvSETMAGIC(tmpstr);
1128                     }
1129                     TAINT_NOT;
1130                 }
1131                 LEAVE;
1132                 if (duplicates && gimme == G_ARRAY) {
1133                     /* at this point we have removed the duplicate key/value
1134                      * pairs from the stack, but the remaining values may be
1135                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1136                      * the (a 2), but the stack now probably contains
1137                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1138                      * obliterates the earlier key. So refresh all values. */
1139                     lastrelem -= duplicates;
1140                     relem = firsthashrelem;
1141                     while (relem < lastrelem+odd) {
1142                         HE *he;
1143                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1144                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1145                     }
1146                 }
1147                 if (odd && gimme == G_ARRAY) lastrelem++;
1148             }
1149             break;
1150         default:
1151             if (SvIMMORTAL(sv)) {
1152                 if (relem <= lastrelem)
1153                     relem++;
1154                 break;
1155             }
1156             if (relem <= lastrelem) {
1157                 if (
1158                   SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1159                   (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1160                 )
1161                     Perl_warner(aTHX_
1162                        packWARN(WARN_MISC),
1163                       "Useless assignment to a temporary"
1164                     );
1165                 sv_setsv(sv, *relem);
1166                 *(relem++) = sv;
1167             }
1168             else
1169                 sv_setsv(sv, &PL_sv_undef);
1170             SvSETMAGIC(sv);
1171             break;
1172         }
1173     }
1174     if (PL_delaymagic & ~DM_DELAY) {
1175         /* Will be used to set PL_tainting below */
1176         Uid_t tmp_uid  = PerlProc_getuid();
1177         Uid_t tmp_euid = PerlProc_geteuid();
1178         Gid_t tmp_gid  = PerlProc_getgid();
1179         Gid_t tmp_egid = PerlProc_getegid();
1180
1181         if (PL_delaymagic & DM_UID) {
1182 #ifdef HAS_SETRESUID
1183             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1184                             (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1185                             (Uid_t)-1);
1186 #else
1187 #  ifdef HAS_SETREUID
1188             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1189                            (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1190 #  else
1191 #    ifdef HAS_SETRUID
1192             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1193                 (void)setruid(PL_delaymagic_uid);
1194                 PL_delaymagic &= ~DM_RUID;
1195             }
1196 #    endif /* HAS_SETRUID */
1197 #    ifdef HAS_SETEUID
1198             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1199                 (void)seteuid(PL_delaymagic_euid);
1200                 PL_delaymagic &= ~DM_EUID;
1201             }
1202 #    endif /* HAS_SETEUID */
1203             if (PL_delaymagic & DM_UID) {
1204                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1205                     DIE(aTHX_ "No setreuid available");
1206                 (void)PerlProc_setuid(PL_delaymagic_uid);
1207             }
1208 #  endif /* HAS_SETREUID */
1209 #endif /* HAS_SETRESUID */
1210             tmp_uid  = PerlProc_getuid();
1211             tmp_euid = PerlProc_geteuid();
1212         }
1213         if (PL_delaymagic & DM_GID) {
1214 #ifdef HAS_SETRESGID
1215             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1216                             (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1217                             (Gid_t)-1);
1218 #else
1219 #  ifdef HAS_SETREGID
1220             (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1221                            (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1222 #  else
1223 #    ifdef HAS_SETRGID
1224             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1225                 (void)setrgid(PL_delaymagic_gid);
1226                 PL_delaymagic &= ~DM_RGID;
1227             }
1228 #    endif /* HAS_SETRGID */
1229 #    ifdef HAS_SETEGID
1230             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1231                 (void)setegid(PL_delaymagic_egid);
1232                 PL_delaymagic &= ~DM_EGID;
1233             }
1234 #    endif /* HAS_SETEGID */
1235             if (PL_delaymagic & DM_GID) {
1236                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1237                     DIE(aTHX_ "No setregid available");
1238                 (void)PerlProc_setgid(PL_delaymagic_gid);
1239             }
1240 #  endif /* HAS_SETREGID */
1241 #endif /* HAS_SETRESGID */
1242             tmp_gid  = PerlProc_getgid();
1243             tmp_egid = PerlProc_getegid();
1244         }
1245         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1246 #ifdef NO_TAINT_SUPPORT
1247         PERL_UNUSED_VAR(tmp_uid);
1248         PERL_UNUSED_VAR(tmp_euid);
1249         PERL_UNUSED_VAR(tmp_gid);
1250         PERL_UNUSED_VAR(tmp_egid);
1251 #endif
1252     }
1253     PL_delaymagic = 0;
1254
1255     if (gimme == G_VOID)
1256         SP = firstrelem - 1;
1257     else if (gimme == G_SCALAR) {
1258         dTARGET;
1259         SP = firstrelem;
1260         SETi(lastrelem - firstrelem + 1);
1261     }
1262     else {
1263         if (ary || hash)
1264             /* note that in this case *firstlelem may have been overwritten
1265                by sv_undef in the odd hash case */
1266             SP = lastrelem;
1267         else {
1268             SP = firstrelem + (lastlelem - firstlelem);
1269             lelem = firstlelem + (relem - firstrelem);
1270             while (relem <= SP)
1271                 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1272         }
1273     }
1274
1275     RETURN;
1276 }
1277
1278 PP(pp_qr)
1279 {
1280     dVAR; dSP;
1281     PMOP * const pm = cPMOP;
1282     REGEXP * rx = PM_GETRE(pm);
1283     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1284     SV * const rv = sv_newmortal();
1285     CV **cvp;
1286     CV *cv;
1287
1288     SvUPGRADE(rv, SVt_IV);
1289     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1290        loathe to use it here, but it seems to be the right fix. Or close.
1291        The key part appears to be that it's essential for pp_qr to return a new
1292        object (SV), which implies that there needs to be an effective way to
1293        generate a new SV from the existing SV that is pre-compiled in the
1294        optree.  */
1295     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1296     SvROK_on(rv);
1297
1298     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1299     if ((cv = *cvp) && CvCLONE(*cvp)) {
1300         *cvp = cv_clone(cv);
1301         SvREFCNT_dec_NN(cv);
1302     }
1303
1304     if (pkg) {
1305         HV *const stash = gv_stashsv(pkg, GV_ADD);
1306         SvREFCNT_dec_NN(pkg);
1307         (void)sv_bless(rv, stash);
1308     }
1309
1310     if (RX_ISTAINTED(rx)) {
1311         SvTAINTED_on(rv);
1312         SvTAINTED_on(SvRV(rv));
1313     }
1314     XPUSHs(rv);
1315     RETURN;
1316 }
1317
1318 PP(pp_match)
1319 {
1320     dVAR; dSP; dTARG;
1321     PMOP *pm = cPMOP;
1322     PMOP *dynpm = pm;
1323     const char *s;
1324     const char *strend;
1325     I32 curpos = 0; /* initial pos() or current $+[0] */
1326     I32 global;
1327     U8 r_flags = 0;
1328     const char *truebase;                       /* Start of string  */
1329     REGEXP *rx = PM_GETRE(pm);
1330     bool rxtainted;
1331     const I32 gimme = GIMME;
1332     STRLEN len;
1333     const I32 oldsave = PL_savestack_ix;
1334     I32 had_zerolen = 0;
1335     MAGIC *mg = NULL;
1336
1337     if (PL_op->op_flags & OPf_STACKED)
1338         TARG = POPs;
1339     else if (PL_op->op_private & OPpTARGET_MY)
1340         GETTARGET;
1341     else {
1342         TARG = DEFSV;
1343         EXTEND(SP,1);
1344     }
1345
1346     PUTBACK;                            /* EVAL blocks need stack_sp. */
1347     /* Skip get-magic if this is a qr// clone, because regcomp has
1348        already done it. */
1349     truebase = ReANY(rx)->mother_re
1350          ? SvPV_nomg_const(TARG, len)
1351          : SvPV_const(TARG, len);
1352     if (!truebase)
1353         DIE(aTHX_ "panic: pp_match");
1354     strend = truebase + len;
1355     rxtainted = (RX_ISTAINTED(rx) ||
1356                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1357     TAINT_NOT;
1358
1359     /* We need to know this in case we fail out early - pos() must be reset */
1360     global = dynpm->op_pmflags & PMf_GLOBAL;
1361
1362     /* PMdf_USED is set after a ?? matches once */
1363     if (
1364 #ifdef USE_ITHREADS
1365         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1366 #else
1367         pm->op_pmflags & PMf_USED
1368 #endif
1369     ) {
1370         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1371         goto nope;
1372     }
1373
1374     /* empty pattern special-cased to use last successful pattern if
1375        possible, except for qr// */
1376     if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1377      && PL_curpm) {
1378         pm = PL_curpm;
1379         rx = PM_GETRE(pm);
1380     }
1381
1382     if (RX_MINLEN(rx) > (I32)len) {
1383         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
1384         goto nope;
1385     }
1386
1387     /* get pos() if //g */
1388     if (global) {
1389         mg = mg_find_mglob(TARG);
1390         if (mg && mg->mg_len >= 0) {
1391             curpos = mg->mg_len;
1392             /* last time pos() was set, it was zero-length match */
1393             if (mg->mg_flags & MGf_MINMATCH)
1394                 had_zerolen = 1;
1395         }
1396     }
1397
1398 #ifdef PERL_SAWAMPERSAND
1399     if (       RX_NPARENS(rx)
1400             || PL_sawampersand
1401             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1402             || (dynpm->op_pmflags & PMf_KEEPCOPY)
1403     )
1404 #endif
1405     {
1406         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1407         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1408          * only on the first iteration. Therefore we need to copy $' as well
1409          * as $&, to make the rest of the string available for captures in
1410          * subsequent iterations */
1411         if (! (global && gimme == G_ARRAY))
1412             r_flags |= REXEC_COPY_SKIP_POST;
1413     };
1414 #ifdef PERL_SAWAMPERSAND
1415     if (dynpm->op_pmflags & PMf_KEEPCOPY)
1416         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1417         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1418 #endif
1419
1420     s = truebase;
1421
1422   play_it_again:
1423     if (global)
1424         s = truebase + curpos;
1425
1426     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1427                      had_zerolen, TARG, NULL, r_flags))
1428         goto nope;
1429
1430     PL_curpm = pm;
1431     if (dynpm->op_pmflags & PMf_ONCE)
1432 #ifdef USE_ITHREADS
1433         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1434 #else
1435         dynpm->op_pmflags |= PMf_USED;
1436 #endif
1437
1438     if (rxtainted)
1439         RX_MATCH_TAINTED_on(rx);
1440     TAINT_IF(RX_MATCH_TAINTED(rx));
1441
1442     /* update pos */
1443
1444     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1445         if (!mg)
1446             mg = sv_magicext_mglob(TARG);
1447         mg->mg_len = RX_OFFS(rx)[0].end;
1448         if (RX_ZERO_LEN(rx))
1449             mg->mg_flags |= MGf_MINMATCH;
1450         else
1451             mg->mg_flags &= ~MGf_MINMATCH;
1452     }
1453
1454     if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1455         LEAVE_SCOPE(oldsave);
1456         RETPUSHYES;
1457     }
1458
1459     /* push captures on stack */
1460
1461     {
1462         const I32 nparens = RX_NPARENS(rx);
1463         I32 i = (global && !nparens) ? 1 : 0;
1464
1465         SPAGAIN;                        /* EVAL blocks could move the stack. */
1466         EXTEND(SP, nparens + i);
1467         EXTEND_MORTAL(nparens + i);
1468         for (i = !i; i <= nparens; i++) {
1469             PUSHs(sv_newmortal());
1470             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1471                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1472                 const char * const s = RX_OFFS(rx)[i].start + truebase;
1473                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1474                     len < 0 || len > strend - s)
1475                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1476                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1477                         (long) i, (long) RX_OFFS(rx)[i].start,
1478                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1479                 sv_setpvn(*SP, s, len);
1480                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1481                     SvUTF8_on(*SP);
1482             }
1483         }
1484         if (global) {
1485             curpos = (UV)RX_OFFS(rx)[0].end;
1486             had_zerolen = RX_ZERO_LEN(rx);
1487             PUTBACK;                    /* EVAL blocks may use stack */
1488             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1489             goto play_it_again;
1490         }
1491         LEAVE_SCOPE(oldsave);
1492         RETURN;
1493     }
1494     /* NOTREACHED */
1495
1496 nope:
1497     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1498         if (!mg)
1499             mg = mg_find_mglob(TARG);
1500         if (mg)
1501             mg->mg_len = -1;
1502     }
1503     LEAVE_SCOPE(oldsave);
1504     if (gimme == G_ARRAY)
1505         RETURN;
1506     RETPUSHNO;
1507 }
1508
1509 OP *
1510 Perl_do_readline(pTHX)
1511 {
1512     dVAR; dSP; dTARGETSTACKED;
1513     SV *sv;
1514     STRLEN tmplen = 0;
1515     STRLEN offset;
1516     PerlIO *fp;
1517     IO * const io = GvIO(PL_last_in_gv);
1518     const I32 type = PL_op->op_type;
1519     const I32 gimme = GIMME_V;
1520
1521     if (io) {
1522         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1523         if (mg) {
1524             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1525             if (gimme == G_SCALAR) {
1526                 SPAGAIN;
1527                 SvSetSV_nosteal(TARG, TOPs);
1528                 SETTARG;
1529             }
1530             return NORMAL;
1531         }
1532     }
1533     fp = NULL;
1534     if (io) {
1535         fp = IoIFP(io);
1536         if (!fp) {
1537             if (IoFLAGS(io) & IOf_ARGV) {
1538                 if (IoFLAGS(io) & IOf_START) {
1539                     IoLINES(io) = 0;
1540                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1541                         IoFLAGS(io) &= ~IOf_START;
1542                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1543                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1544                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1545                         SvSETMAGIC(GvSV(PL_last_in_gv));
1546                         fp = IoIFP(io);
1547                         goto have_fp;
1548                     }
1549                 }
1550                 fp = nextargv(PL_last_in_gv);
1551                 if (!fp) { /* Note: fp != IoIFP(io) */
1552                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1553                 }
1554             }
1555             else if (type == OP_GLOB)
1556                 fp = Perl_start_glob(aTHX_ POPs, io);
1557         }
1558         else if (type == OP_GLOB)
1559             SP--;
1560         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1561             report_wrongway_fh(PL_last_in_gv, '>');
1562         }
1563     }
1564     if (!fp) {
1565         if ((!io || !(IoFLAGS(io) & IOf_START))
1566             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1567         {
1568             if (type == OP_GLOB)
1569                 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
1570                             "glob failed (can't start child: %s)",
1571                             Strerror(errno));
1572             else
1573                 report_evil_fh(PL_last_in_gv);
1574         }
1575         if (gimme == G_SCALAR) {
1576             /* undef TARG, and push that undefined value */
1577             if (type != OP_RCATLINE) {
1578                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1579                 SvOK_off(TARG);
1580             }
1581             PUSHTARG;
1582         }
1583         RETURN;
1584     }
1585   have_fp:
1586     if (gimme == G_SCALAR) {
1587         sv = TARG;
1588         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1589             mg_get(sv);
1590         if (SvROK(sv)) {
1591             if (type == OP_RCATLINE)
1592                 SvPV_force_nomg_nolen(sv);
1593             else
1594                 sv_unref(sv);
1595         }
1596         else if (isGV_with_GP(sv)) {
1597             SvPV_force_nomg_nolen(sv);
1598         }
1599         SvUPGRADE(sv, SVt_PV);
1600         tmplen = SvLEN(sv);     /* remember if already alloced */
1601         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1602             /* try short-buffering it. Please update t/op/readline.t
1603              * if you change the growth length.
1604              */
1605             Sv_Grow(sv, 80);
1606         }
1607         offset = 0;
1608         if (type == OP_RCATLINE && SvOK(sv)) {
1609             if (!SvPOK(sv)) {
1610                 SvPV_force_nomg_nolen(sv);
1611             }
1612             offset = SvCUR(sv);
1613         }
1614     }
1615     else {
1616         sv = sv_2mortal(newSV(80));
1617         offset = 0;
1618     }
1619
1620     /* This should not be marked tainted if the fp is marked clean */
1621 #define MAYBE_TAINT_LINE(io, sv) \
1622     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1623         TAINT;                          \
1624         SvTAINTED_on(sv);               \
1625     }
1626
1627 /* delay EOF state for a snarfed empty file */
1628 #define SNARF_EOF(gimme,rs,io,sv) \
1629     (gimme != G_SCALAR || SvCUR(sv)                                     \
1630      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1631
1632     for (;;) {
1633         PUTBACK;
1634         if (!sv_gets(sv, fp, offset)
1635             && (type == OP_GLOB
1636                 || SNARF_EOF(gimme, PL_rs, io, sv)
1637                 || PerlIO_error(fp)))
1638         {
1639             PerlIO_clearerr(fp);
1640             if (IoFLAGS(io) & IOf_ARGV) {
1641                 fp = nextargv(PL_last_in_gv);
1642                 if (fp)
1643                     continue;
1644                 (void)do_close(PL_last_in_gv, FALSE);
1645             }
1646             else if (type == OP_GLOB) {
1647                 if (!do_close(PL_last_in_gv, FALSE)) {
1648                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1649                                    "glob failed (child exited with status %d%s)",
1650                                    (int)(STATUS_CURRENT >> 8),
1651                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1652                 }
1653             }
1654             if (gimme == G_SCALAR) {
1655                 if (type != OP_RCATLINE) {
1656                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1657                     SvOK_off(TARG);
1658                 }
1659                 SPAGAIN;
1660                 PUSHTARG;
1661             }
1662             MAYBE_TAINT_LINE(io, sv);
1663             RETURN;
1664         }
1665         MAYBE_TAINT_LINE(io, sv);
1666         IoLINES(io)++;
1667         IoFLAGS(io) |= IOf_NOLINE;
1668         SvSETMAGIC(sv);
1669         SPAGAIN;
1670         XPUSHs(sv);
1671         if (type == OP_GLOB) {
1672             const char *t1;
1673
1674             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1675                 char * const tmps = SvEND(sv) - 1;
1676                 if (*tmps == *SvPVX_const(PL_rs)) {
1677                     *tmps = '\0';
1678                     SvCUR_set(sv, SvCUR(sv) - 1);
1679                 }
1680             }
1681             for (t1 = SvPVX_const(sv); *t1; t1++)
1682                 if (!isALPHANUMERIC(*t1) &&
1683                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1684                         break;
1685             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1686                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1687                 continue;
1688             }
1689         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1690              if (ckWARN(WARN_UTF8)) {
1691                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1692                 const STRLEN len = SvCUR(sv) - offset;
1693                 const U8 *f;
1694
1695                 if (!is_utf8_string_loc(s, len, &f))
1696                     /* Emulate :encoding(utf8) warning in the same case. */
1697                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1698                                 "utf8 \"\\x%02X\" does not map to Unicode",
1699                                 f < (U8*)SvEND(sv) ? *f : 0);
1700              }
1701         }
1702         if (gimme == G_ARRAY) {
1703             if (SvLEN(sv) - SvCUR(sv) > 20) {
1704                 SvPV_shrink_to_cur(sv);
1705             }
1706             sv = sv_2mortal(newSV(80));
1707             continue;
1708         }
1709         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1710             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1711             const STRLEN new_len
1712                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1713             SvPV_renew(sv, new_len);
1714         }
1715         RETURN;
1716     }
1717 }
1718
1719 PP(pp_helem)
1720 {
1721     dVAR; dSP;
1722     HE* he;
1723     SV **svp;
1724     SV * const keysv = POPs;
1725     HV * const hv = MUTABLE_HV(POPs);
1726     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1727     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1728     SV *sv;
1729     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1730     bool preeminent = TRUE;
1731
1732     if (SvTYPE(hv) != SVt_PVHV)
1733         RETPUSHUNDEF;
1734
1735     if (localizing) {
1736         MAGIC *mg;
1737         HV *stash;
1738
1739         /* If we can determine whether the element exist,
1740          * Try to preserve the existenceness of a tied hash
1741          * element by using EXISTS and DELETE if possible.
1742          * Fallback to FETCH and STORE otherwise. */
1743         if (SvCANEXISTDELETE(hv))
1744             preeminent = hv_exists_ent(hv, keysv, 0);
1745     }
1746
1747     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1748     svp = he ? &HeVAL(he) : NULL;
1749     if (lval) {
1750         if (!svp || !*svp || *svp == &PL_sv_undef) {
1751             SV* lv;
1752             SV* key2;
1753             if (!defer) {
1754                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1755             }
1756             lv = sv_newmortal();
1757             sv_upgrade(lv, SVt_PVLV);
1758             LvTYPE(lv) = 'y';
1759             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1760             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
1761             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1762             LvTARGLEN(lv) = 1;
1763             PUSHs(lv);
1764             RETURN;
1765         }
1766         if (localizing) {
1767             if (HvNAME_get(hv) && isGV(*svp))
1768                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1769             else if (preeminent)
1770                 save_helem_flags(hv, keysv, svp,
1771                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1772             else
1773                 SAVEHDELETE(hv, keysv);
1774         }
1775         else if (PL_op->op_private & OPpDEREF) {
1776             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1777             RETURN;
1778         }
1779     }
1780     sv = (svp && *svp ? *svp : &PL_sv_undef);
1781     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1782      * was to make C<local $tied{foo} = $tied{foo}> possible.
1783      * However, it seems no longer to be needed for that purpose, and
1784      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1785      * would loop endlessly since the pos magic is getting set on the
1786      * mortal copy and lost. However, the copy has the effect of
1787      * triggering the get magic, and losing it altogether made things like
1788      * c<$tied{foo};> in void context no longer do get magic, which some
1789      * code relied on. Also, delayed triggering of magic on @+ and friends
1790      * meant the original regex may be out of scope by now. So as a
1791      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1792      * being called too many times). */
1793     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1794         mg_get(sv);
1795     PUSHs(sv);
1796     RETURN;
1797 }
1798
1799 PP(pp_iter)
1800 {
1801     dVAR; dSP;
1802     PERL_CONTEXT *cx;
1803     SV *oldsv;
1804     SV **itersvp;
1805
1806     EXTEND(SP, 1);
1807     cx = &cxstack[cxstack_ix];
1808     itersvp = CxITERVAR(cx);
1809
1810     switch (CxTYPE(cx)) {
1811
1812     case CXt_LOOP_LAZYSV: /* string increment */
1813     {
1814         SV* cur = cx->blk_loop.state_u.lazysv.cur;
1815         SV *end = cx->blk_loop.state_u.lazysv.end;
1816         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1817            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1818         STRLEN maxlen = 0;
1819         const char *max = SvPV_const(end, maxlen);
1820         if (SvNIOK(cur) || SvCUR(cur) > maxlen)
1821             RETPUSHNO;
1822
1823         oldsv = *itersvp;
1824         if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1825             /* safe to reuse old SV */
1826             sv_setsv(oldsv, cur);
1827         }
1828         else
1829         {
1830             /* we need a fresh SV every time so that loop body sees a
1831              * completely new SV for closures/references to work as
1832              * they used to */
1833             *itersvp = newSVsv(cur);
1834             SvREFCNT_dec_NN(oldsv);
1835         }
1836         if (strEQ(SvPVX_const(cur), max))
1837             sv_setiv(cur, 0); /* terminate next time */
1838         else
1839             sv_inc(cur);
1840         break;
1841     }
1842
1843     case CXt_LOOP_LAZYIV: /* integer increment */
1844     {
1845         IV cur = cx->blk_loop.state_u.lazyiv.cur;
1846         if (cur > cx->blk_loop.state_u.lazyiv.end)
1847             RETPUSHNO;
1848
1849         oldsv = *itersvp;
1850         /* don't risk potential race */
1851         if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1852             /* safe to reuse old SV */
1853             sv_setiv(oldsv, cur);
1854         }
1855         else
1856         {
1857             /* we need a fresh SV every time so that loop body sees a
1858              * completely new SV for closures/references to work as they
1859              * used to */
1860             *itersvp = newSViv(cur);
1861             SvREFCNT_dec_NN(oldsv);
1862         }
1863
1864         if (cur == IV_MAX) {
1865             /* Handle end of range at IV_MAX */
1866             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1867         } else
1868             ++cx->blk_loop.state_u.lazyiv.cur;
1869         break;
1870     }
1871
1872     case CXt_LOOP_FOR: /* iterate array */
1873     {
1874
1875         AV *av = cx->blk_loop.state_u.ary.ary;
1876         SV *sv;
1877         bool av_is_stack = FALSE;
1878         IV ix;
1879
1880         if (!av) {
1881             av_is_stack = TRUE;
1882             av = PL_curstack;
1883         }
1884         if (PL_op->op_private & OPpITER_REVERSED) {
1885             ix = --cx->blk_loop.state_u.ary.ix;
1886             if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
1887                 RETPUSHNO;
1888         }
1889         else {
1890             ix = ++cx->blk_loop.state_u.ary.ix;
1891             if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
1892                 RETPUSHNO;
1893         }
1894
1895         if (SvMAGICAL(av) || AvREIFY(av)) {
1896             SV * const * const svp = av_fetch(av, ix, FALSE);
1897             sv = svp ? *svp : NULL;
1898         }
1899         else {
1900             sv = AvARRAY(av)[ix];
1901         }
1902
1903         if (sv) {
1904             if (SvIS_FREED(sv)) {
1905                 *itersvp = NULL;
1906                 Perl_croak(aTHX_ "Use of freed value in iteration");
1907             }
1908             if (SvPADTMP(sv) && !IS_PADGV(sv))
1909                 sv = newSVsv(sv);
1910             else {
1911                 SvTEMP_off(sv);
1912                 SvREFCNT_inc_simple_void_NN(sv);
1913             }
1914         }
1915         else
1916             sv = &PL_sv_undef;
1917
1918         if (!av_is_stack && sv == &PL_sv_undef) {
1919             SV *lv = newSV_type(SVt_PVLV);
1920             LvTYPE(lv) = 'y';
1921             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1922             LvTARG(lv) = SvREFCNT_inc_simple(av);
1923             LvTARGOFF(lv) = ix;
1924             LvTARGLEN(lv) = (STRLEN)UV_MAX;
1925             sv = lv;
1926         }
1927
1928         oldsv = *itersvp;
1929         *itersvp = sv;
1930         SvREFCNT_dec(oldsv);
1931         break;
1932     }
1933
1934     default:
1935         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1936     }
1937     RETPUSHYES;
1938 }
1939
1940 /*
1941 A description of how taint works in pattern matching and substitution.
1942
1943 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1944 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1945
1946 While the pattern is being assembled/concatenated and then compiled,
1947 PL_tainted will get set (via TAINT_set) if any component of the pattern
1948 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
1949 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1950 TAINT_get).
1951
1952 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1953 the pattern is marked as tainted. This means that subsequent usage, such
1954 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1955 on the new pattern too.
1956
1957 At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the
1958 regex is cleared; during execution, locale-variant ops such as POSIXL may
1959 set RXf_TAINTED_SEEN.
1960
1961 RXf_TAINTED_SEEN is used post-execution by the get magic code
1962 of $1 et al to indicate whether the returned value should be tainted.
1963 It is the responsibility of the caller of the pattern (i.e. pp_match,
1964 pp_subst etc) to set this flag for any other circumstances where $1 needs
1965 to be tainted.
1966
1967 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1968
1969 There are three possible sources of taint
1970     * the source string
1971     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1972     * the replacement string (or expression under /e)
1973     
1974 There are four destinations of taint and they are affected by the sources
1975 according to the rules below:
1976
1977     * the return value (not including /r):
1978         tainted by the source string and pattern, but only for the
1979         number-of-iterations case; boolean returns aren't tainted;
1980     * the modified string (or modified copy under /r):
1981         tainted by the source string, pattern, and replacement strings;
1982     * $1 et al:
1983         tainted by the pattern, and under 'use re "taint"', by the source
1984         string too;
1985     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
1986         should always be unset before executing subsequent code.
1987
1988 The overall action of pp_subst is:
1989
1990     * at the start, set bits in rxtainted indicating the taint status of
1991         the various sources.
1992
1993     * After each pattern execution, update the SUBST_TAINT_PAT bit in
1994         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
1995         pattern has subsequently become tainted via locale ops.
1996
1997     * If control is being passed to pp_substcont to execute a /e block,
1998         save rxtainted in the CXt_SUBST block, for future use by
1999         pp_substcont.
2000
2001     * Whenever control is being returned to perl code (either by falling
2002         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2003         use the flag bits in rxtainted to make all the appropriate types of
2004         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2005         et al will appear tainted.
2006
2007 pp_match is just a simpler version of the above.
2008
2009 */
2010
2011 PP(pp_subst)
2012 {
2013     dVAR; dSP; dTARG;
2014     PMOP *pm = cPMOP;
2015     PMOP *rpm = pm;
2016     char *s;
2017     char *strend;
2018     const char *c;
2019     STRLEN clen;
2020     I32 iters = 0;
2021     I32 maxiters;
2022     bool once;
2023     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2024                         See "how taint works" above */
2025     char *orig;
2026     U8 r_flags;
2027     REGEXP *rx = PM_GETRE(pm);
2028     STRLEN len;
2029     int force_on_match = 0;
2030     const I32 oldsave = PL_savestack_ix;
2031     STRLEN slen;
2032     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2033 #ifdef PERL_ANY_COW
2034     bool is_cow;
2035 #endif
2036     SV *nsv = NULL;
2037     /* known replacement string? */
2038     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2039
2040     PERL_ASYNC_CHECK();
2041
2042     if (PL_op->op_flags & OPf_STACKED)
2043         TARG = POPs;
2044     else if (PL_op->op_private & OPpTARGET_MY)
2045         GETTARGET;
2046     else {
2047         TARG = DEFSV;
2048         EXTEND(SP,1);
2049     }
2050
2051     SvGETMAGIC(TARG); /* must come before cow check */
2052 #ifdef PERL_ANY_COW
2053     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2054        because they make integers such as 256 "false".  */
2055     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2056 #else
2057     if (SvIsCOW(TARG))
2058         sv_force_normal_flags(TARG,0);
2059 #endif
2060     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2061         && (SvREADONLY(TARG)
2062             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2063                   || SvTYPE(TARG) > SVt_PVLV)
2064                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2065         Perl_croak_no_modify();
2066     PUTBACK;
2067
2068     orig = SvPV_nomg(TARG, len);
2069     /* note we don't (yet) force the var into being a string; if we fail
2070      * to match, we leave as-is; on successful match howeverm, we *will*
2071      * coerce into a string, then repeat the match */
2072     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2073         force_on_match = 1;
2074
2075     /* only replace once? */
2076     once = !(rpm->op_pmflags & PMf_GLOBAL);
2077
2078     /* See "how taint works" above */
2079     if (TAINTING_get) {
2080         rxtainted  = (
2081             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2082           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2083           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2084           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2085                 ? SUBST_TAINT_BOOLRET : 0));
2086         TAINT_NOT;
2087     }
2088
2089   force_it:
2090     if (!pm || !orig)
2091         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2092
2093     strend = orig + len;
2094     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2095     maxiters = 2 * slen + 10;   /* We can match twice at each
2096                                    position, once with zero-length,
2097                                    second time with non-zero. */
2098
2099     if (!RX_PRELEN(rx) && PL_curpm
2100      && !ReANY(rx)->mother_re) {
2101         pm = PL_curpm;
2102         rx = PM_GETRE(pm);
2103     }
2104
2105 #ifdef PERL_SAWAMPERSAND
2106     r_flags = (    RX_NPARENS(rx)
2107                 || PL_sawampersand
2108                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2109                 || (rpm->op_pmflags & PMf_KEEPCOPY)
2110               )
2111           ? REXEC_COPY_STR
2112           : 0;
2113 #else
2114     r_flags = REXEC_COPY_STR;
2115 #endif
2116
2117     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2118     {
2119         SPAGAIN;
2120         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2121         LEAVE_SCOPE(oldsave);
2122         RETURN;
2123     }
2124     PL_curpm = pm;
2125
2126     /* known replacement string? */
2127     if (dstr) {
2128         /* replacement needing upgrading? */
2129         if (DO_UTF8(TARG) && !doutf8) {
2130              nsv = sv_newmortal();
2131              SvSetSV(nsv, dstr);
2132              if (PL_encoding)
2133                   sv_recode_to_utf8(nsv, PL_encoding);
2134              else
2135                   sv_utf8_upgrade(nsv);
2136              c = SvPV_const(nsv, clen);
2137              doutf8 = TRUE;
2138         }
2139         else {
2140             c = SvPV_const(dstr, clen);
2141             doutf8 = DO_UTF8(dstr);
2142         }
2143
2144         if (SvTAINTED(dstr))
2145             rxtainted |= SUBST_TAINT_REPL;
2146     }
2147     else {
2148         c = NULL;
2149         doutf8 = FALSE;
2150     }
2151     
2152     /* can do inplace substitution? */
2153     if (c
2154 #ifdef PERL_ANY_COW
2155         && !is_cow
2156 #endif
2157         && (I32)clen <= RX_MINLENRET(rx)
2158         && (once || !(r_flags & REXEC_COPY_STR))
2159         && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2160         && (!doutf8 || SvUTF8(TARG))
2161         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2162     {
2163
2164 #ifdef PERL_ANY_COW
2165         if (SvIsCOW(TARG)) {
2166           if (!force_on_match)
2167             goto have_a_cow;
2168           assert(SvVOK(TARG));
2169         }
2170 #endif
2171         if (force_on_match) {
2172             /* redo the first match, this time with the orig var
2173              * forced into being a string */
2174             force_on_match = 0;
2175             orig = SvPV_force_nomg(TARG, len);
2176             goto force_it;
2177         }
2178
2179         if (once) {
2180             char *d, *m;
2181             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2182                 rxtainted |= SUBST_TAINT_PAT;
2183             m = orig + RX_OFFS(rx)[0].start;
2184             d = orig + RX_OFFS(rx)[0].end;
2185             s = orig;
2186             if (m - s > strend - d) {  /* faster to shorten from end */
2187                 I32 i;
2188                 if (clen) {
2189                     Copy(c, m, clen, char);
2190                     m += clen;
2191                 }
2192                 i = strend - d;
2193                 if (i > 0) {
2194                     Move(d, m, i, char);
2195                     m += i;
2196                 }
2197                 *m = '\0';
2198                 SvCUR_set(TARG, m - s);
2199             }
2200             else {      /* faster from front */
2201                 I32 i = m - s;
2202                 d -= clen;
2203                 if (i > 0)
2204                     Move(s, d - i, i, char);
2205                 sv_chop(TARG, d-i);
2206                 if (clen)
2207                     Copy(c, d, clen, char);
2208             }
2209             SPAGAIN;
2210             PUSHs(&PL_sv_yes);
2211         }
2212         else {
2213             char *d, *m;
2214             d = s = RX_OFFS(rx)[0].start + orig;
2215             do {
2216                 I32 i;
2217                 if (iters++ > maxiters)
2218                     DIE(aTHX_ "Substitution loop");
2219                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2220                     rxtainted |= SUBST_TAINT_PAT;
2221                 m = RX_OFFS(rx)[0].start + orig;
2222                 if ((i = m - s)) {
2223                     if (s != d)
2224                         Move(s, d, i, char);
2225                     d += i;
2226                 }
2227                 if (clen) {
2228                     Copy(c, d, clen, char);
2229                     d += clen;
2230                 }
2231                 s = RX_OFFS(rx)[0].end + orig;
2232             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2233                                  TARG, NULL,
2234                                  /* don't match same null twice */
2235                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2236             if (s != d) {
2237                 I32 i = strend - s;
2238                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2239                 Move(s, d, i+1, char);          /* include the NUL */
2240             }
2241             SPAGAIN;
2242             mPUSHi((I32)iters);
2243         }
2244     }
2245     else {
2246         bool first;
2247         char *m;
2248         SV *repl;
2249         if (force_on_match) {
2250             /* redo the first match, this time with the orig var
2251              * forced into being a string */
2252             force_on_match = 0;
2253             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2254                 /* I feel that it should be possible to avoid this mortal copy
2255                    given that the code below copies into a new destination.
2256                    However, I suspect it isn't worth the complexity of
2257                    unravelling the C<goto force_it> for the small number of
2258                    cases where it would be viable to drop into the copy code. */
2259                 TARG = sv_2mortal(newSVsv(TARG));
2260             }
2261             orig = SvPV_force_nomg(TARG, len);
2262             goto force_it;
2263         }
2264 #ifdef PERL_ANY_COW
2265       have_a_cow:
2266 #endif
2267         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2268             rxtainted |= SUBST_TAINT_PAT;
2269         repl = dstr;
2270         s = RX_OFFS(rx)[0].start + orig;
2271         dstr = newSVpvn_flags(orig, s-orig,
2272                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2273         if (!c) {
2274             PERL_CONTEXT *cx;
2275             SPAGAIN;
2276             m = orig;
2277             /* note that a whole bunch of local vars are saved here for
2278              * use by pp_substcont: here's a list of them in case you're
2279              * searching for places in this sub that uses a particular var:
2280              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2281              * s m strend rx once */
2282             PUSHSUBST(cx);
2283             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2284         }
2285         first = TRUE;
2286         do {
2287             if (iters++ > maxiters)
2288                 DIE(aTHX_ "Substitution loop");
2289             if (RX_MATCH_TAINTED(rx))
2290                 rxtainted |= SUBST_TAINT_PAT;
2291             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2292                 char *old_s    = s;
2293                 char *old_orig = orig;
2294                 assert(RX_SUBOFFSET(rx) == 0);
2295
2296                 orig = RX_SUBBEG(rx);
2297                 s = orig + (old_s - old_orig);
2298                 strend = s + (strend - old_s);
2299             }
2300             m = RX_OFFS(rx)[0].start + orig;
2301             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2302             s = RX_OFFS(rx)[0].end + orig;
2303             if (first) {
2304                 /* replacement already stringified */
2305               if (clen)
2306                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2307               first = FALSE;
2308             }
2309             else {
2310                 if (PL_encoding) {
2311                     if (!nsv) nsv = sv_newmortal();
2312                     sv_copypv(nsv, repl);
2313                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2314                     sv_catsv(dstr, nsv);
2315                 }
2316                 else sv_catsv(dstr, repl);
2317                 if (SvTAINTED(repl))
2318                     rxtainted |= SUBST_TAINT_REPL;
2319             }
2320             if (once)
2321                 break;
2322         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2323                              TARG, NULL,
2324                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2325         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2326
2327         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2328             /* From here on down we're using the copy, and leaving the original
2329                untouched.  */
2330             TARG = dstr;
2331             SPAGAIN;
2332             PUSHs(dstr);
2333         } else {
2334 #ifdef PERL_ANY_COW
2335             /* The match may make the string COW. If so, brilliant, because
2336                that's just saved us one malloc, copy and free - the regexp has
2337                donated the old buffer, and we malloc an entirely new one, rather
2338                than the regexp malloc()ing a buffer and copying our original,
2339                only for us to throw it away here during the substitution.  */
2340             if (SvIsCOW(TARG)) {
2341                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2342             } else
2343 #endif
2344             {
2345                 SvPV_free(TARG);
2346             }
2347             SvPV_set(TARG, SvPVX(dstr));
2348             SvCUR_set(TARG, SvCUR(dstr));
2349             SvLEN_set(TARG, SvLEN(dstr));
2350             SvFLAGS(TARG) |= SvUTF8(dstr);
2351             SvPV_set(dstr, NULL);
2352
2353             SPAGAIN;
2354             mPUSHi((I32)iters);
2355         }
2356     }
2357
2358     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2359         (void)SvPOK_only_UTF8(TARG);
2360     }
2361
2362     /* See "how taint works" above */
2363     if (TAINTING_get) {
2364         if ((rxtainted & SUBST_TAINT_PAT) ||
2365             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2366                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2367         )
2368             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2369
2370         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2371             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2372         )
2373             SvTAINTED_on(TOPs);  /* taint return value */
2374         else
2375             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2376
2377         /* needed for mg_set below */
2378         TAINT_set(
2379           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2380         );
2381         SvTAINT(TARG);
2382     }
2383     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2384     TAINT_NOT;
2385     LEAVE_SCOPE(oldsave);
2386     RETURN;
2387 }
2388
2389 PP(pp_grepwhile)
2390 {
2391     dVAR; dSP;
2392
2393     if (SvTRUEx(POPs))
2394         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2395     ++*PL_markstack_ptr;
2396     FREETMPS;
2397     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2398
2399     /* All done yet? */
2400     if (PL_stack_base + *PL_markstack_ptr > SP) {
2401         I32 items;
2402         const I32 gimme = GIMME_V;
2403
2404         LEAVE_with_name("grep");                                        /* exit outer scope */
2405         (void)POPMARK;                          /* pop src */
2406         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2407         (void)POPMARK;                          /* pop dst */
2408         SP = PL_stack_base + POPMARK;           /* pop original mark */
2409         if (gimme == G_SCALAR) {
2410             if (PL_op->op_private & OPpGREP_LEX) {
2411                 SV* const sv = sv_newmortal();
2412                 sv_setiv(sv, items);
2413                 PUSHs(sv);
2414             }
2415             else {
2416                 dTARGET;
2417                 XPUSHi(items);
2418             }
2419         }
2420         else if (gimme == G_ARRAY)
2421             SP += items;
2422         RETURN;
2423     }
2424     else {
2425         SV *src;
2426
2427         ENTER_with_name("grep_item");                                   /* enter inner scope */
2428         SAVEVPTR(PL_curpm);
2429
2430         src = PL_stack_base[*PL_markstack_ptr];
2431         if (SvPADTMP(src) && !IS_PADGV(src)) {
2432             src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2433             PL_tmps_floor++;
2434         }
2435         SvTEMP_off(src);
2436         if (PL_op->op_private & OPpGREP_LEX)
2437             PAD_SVl(PL_op->op_targ) = src;
2438         else
2439             DEFSV_set(src);
2440
2441         RETURNOP(cLOGOP->op_other);
2442     }
2443 }
2444
2445 PP(pp_leavesub)
2446 {
2447     dVAR; dSP;
2448     SV **mark;
2449     SV **newsp;
2450     PMOP *newpm;
2451     I32 gimme;
2452     PERL_CONTEXT *cx;
2453     SV *sv;
2454
2455     if (CxMULTICALL(&cxstack[cxstack_ix]))
2456         return 0;
2457
2458     POPBLOCK(cx,newpm);
2459     cxstack_ix++; /* temporarily protect top context */
2460
2461     TAINT_NOT;
2462     if (gimme == G_SCALAR) {
2463         MARK = newsp + 1;
2464         if (MARK <= SP) {
2465             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2466                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2467                      && !SvMAGICAL(TOPs)) {
2468                     *MARK = SvREFCNT_inc(TOPs);
2469                     FREETMPS;
2470                     sv_2mortal(*MARK);
2471                 }
2472                 else {
2473                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2474                     FREETMPS;
2475                     *MARK = sv_mortalcopy(sv);
2476                     SvREFCNT_dec_NN(sv);
2477                 }
2478             }
2479             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2480                      && !SvMAGICAL(TOPs)) {
2481                 *MARK = TOPs;
2482             }
2483             else
2484                 *MARK = sv_mortalcopy(TOPs);
2485         }
2486         else {
2487             MEXTEND(MARK, 0);
2488             *MARK = &PL_sv_undef;
2489         }
2490         SP = MARK;
2491     }
2492     else if (gimme == G_ARRAY) {
2493         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2494             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2495                  || SvMAGICAL(*MARK)) {
2496                 *MARK = sv_mortalcopy(*MARK);
2497                 TAINT_NOT;      /* Each item is independent */
2498             }
2499         }
2500     }
2501     PUTBACK;
2502
2503     LEAVE;
2504     cxstack_ix--;
2505     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2506     PL_curpm = newpm;   /* ... and pop $1 et al */
2507
2508     LEAVESUB(sv);
2509     return cx->blk_sub.retop;
2510 }
2511
2512 PP(pp_entersub)
2513 {
2514     dVAR; dSP; dPOPss;
2515     GV *gv;
2516     CV *cv;
2517     PERL_CONTEXT *cx;
2518     I32 gimme;
2519     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2520
2521     if (!sv)
2522         DIE(aTHX_ "Not a CODE reference");
2523     switch (SvTYPE(sv)) {
2524         /* This is overwhelming the most common case:  */
2525     case SVt_PVGV:
2526       we_have_a_glob:
2527         if (!(cv = GvCVu((const GV *)sv))) {
2528             HV *stash;
2529             cv = sv_2cv(sv, &stash, &gv, 0);
2530         }
2531         if (!cv) {
2532             ENTER;
2533             SAVETMPS;
2534             goto try_autoload;
2535         }
2536         break;
2537     case SVt_PVLV:
2538         if(isGV_with_GP(sv)) goto we_have_a_glob;
2539         /*FALLTHROUGH*/
2540     default:
2541         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2542             if (hasargs)
2543                 SP = PL_stack_base + POPMARK;
2544             else
2545                 (void)POPMARK;
2546             RETURN;
2547         }
2548         SvGETMAGIC(sv);
2549         if (SvROK(sv)) {
2550             if (SvAMAGIC(sv)) {
2551                 sv = amagic_deref_call(sv, to_cv_amg);
2552                 /* Don't SPAGAIN here.  */
2553             }
2554         }
2555         else {
2556             const char *sym;
2557             STRLEN len;
2558             if (!SvOK(sv))
2559                 DIE(aTHX_ PL_no_usym, "a subroutine");
2560             sym = SvPV_nomg_const(sv, len);
2561             if (PL_op->op_private & HINT_STRICT_REFS)
2562                 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2563             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2564             break;
2565         }
2566         cv = MUTABLE_CV(SvRV(sv));
2567         if (SvTYPE(cv) == SVt_PVCV)
2568             break;
2569         /* FALL THROUGH */
2570     case SVt_PVHV:
2571     case SVt_PVAV:
2572         DIE(aTHX_ "Not a CODE reference");
2573         /* This is the second most common case:  */
2574     case SVt_PVCV:
2575         cv = MUTABLE_CV(sv);
2576         break;
2577     }
2578
2579     ENTER;
2580
2581   retry:
2582     if (CvCLONE(cv) && ! CvCLONED(cv))
2583         DIE(aTHX_ "Closure prototype called");
2584     if (!CvROOT(cv) && !CvXSUB(cv)) {
2585         GV* autogv;
2586         SV* sub_name;
2587
2588         /* anonymous or undef'd function leaves us no recourse */
2589         if (CvANON(cv) || !(gv = CvGV(cv))) {
2590             if (CvNAMED(cv))
2591                 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2592                            HEKfARG(CvNAME_HEK(cv)));
2593             DIE(aTHX_ "Undefined subroutine called");
2594         }
2595
2596         /* autoloaded stub? */
2597         if (cv != GvCV(gv)) {
2598             cv = GvCV(gv);
2599         }
2600         /* should call AUTOLOAD now? */
2601         else {
2602 try_autoload:
2603             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2604                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2605             {
2606                 cv = GvCV(autogv);
2607             }
2608             else {
2609                sorry:
2610                 sub_name = sv_newmortal();
2611                 gv_efullname3(sub_name, gv, NULL);
2612                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2613             }
2614         }
2615         if (!cv)
2616             goto sorry;
2617         goto retry;
2618     }
2619
2620     gimme = GIMME_V;
2621     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2622          Perl_get_db_sub(aTHX_ &sv, cv);
2623          if (CvISXSUB(cv))
2624              PL_curcopdb = PL_curcop;
2625          if (CvLVALUE(cv)) {
2626              /* check for lsub that handles lvalue subroutines */
2627              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2628              /* if lsub not found then fall back to DB::sub */
2629              if (!cv) cv = GvCV(PL_DBsub);
2630          } else {
2631              cv = GvCV(PL_DBsub);
2632          }
2633
2634         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2635             DIE(aTHX_ "No DB::sub routine defined");
2636     }
2637
2638     if (!(CvISXSUB(cv))) {
2639         /* This path taken at least 75% of the time   */
2640         dMARK;
2641         I32 items = SP - MARK;
2642         PADLIST * const padlist = CvPADLIST(cv);
2643         PUSHBLOCK(cx, CXt_SUB, MARK);
2644         PUSHSUB(cx);
2645         cx->blk_sub.retop = PL_op->op_next;
2646         CvDEPTH(cv)++;
2647         if (CvDEPTH(cv) >= 2) {
2648             PERL_STACK_OVERFLOW_CHECK();
2649             pad_push(padlist, CvDEPTH(cv));
2650         }
2651         SAVECOMPPAD();
2652         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2653         if (hasargs) {
2654             AV *const av = MUTABLE_AV(PAD_SVl(0));
2655             if (AvREAL(av)) {
2656                 /* @_ is normally not REAL--this should only ever
2657                  * happen when DB::sub() calls things that modify @_ */
2658                 av_clear(av);
2659                 AvREAL_off(av);
2660                 AvREIFY_on(av);
2661             }
2662             cx->blk_sub.savearray = GvAV(PL_defgv);
2663             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2664             CX_CURPAD_SAVE(cx->blk_sub);
2665             cx->blk_sub.argarray = av;
2666             ++MARK;
2667
2668             if (items - 1 > AvMAX(av)) {
2669                 SV **ary = AvALLOC(av);
2670                 AvMAX(av) = items - 1;
2671                 Renew(ary, items, SV*);
2672                 AvALLOC(av) = ary;
2673                 AvARRAY(av) = ary;
2674             }
2675
2676             Copy(MARK,AvARRAY(av),items,SV*);
2677             AvFILLp(av) = items - 1;
2678         
2679             MARK = AvARRAY(av);
2680             while (items--) {
2681                 if (*MARK)
2682                 {
2683                     if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
2684                         *MARK = sv_mortalcopy(*MARK);
2685                     SvTEMP_off(*MARK);
2686                 }
2687                 MARK++;
2688             }
2689         }
2690         SAVETMPS;
2691         if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2692             !CvLVALUE(cv))
2693             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2694         /* warning must come *after* we fully set up the context
2695          * stuff so that __WARN__ handlers can safely dounwind()
2696          * if they want to
2697          */
2698         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2699             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2700             sub_crush_depth(cv);
2701         RETURNOP(CvSTART(cv));
2702     }
2703     else {
2704         I32 markix = TOPMARK;
2705
2706         SAVETMPS;
2707         PUTBACK;
2708
2709         if (((PL_op->op_private
2710                & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2711              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2712             !CvLVALUE(cv))
2713             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2714
2715         if (!hasargs) {
2716             /* Need to copy @_ to stack. Alternative may be to
2717              * switch stack to @_, and copy return values
2718              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2719             AV * const av = GvAV(PL_defgv);
2720             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2721
2722             if (items) {
2723                 /* Mark is at the end of the stack. */
2724                 EXTEND(SP, items);
2725                 Copy(AvARRAY(av), SP + 1, items, SV*);
2726                 SP += items;
2727                 PUTBACK ;               
2728             }
2729         }
2730         else {
2731             SV **mark = PL_stack_base + markix;
2732             I32 items = SP - mark;
2733             while (items--) {
2734                 mark++;
2735                 if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark))
2736                     *mark = sv_mortalcopy(*mark);
2737             }
2738         }
2739         /* We assume first XSUB in &DB::sub is the called one. */
2740         if (PL_curcopdb) {
2741             SAVEVPTR(PL_curcop);
2742             PL_curcop = PL_curcopdb;
2743             PL_curcopdb = NULL;
2744         }
2745         /* Do we need to open block here? XXXX */
2746
2747         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2748         assert(CvXSUB(cv));
2749         CvXSUB(cv)(aTHX_ cv);
2750
2751         /* Enforce some sanity in scalar context. */
2752         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2753             if (markix > PL_stack_sp - PL_stack_base)
2754                 *(PL_stack_base + markix) = &PL_sv_undef;
2755             else
2756                 *(PL_stack_base + markix) = *PL_stack_sp;
2757             PL_stack_sp = PL_stack_base + markix;
2758         }
2759         LEAVE;
2760         return NORMAL;
2761     }
2762 }
2763
2764 void
2765 Perl_sub_crush_depth(pTHX_ CV *cv)
2766 {
2767     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2768
2769     if (CvANON(cv))
2770         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2771     else {
2772         HEK *const hek = CvNAME_HEK(cv);
2773         SV *tmpstr;
2774         if (hek) {
2775             tmpstr = sv_2mortal(newSVhek(hek));
2776         }
2777         else {
2778             tmpstr = sv_newmortal();
2779             gv_efullname3(tmpstr, CvGV(cv), NULL);
2780         }
2781         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2782                     SVfARG(tmpstr));
2783     }
2784 }
2785
2786 PP(pp_aelem)
2787 {
2788     dVAR; dSP;
2789     SV** svp;
2790     SV* const elemsv = POPs;
2791     IV elem = SvIV(elemsv);
2792     AV *const av = MUTABLE_AV(POPs);
2793     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2794     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2795     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2796     bool preeminent = TRUE;
2797     SV *sv;
2798
2799     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2800         Perl_warner(aTHX_ packWARN(WARN_MISC),
2801                     "Use of reference \"%"SVf"\" as array index",
2802                     SVfARG(elemsv));
2803     if (SvTYPE(av) != SVt_PVAV)
2804         RETPUSHUNDEF;
2805
2806     if (localizing) {
2807         MAGIC *mg;
2808         HV *stash;
2809
2810         /* If we can determine whether the element exist,
2811          * Try to preserve the existenceness of a tied array
2812          * element by using EXISTS and DELETE if possible.
2813          * Fallback to FETCH and STORE otherwise. */
2814         if (SvCANEXISTDELETE(av))
2815             preeminent = av_exists(av, elem);
2816     }
2817
2818     svp = av_fetch(av, elem, lval && !defer);
2819     if (lval) {
2820 #ifdef PERL_MALLOC_WRAP
2821          if (SvUOK(elemsv)) {
2822               const UV uv = SvUV(elemsv);
2823               elem = uv > IV_MAX ? IV_MAX : uv;
2824          }
2825          else if (SvNOK(elemsv))
2826               elem = (IV)SvNV(elemsv);
2827          if (elem > 0) {
2828               static const char oom_array_extend[] =
2829                 "Out of memory during array extend"; /* Duplicated in av.c */
2830               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2831          }
2832 #endif
2833         if (!svp || *svp == &PL_sv_undef) {
2834             SV* lv;
2835             if (!defer)
2836                 DIE(aTHX_ PL_no_aelem, elem);
2837             lv = sv_newmortal();
2838             sv_upgrade(lv, SVt_PVLV);
2839             LvTYPE(lv) = 'y';
2840             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2841             LvTARG(lv) = SvREFCNT_inc_simple(av);
2842             LvTARGOFF(lv) = elem;
2843             LvTARGLEN(lv) = 1;
2844             PUSHs(lv);
2845             RETURN;
2846         }
2847         if (localizing) {
2848             if (preeminent)
2849                 save_aelem(av, elem, svp);
2850             else
2851                 SAVEADELETE(av, elem);
2852         }
2853         else if (PL_op->op_private & OPpDEREF) {
2854             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2855             RETURN;
2856         }
2857     }
2858     sv = (svp ? *svp : &PL_sv_undef);
2859     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2860         mg_get(sv);
2861     PUSHs(sv);
2862     RETURN;
2863 }
2864
2865 SV*
2866 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2867 {
2868     PERL_ARGS_ASSERT_VIVIFY_REF;
2869
2870     SvGETMAGIC(sv);
2871     if (!SvOK(sv)) {
2872         if (SvREADONLY(sv))
2873             Perl_croak_no_modify();
2874         prepare_SV_for_RV(sv);
2875         switch (to_what) {
2876         case OPpDEREF_SV:
2877             SvRV_set(sv, newSV(0));
2878             break;
2879         case OPpDEREF_AV:
2880             SvRV_set(sv, MUTABLE_SV(newAV()));
2881             break;
2882         case OPpDEREF_HV:
2883             SvRV_set(sv, MUTABLE_SV(newHV()));
2884             break;
2885         }
2886         SvROK_on(sv);
2887         SvSETMAGIC(sv);
2888         SvGETMAGIC(sv);
2889     }
2890     if (SvGMAGICAL(sv)) {
2891         /* copy the sv without magic to prevent magic from being
2892            executed twice */
2893         SV* msv = sv_newmortal();
2894         sv_setsv_nomg(msv, sv);
2895         return msv;
2896     }
2897     return sv;
2898 }
2899
2900 PP(pp_method)
2901 {
2902     dVAR; dSP;
2903     SV* const sv = TOPs;
2904
2905     if (SvROK(sv)) {
2906         SV* const rsv = SvRV(sv);
2907         if (SvTYPE(rsv) == SVt_PVCV) {
2908             SETs(rsv);
2909             RETURN;
2910         }
2911     }
2912
2913     SETs(method_common(sv, NULL));
2914     RETURN;
2915 }
2916
2917 PP(pp_method_named)
2918 {
2919     dVAR; dSP;
2920     SV* const sv = cSVOP_sv;
2921     U32 hash = SvSHARED_HASH(sv);
2922
2923     XPUSHs(method_common(sv, &hash));
2924     RETURN;
2925 }
2926
2927 STATIC SV *
2928 S_method_common(pTHX_ SV* meth, U32* hashp)
2929 {
2930     dVAR;
2931     SV* ob;
2932     GV* gv;
2933     HV* stash;
2934     SV *packsv = NULL;
2935     SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2936         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2937                             "package or object reference", SVfARG(meth)),
2938            (SV *)NULL)
2939         : *(PL_stack_base + TOPMARK + 1);
2940
2941     PERL_ARGS_ASSERT_METHOD_COMMON;
2942
2943     if (!sv)
2944        undefined:
2945         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2946                    SVfARG(meth));
2947
2948     SvGETMAGIC(sv);
2949     if (SvROK(sv))
2950         ob = MUTABLE_SV(SvRV(sv));
2951     else if (!SvOK(sv)) goto undefined;
2952     else if (isGV_with_GP(sv)) {
2953         if (!GvIO(sv))
2954             Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2955                              "without a package or object reference",
2956                               SVfARG(meth));
2957         ob = sv;
2958         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
2959             assert(!LvTARGLEN(ob));
2960             ob = LvTARG(ob);
2961             assert(ob);
2962         }
2963         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
2964     }
2965     else {
2966         /* this isn't a reference */
2967         GV* iogv;
2968         STRLEN packlen;
2969         const char * const packname = SvPV_nomg_const(sv, packlen);
2970         const bool packname_is_utf8 = !!SvUTF8(sv);
2971         const HE* const he =
2972             (const HE *)hv_common(
2973                 PL_stashcache, NULL, packname, packlen,
2974                 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
2975             );
2976           
2977         if (he) { 
2978             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2979             DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
2980                              stash, sv));
2981             goto fetch;
2982         }
2983
2984         if (!(iogv = gv_fetchpvn_flags(
2985                 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2986              )) ||
2987             !(ob=MUTABLE_SV(GvIO(iogv))))
2988         {
2989             /* this isn't the name of a filehandle either */
2990             if (!packlen)
2991             {
2992                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2993                                  "without a package or object reference",
2994                                   SVfARG(meth));
2995             }
2996             /* assume it's a package name */
2997             stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
2998             if (!stash)
2999                 packsv = sv;
3000             else {
3001                 SV* const ref = newSViv(PTR2IV(stash));
3002                 (void)hv_store(PL_stashcache, packname,
3003                                 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3004                 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3005                                  stash, sv));
3006             }
3007             goto fetch;
3008         }
3009         /* it _is_ a filehandle name -- replace with a reference */
3010         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3011     }
3012
3013     /* if we got here, ob should be an object or a glob */
3014     if (!ob || !(SvOBJECT(ob)
3015                  || (isGV_with_GP(ob)
3016                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3017                      && SvOBJECT(ob))))
3018     {
3019         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3020                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3021                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3022                                         : meth));
3023     }
3024
3025     stash = SvSTASH(ob);
3026
3027   fetch:
3028     /* NOTE: stash may be null, hope hv_fetch_ent and
3029        gv_fetchmethod can cope (it seems they can) */
3030
3031     /* shortcut for simple names */
3032     if (hashp) {
3033         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3034         if (he) {
3035             gv = MUTABLE_GV(HeVAL(he));
3036             if (isGV(gv) && GvCV(gv) &&
3037                 (!GvCVGEN(gv) || GvCVGEN(gv)
3038                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3039                 return MUTABLE_SV(GvCV(gv));
3040         }
3041     }
3042
3043     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3044                                      meth, GV_AUTOLOAD | GV_CROAK);
3045
3046     assert(gv);
3047
3048     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3049 }
3050
3051 /*
3052  * Local variables:
3053  * c-indentation-style: bsd
3054  * c-basic-offset: 4
3055  * indent-tabs-mode: nil
3056  * End:
3057  *
3058  * ex: set ts=8 sts=4 sw=4 et:
3059  */