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