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