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