This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bb0f20517bf5e276e0f4cbec91b92d35d2154286
[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_flags & OPf_SPECIAL
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 (LVRET) {
835             if (gimme != G_ARRAY)
836                 goto croak_cant_return;
837             SETs(sv);
838             RETURN;
839         }
840         else if (PL_op->op_flags & OPf_MOD
841                 && PL_op->op_private & OPpLVAL_INTRO)
842             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
843     }
844     else {
845         if (SvTYPE(sv) == type) {
846             if (PL_op->op_flags & OPf_REF) {
847                 SETs(sv);
848                 RETURN;
849             }
850             else if (LVRET) {
851                 if (gimme != G_ARRAY)
852                     goto croak_cant_return;
853                 SETs(sv);
854                 RETURN;
855             }
856         }
857         else {
858             GV *gv;
859         
860             if (!isGV_with_GP(sv)) {
861                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
862                                      type, &sp);
863                 if (!gv)
864                     RETURN;
865             }
866             else {
867                 gv = MUTABLE_GV(sv);
868             }
869             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
870             if (PL_op->op_private & OPpLVAL_INTRO)
871                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
872             if (PL_op->op_flags & OPf_REF) {
873                 SETs(sv);
874                 RETURN;
875             }
876             else if (LVRET) {
877                 if (gimme != G_ARRAY)
878                     goto croak_cant_return;
879                 SETs(sv);
880                 RETURN;
881             }
882         }
883     }
884
885     if (is_pp_rv2av) {
886         AV *const av = MUTABLE_AV(sv);
887         /* The guts of pp_rv2av, with no intending change to preserve history
888            (until such time as we get tools that can do blame annotation across
889            whitespace changes.  */
890         if (gimme == G_ARRAY) {
891             const I32 maxarg = AvFILL(av) + 1;
892             (void)POPs;                 /* XXXX May be optimized away? */
893             EXTEND(SP, maxarg);
894             if (SvRMAGICAL(av)) {
895                 U32 i;
896                 for (i=0; i < (U32)maxarg; i++) {
897                     SV ** const svp = av_fetch(av, i, FALSE);
898                     /* See note in pp_helem, and bug id #27839 */
899                     SP[i+1] = svp
900                         ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
901                         : &PL_sv_undef;
902                 }
903             }
904             else {
905                 Copy(AvARRAY(av), SP+1, maxarg, SV*);
906             }
907             SP += maxarg;
908         }
909         else if (gimme == G_SCALAR) {
910             dTARGET;
911             const I32 maxarg = AvFILL(av) + 1;
912             SETi(maxarg);
913         }
914     } else {
915         /* The guts of pp_rv2hv  */
916         if (gimme == G_ARRAY) { /* array wanted */
917             *PL_stack_sp = sv;
918             return Perl_do_kv(aTHX);
919         }
920         else if (gimme == G_SCALAR) {
921             dTARGET;
922             TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
923             SPAGAIN;
924             SETTARG;
925         }
926     }
927     RETURN;
928
929  croak_cant_return:
930     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
931                is_pp_rv2av ? "array" : "hash");
932     RETURN;
933 }
934
935 STATIC void
936 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
937 {
938     dVAR;
939
940     PERL_ARGS_ASSERT_DO_ODDBALL;
941
942     if (*relem) {
943         SV *tmpstr;
944         const HE *didstore;
945
946         if (ckWARN(WARN_MISC)) {
947             const char *err;
948             if (relem == firstrelem &&
949                 SvROK(*relem) &&
950                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
951                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
952             {
953                 err = "Reference found where even-sized list expected";
954             }
955             else
956                 err = "Odd number of elements in hash assignment";
957             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
958         }
959
960         tmpstr = newSV(0);
961         didstore = hv_store_ent(hash,*relem,tmpstr,0);
962         if (SvMAGICAL(hash)) {
963             if (SvSMAGICAL(tmpstr))
964                 mg_set(tmpstr);
965             if (!didstore)
966                 sv_2mortal(tmpstr);
967         }
968         TAINT_NOT;
969     }
970 }
971
972 PP(pp_aassign)
973 {
974     dVAR; dSP;
975     SV **lastlelem = PL_stack_sp;
976     SV **lastrelem = PL_stack_base + POPMARK;
977     SV **firstrelem = PL_stack_base + POPMARK + 1;
978     SV **firstlelem = lastrelem + 1;
979
980     register SV **relem;
981     register SV **lelem;
982
983     register SV *sv;
984     register AV *ary;
985
986     I32 gimme;
987     HV *hash;
988     I32 i;
989     int magic;
990     int duplicates = 0;
991     SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet  */
992
993     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
994     gimme = GIMME_V;
995
996     /* If there's a common identifier on both sides we have to take
997      * special care that assigning the identifier on the left doesn't
998      * clobber a value on the right that's used later in the list.
999      * Don't bother if LHS is just an empty hash or array.
1000      */
1001
1002     if (    (PL_op->op_private & OPpASSIGN_COMMON)
1003         &&  (
1004                firstlelem != lastlelem
1005             || ! ((sv = *firstlelem))
1006             || SvMAGICAL(sv)
1007             || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1008             || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1009             || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1010             )
1011     ) {
1012         EXTEND_MORTAL(lastrelem - firstrelem + 1);
1013         for (relem = firstrelem; relem <= lastrelem; relem++) {
1014             if ((sv = *relem)) {
1015                 TAINT_NOT;      /* Each item is independent */
1016
1017                 /* Dear TODO test in t/op/sort.t, I love you.
1018                    (It's relying on a panic, not a "semi-panic" from newSVsv()
1019                    and then an assertion failure below.)  */
1020                 if (SvIS_FREED(sv)) {
1021                     Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1022                                (void*)sv);
1023                 }
1024                 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1025                    and we need a second copy of a temp here.  */
1026                 *relem = sv_2mortal(newSVsv(sv));
1027             }
1028         }
1029     }
1030
1031     relem = firstrelem;
1032     lelem = firstlelem;
1033     ary = NULL;
1034     hash = NULL;
1035
1036     while (lelem <= lastlelem) {
1037         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1038         sv = *lelem++;
1039         switch (SvTYPE(sv)) {
1040         case SVt_PVAV:
1041             ary = MUTABLE_AV(sv);
1042             magic = SvMAGICAL(ary) != 0;
1043             av_clear(ary);
1044             av_extend(ary, lastrelem - relem);
1045             i = 0;
1046             while (relem <= lastrelem) {        /* gobble up all the rest */
1047                 SV **didstore;
1048                 assert(*relem);
1049                 sv = newSV(0);
1050                 sv_setsv(sv, *relem);
1051                 *(relem++) = sv;
1052                 didstore = av_store(ary,i++,sv);
1053                 if (magic) {
1054                     if (SvSMAGICAL(sv))
1055                         mg_set(sv);
1056                     if (!didstore)
1057                         sv_2mortal(sv);
1058                 }
1059                 TAINT_NOT;
1060             }
1061             if (PL_delaymagic & DM_ARRAY_ISA)
1062                 SvSETMAGIC(MUTABLE_SV(ary));
1063             break;
1064         case SVt_PVHV: {                                /* normal hash */
1065                 SV *tmpstr;
1066                 SV** topelem = relem;
1067
1068                 hash = MUTABLE_HV(sv);
1069                 magic = SvMAGICAL(hash) != 0;
1070                 hv_clear(hash);
1071                 firsthashrelem = relem;
1072
1073                 while (relem < lastrelem) {     /* gobble up all the rest */
1074                     HE *didstore;
1075                     sv = *relem ? *relem : &PL_sv_no;
1076                     relem++;
1077                     tmpstr = newSV(0);
1078                     if (*relem)
1079                         sv_setsv(tmpstr,*relem);        /* value */
1080                     relem++;
1081                     if (gimme != G_VOID) {
1082                         if (hv_exists_ent(hash, sv, 0))
1083                             /* key overwrites an existing entry */
1084                             duplicates += 2;
1085                         else
1086                         if (gimme == G_ARRAY) {
1087                             /* copy element back: possibly to an earlier
1088                              * stack location if we encountered dups earlier */
1089                             *topelem++ = sv;
1090                             *topelem++ = tmpstr;
1091                         }
1092                     }
1093                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1094                     if (magic) {
1095                         if (SvSMAGICAL(tmpstr))
1096                             mg_set(tmpstr);
1097                         if (!didstore)
1098                             sv_2mortal(tmpstr);
1099                     }
1100                     TAINT_NOT;
1101                 }
1102                 if (relem == lastrelem) {
1103                     do_oddball(hash, relem, firstrelem);
1104                     relem++;
1105                 }
1106             }
1107             break;
1108         default:
1109             if (SvIMMORTAL(sv)) {
1110                 if (relem <= lastrelem)
1111                     relem++;
1112                 break;
1113             }
1114             if (relem <= lastrelem) {
1115                 sv_setsv(sv, *relem);
1116                 *(relem++) = sv;
1117             }
1118             else
1119                 sv_setsv(sv, &PL_sv_undef);
1120             SvSETMAGIC(sv);
1121             break;
1122         }
1123     }
1124     if (PL_delaymagic & ~DM_DELAY) {
1125         if (PL_delaymagic & DM_UID) {
1126 #ifdef HAS_SETRESUID
1127             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1128                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1129                             (Uid_t)-1);
1130 #else
1131 #  ifdef HAS_SETREUID
1132             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1133                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1134 #  else
1135 #    ifdef HAS_SETRUID
1136             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1137                 (void)setruid(PL_uid);
1138                 PL_delaymagic &= ~DM_RUID;
1139             }
1140 #    endif /* HAS_SETRUID */
1141 #    ifdef HAS_SETEUID
1142             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1143                 (void)seteuid(PL_euid);
1144                 PL_delaymagic &= ~DM_EUID;
1145             }
1146 #    endif /* HAS_SETEUID */
1147             if (PL_delaymagic & DM_UID) {
1148                 if (PL_uid != PL_euid)
1149                     DIE(aTHX_ "No setreuid available");
1150                 (void)PerlProc_setuid(PL_uid);
1151             }
1152 #  endif /* HAS_SETREUID */
1153 #endif /* HAS_SETRESUID */
1154             PL_uid = PerlProc_getuid();
1155             PL_euid = PerlProc_geteuid();
1156         }
1157         if (PL_delaymagic & DM_GID) {
1158 #ifdef HAS_SETRESGID
1159             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1160                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1161                             (Gid_t)-1);
1162 #else
1163 #  ifdef HAS_SETREGID
1164             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1165                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1166 #  else
1167 #    ifdef HAS_SETRGID
1168             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1169                 (void)setrgid(PL_gid);
1170                 PL_delaymagic &= ~DM_RGID;
1171             }
1172 #    endif /* HAS_SETRGID */
1173 #    ifdef HAS_SETEGID
1174             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1175                 (void)setegid(PL_egid);
1176                 PL_delaymagic &= ~DM_EGID;
1177             }
1178 #    endif /* HAS_SETEGID */
1179             if (PL_delaymagic & DM_GID) {
1180                 if (PL_gid != PL_egid)
1181                     DIE(aTHX_ "No setregid available");
1182                 (void)PerlProc_setgid(PL_gid);
1183             }
1184 #  endif /* HAS_SETREGID */
1185 #endif /* HAS_SETRESGID */
1186             PL_gid = PerlProc_getgid();
1187             PL_egid = PerlProc_getegid();
1188         }
1189         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1190     }
1191     PL_delaymagic = 0;
1192
1193     if (gimme == G_VOID)
1194         SP = firstrelem - 1;
1195     else if (gimme == G_SCALAR) {
1196         dTARGET;
1197         SP = firstrelem;
1198         SETi(lastrelem - firstrelem + 1 - duplicates);
1199     }
1200     else {
1201         if (ary)
1202             SP = lastrelem;
1203         else if (hash) {
1204             if (duplicates) {
1205                 /* at this point we have removed the duplicate key/value
1206                  * pairs from the stack, but the remaining values may be
1207                  * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1208                  * the (a 2), but the stack now probably contains
1209                  * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1210                  * obliterates the earlier key. So refresh all values. */
1211                 lastrelem -= duplicates;
1212                 relem = firsthashrelem;
1213                 while (relem < lastrelem) {
1214                     HE *he;
1215                     sv = *relem++;
1216                     he = hv_fetch_ent(hash, sv, 0, 0);
1217                     *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1218                 }
1219             }
1220             SP = lastrelem;
1221         }
1222         else
1223             SP = firstrelem + (lastlelem - firstlelem);
1224         lelem = firstlelem + (relem - firstrelem);
1225         while (relem <= SP)
1226             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1227     }
1228
1229     RETURN;
1230 }
1231
1232 PP(pp_qr)
1233 {
1234     dVAR; dSP;
1235     register PMOP * const pm = cPMOP;
1236     REGEXP * rx = PM_GETRE(pm);
1237     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1238     SV * const rv = sv_newmortal();
1239
1240     SvUPGRADE(rv, SVt_IV);
1241     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1242        loathe to use it here, but it seems to be the right fix. Or close.
1243        The key part appears to be that it's essential for pp_qr to return a new
1244        object (SV), which implies that there needs to be an effective way to
1245        generate a new SV from the existing SV that is pre-compiled in the
1246        optree.  */
1247     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1248     SvROK_on(rv);
1249
1250     if (pkg) {
1251         HV *const stash = gv_stashsv(pkg, GV_ADD);
1252         SvREFCNT_dec(pkg);
1253         (void)sv_bless(rv, stash);
1254     }
1255
1256     if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1257         SvTAINTED_on(rv);
1258         SvTAINTED_on(SvRV(rv));
1259     }
1260     XPUSHs(rv);
1261     RETURN;
1262 }
1263
1264 PP(pp_match)
1265 {
1266     dVAR; dSP; dTARG;
1267     register PMOP *pm = cPMOP;
1268     PMOP *dynpm = pm;
1269     register const char *t;
1270     register const char *s;
1271     const char *strend;
1272     I32 global;
1273     U8 r_flags = REXEC_CHECKED;
1274     const char *truebase;                       /* Start of string  */
1275     register REGEXP *rx = PM_GETRE(pm);
1276     bool rxtainted;
1277     const I32 gimme = GIMME;
1278     STRLEN len;
1279     I32 minmatch = 0;
1280     const I32 oldsave = PL_savestack_ix;
1281     I32 update_minmatch = 1;
1282     I32 had_zerolen = 0;
1283     U32 gpos = 0;
1284
1285     if (PL_op->op_flags & OPf_STACKED)
1286         TARG = POPs;
1287     else if (PL_op->op_private & OPpTARGET_MY)
1288         GETTARGET;
1289     else {
1290         TARG = DEFSV;
1291         EXTEND(SP,1);
1292     }
1293
1294     PUTBACK;                            /* EVAL blocks need stack_sp. */
1295     /* Skip get-magic if this is a qr// clone, because regcomp has
1296        already done it. */
1297     s = ((struct regexp *)SvANY(rx))->mother_re
1298          ? SvPV_nomg_const(TARG, len)
1299          : SvPV_const(TARG, len);
1300     if (!s)
1301         DIE(aTHX_ "panic: pp_match");
1302     strend = s + len;
1303     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1304                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1305     TAINT_NOT;
1306
1307     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1308
1309     /* PMdf_USED is set after a ?? matches once */
1310     if (
1311 #ifdef USE_ITHREADS
1312         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1313 #else
1314         pm->op_pmflags & PMf_USED
1315 #endif
1316     ) {
1317       failure:
1318         if (gimme == G_ARRAY)
1319             RETURN;
1320         RETPUSHNO;
1321     }
1322
1323
1324
1325     /* empty pattern special-cased to use last successful pattern if possible */
1326     if (!RX_PRELEN(rx) && PL_curpm) {
1327         pm = PL_curpm;
1328         rx = PM_GETRE(pm);
1329     }
1330
1331     if (RX_MINLEN(rx) > (I32)len)
1332         goto failure;
1333
1334     truebase = t = s;
1335
1336     /* XXXX What part of this is needed with true \G-support? */
1337     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1338         RX_OFFS(rx)[0].start = -1;
1339         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1340             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1341             if (mg && mg->mg_len >= 0) {
1342                 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1343                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1344                 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1345                     r_flags |= REXEC_IGNOREPOS;
1346                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1347                 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT) 
1348                     gpos = mg->mg_len;
1349                 else 
1350                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1351                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1352                 update_minmatch = 0;
1353             }
1354         }
1355     }
1356     /* XXX: comment out !global get safe $1 vars after a
1357        match, BUT be aware that this leads to dramatic slowdowns on
1358        /g matches against large strings.  So far a solution to this problem
1359        appears to be quite tricky.
1360        Test for the unsafe vars are TODO for now. */
1361     if (       (!global && RX_NPARENS(rx))
1362             || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1363             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1364         r_flags |= REXEC_COPY_STR;
1365     if (SvSCREAM(TARG))
1366         r_flags |= REXEC_SCREAM;
1367
1368   play_it_again:
1369     if (global && RX_OFFS(rx)[0].start != -1) {
1370         t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1371         if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1372             goto nope;
1373         if (update_minmatch++)
1374             minmatch = had_zerolen;
1375     }
1376     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1377         DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1378         /* FIXME - can PL_bostr be made const char *?  */
1379         PL_bostr = (char *)truebase;
1380         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1381
1382         if (!s)
1383             goto nope;
1384         if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1385              && !PL_sawampersand
1386              && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1387              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1388                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1389                       && (r_flags & REXEC_SCREAM)))
1390              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1391             goto yup;
1392     }
1393     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1394                     minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1395     {
1396         PL_curpm = pm;
1397         if (dynpm->op_pmflags & PMf_ONCE) {
1398 #ifdef USE_ITHREADS
1399             SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1400 #else
1401             dynpm->op_pmflags |= PMf_USED;
1402 #endif
1403         }
1404         goto gotcha;
1405     }
1406     else
1407         goto ret_no;
1408     /*NOTREACHED*/
1409
1410   gotcha:
1411     if (rxtainted)
1412         RX_MATCH_TAINTED_on(rx);
1413     TAINT_IF(RX_MATCH_TAINTED(rx));
1414     if (gimme == G_ARRAY) {
1415         const I32 nparens = RX_NPARENS(rx);
1416         I32 i = (global && !nparens) ? 1 : 0;
1417
1418         SPAGAIN;                        /* EVAL blocks could move the stack. */
1419         EXTEND(SP, nparens + i);
1420         EXTEND_MORTAL(nparens + i);
1421         for (i = !i; i <= nparens; i++) {
1422             PUSHs(sv_newmortal());
1423             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1424                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1425                 s = RX_OFFS(rx)[i].start + truebase;
1426                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1427                     len < 0 || len > strend - s)
1428                     DIE(aTHX_ "panic: pp_match start/end pointers");
1429                 sv_setpvn(*SP, s, len);
1430                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1431                     SvUTF8_on(*SP);
1432             }
1433         }
1434         if (global) {
1435             if (dynpm->op_pmflags & PMf_CONTINUE) {
1436                 MAGIC* mg = NULL;
1437                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1438                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1439                 if (!mg) {
1440 #ifdef PERL_OLD_COPY_ON_WRITE
1441                     if (SvIsCOW(TARG))
1442                         sv_force_normal_flags(TARG, 0);
1443 #endif
1444                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1445                                      &PL_vtbl_mglob, NULL, 0);
1446                 }
1447                 if (RX_OFFS(rx)[0].start != -1) {
1448                     mg->mg_len = RX_OFFS(rx)[0].end;
1449                     if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1450                         mg->mg_flags |= MGf_MINMATCH;
1451                     else
1452                         mg->mg_flags &= ~MGf_MINMATCH;
1453                 }
1454             }
1455             had_zerolen = (RX_OFFS(rx)[0].start != -1
1456                            && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1457                                == (UV)RX_OFFS(rx)[0].end));
1458             PUTBACK;                    /* EVAL blocks may use stack */
1459             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1460             goto play_it_again;
1461         }
1462         else if (!nparens)
1463             XPUSHs(&PL_sv_yes);
1464         LEAVE_SCOPE(oldsave);
1465         RETURN;
1466     }
1467     else {
1468         if (global) {
1469             MAGIC* mg;
1470             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1471                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1472             else
1473                 mg = NULL;
1474             if (!mg) {
1475 #ifdef PERL_OLD_COPY_ON_WRITE
1476                 if (SvIsCOW(TARG))
1477                     sv_force_normal_flags(TARG, 0);
1478 #endif
1479                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1480                                  &PL_vtbl_mglob, NULL, 0);
1481             }
1482             if (RX_OFFS(rx)[0].start != -1) {
1483                 mg->mg_len = RX_OFFS(rx)[0].end;
1484                 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1485                     mg->mg_flags |= MGf_MINMATCH;
1486                 else
1487                     mg->mg_flags &= ~MGf_MINMATCH;
1488             }
1489         }
1490         LEAVE_SCOPE(oldsave);
1491         RETPUSHYES;
1492     }
1493
1494 yup:                                    /* Confirmed by INTUIT */
1495     if (rxtainted)
1496         RX_MATCH_TAINTED_on(rx);
1497     TAINT_IF(RX_MATCH_TAINTED(rx));
1498     PL_curpm = pm;
1499     if (dynpm->op_pmflags & PMf_ONCE) {
1500 #ifdef USE_ITHREADS
1501         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1502 #else
1503         dynpm->op_pmflags |= PMf_USED;
1504 #endif
1505     }
1506     if (RX_MATCH_COPIED(rx))
1507         Safefree(RX_SUBBEG(rx));
1508     RX_MATCH_COPIED_off(rx);
1509     RX_SUBBEG(rx) = NULL;
1510     if (global) {
1511         /* FIXME - should rx->subbeg be const char *?  */
1512         RX_SUBBEG(rx) = (char *) truebase;
1513         RX_OFFS(rx)[0].start = s - truebase;
1514         if (RX_MATCH_UTF8(rx)) {
1515             char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1516             RX_OFFS(rx)[0].end = t - truebase;
1517         }
1518         else {
1519             RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1520         }
1521         RX_SUBLEN(rx) = strend - truebase;
1522         goto gotcha;
1523     }
1524     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1525         I32 off;
1526 #ifdef PERL_OLD_COPY_ON_WRITE
1527         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1528             if (DEBUG_C_TEST) {
1529                 PerlIO_printf(Perl_debug_log,
1530                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1531                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1532                               (int)(t-truebase));
1533             }
1534             RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1535             RX_SUBBEG(rx)
1536                 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1537             assert (SvPOKp(RX_SAVED_COPY(rx)));
1538         } else
1539 #endif
1540         {
1541
1542             RX_SUBBEG(rx) = savepvn(t, strend - t);
1543 #ifdef PERL_OLD_COPY_ON_WRITE
1544             RX_SAVED_COPY(rx) = NULL;
1545 #endif
1546         }
1547         RX_SUBLEN(rx) = strend - t;
1548         RX_MATCH_COPIED_on(rx);
1549         off = RX_OFFS(rx)[0].start = s - t;
1550         RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1551     }
1552     else {                      /* startp/endp are used by @- @+. */
1553         RX_OFFS(rx)[0].start = s - truebase;
1554         RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1555     }
1556     /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1557        -dmq */
1558     RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;      /* used by @-, @+, and $^N */
1559     LEAVE_SCOPE(oldsave);
1560     RETPUSHYES;
1561
1562 nope:
1563 ret_no:
1564     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1565         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1566             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1567             if (mg)
1568                 mg->mg_len = -1;
1569         }
1570     }
1571     LEAVE_SCOPE(oldsave);
1572     if (gimme == G_ARRAY)
1573         RETURN;
1574     RETPUSHNO;
1575 }
1576
1577 OP *
1578 Perl_do_readline(pTHX)
1579 {
1580     dVAR; dSP; dTARGETSTACKED;
1581     register SV *sv;
1582     STRLEN tmplen = 0;
1583     STRLEN offset;
1584     PerlIO *fp;
1585     register IO * const io = GvIO(PL_last_in_gv);
1586     register const I32 type = PL_op->op_type;
1587     const I32 gimme = GIMME_V;
1588
1589     if (io) {
1590         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1591         if (mg) {
1592             Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1593             if (gimme == G_SCALAR) {
1594                 SPAGAIN;
1595                 SvSetSV_nosteal(TARG, TOPs);
1596                 SETTARG;
1597             }
1598             return NORMAL;
1599         }
1600     }
1601     fp = NULL;
1602     if (io) {
1603         fp = IoIFP(io);
1604         if (!fp) {
1605             if (IoFLAGS(io) & IOf_ARGV) {
1606                 if (IoFLAGS(io) & IOf_START) {
1607                     IoLINES(io) = 0;
1608                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1609                         IoFLAGS(io) &= ~IOf_START;
1610                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1611                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1612                         SvSETMAGIC(GvSV(PL_last_in_gv));
1613                         fp = IoIFP(io);
1614                         goto have_fp;
1615                     }
1616                 }
1617                 fp = nextargv(PL_last_in_gv);
1618                 if (!fp) { /* Note: fp != IoIFP(io) */
1619                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1620                 }
1621             }
1622             else if (type == OP_GLOB)
1623                 fp = Perl_start_glob(aTHX_ POPs, io);
1624         }
1625         else if (type == OP_GLOB)
1626             SP--;
1627         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1628             report_wrongway_fh(PL_last_in_gv, '>');
1629         }
1630     }
1631     if (!fp) {
1632         if ((!io || !(IoFLAGS(io) & IOf_START))
1633             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1634         {
1635             if (type == OP_GLOB)
1636                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1637                             "glob failed (can't start child: %s)",
1638                             Strerror(errno));
1639             else
1640                 report_evil_fh(PL_last_in_gv);
1641         }
1642         if (gimme == G_SCALAR) {
1643             /* undef TARG, and push that undefined value */
1644             if (type != OP_RCATLINE) {
1645                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1646                 SvOK_off(TARG);
1647             }
1648             PUSHTARG;
1649         }
1650         RETURN;
1651     }
1652   have_fp:
1653     if (gimme == G_SCALAR) {
1654         sv = TARG;
1655         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1656             mg_get(sv);
1657         if (SvROK(sv)) {
1658             if (type == OP_RCATLINE)
1659                 SvPV_force_nolen(sv);
1660             else
1661                 sv_unref(sv);
1662         }
1663         else if (isGV_with_GP(sv)) {
1664             SvPV_force_nolen(sv);
1665         }
1666         SvUPGRADE(sv, SVt_PV);
1667         tmplen = SvLEN(sv);     /* remember if already alloced */
1668         if (!tmplen && !SvREADONLY(sv)) {
1669             /* try short-buffering it. Please update t/op/readline.t
1670              * if you change the growth length.
1671              */
1672             Sv_Grow(sv, 80);
1673         }
1674         offset = 0;
1675         if (type == OP_RCATLINE && SvOK(sv)) {
1676             if (!SvPOK(sv)) {
1677                 SvPV_force_nolen(sv);
1678             }
1679             offset = SvCUR(sv);
1680         }
1681     }
1682     else {
1683         sv = sv_2mortal(newSV(80));
1684         offset = 0;
1685     }
1686
1687     /* This should not be marked tainted if the fp is marked clean */
1688 #define MAYBE_TAINT_LINE(io, sv) \
1689     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1690         TAINT;                          \
1691         SvTAINTED_on(sv);               \
1692     }
1693
1694 /* delay EOF state for a snarfed empty file */
1695 #define SNARF_EOF(gimme,rs,io,sv) \
1696     (gimme != G_SCALAR || SvCUR(sv)                                     \
1697      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1698
1699     for (;;) {
1700         PUTBACK;
1701         if (!sv_gets(sv, fp, offset)
1702             && (type == OP_GLOB
1703                 || SNARF_EOF(gimme, PL_rs, io, sv)
1704                 || PerlIO_error(fp)))
1705         {
1706             PerlIO_clearerr(fp);
1707             if (IoFLAGS(io) & IOf_ARGV) {
1708                 fp = nextargv(PL_last_in_gv);
1709                 if (fp)
1710                     continue;
1711                 (void)do_close(PL_last_in_gv, FALSE);
1712             }
1713             else if (type == OP_GLOB) {
1714                 if (!do_close(PL_last_in_gv, FALSE)) {
1715                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1716                                    "glob failed (child exited with status %d%s)",
1717                                    (int)(STATUS_CURRENT >> 8),
1718                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1719                 }
1720             }
1721             if (gimme == G_SCALAR) {
1722                 if (type != OP_RCATLINE) {
1723                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1724                     SvOK_off(TARG);
1725                 }
1726                 SPAGAIN;
1727                 PUSHTARG;
1728             }
1729             MAYBE_TAINT_LINE(io, sv);
1730             RETURN;
1731         }
1732         MAYBE_TAINT_LINE(io, sv);
1733         IoLINES(io)++;
1734         IoFLAGS(io) |= IOf_NOLINE;
1735         SvSETMAGIC(sv);
1736         SPAGAIN;
1737         XPUSHs(sv);
1738         if (type == OP_GLOB) {
1739             const char *t1;
1740
1741             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1742                 char * const tmps = SvEND(sv) - 1;
1743                 if (*tmps == *SvPVX_const(PL_rs)) {
1744                     *tmps = '\0';
1745                     SvCUR_set(sv, SvCUR(sv) - 1);
1746                 }
1747             }
1748             for (t1 = SvPVX_const(sv); *t1; t1++)
1749                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1750                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1751                         break;
1752             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1753                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1754                 continue;
1755             }
1756         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1757              if (ckWARN(WARN_UTF8)) {
1758                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1759                 const STRLEN len = SvCUR(sv) - offset;
1760                 const U8 *f;
1761
1762                 if (!is_utf8_string_loc(s, len, &f))
1763                     /* Emulate :encoding(utf8) warning in the same case. */
1764                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1765                                 "utf8 \"\\x%02X\" does not map to Unicode",
1766                                 f < (U8*)SvEND(sv) ? *f : 0);
1767              }
1768         }
1769         if (gimme == G_ARRAY) {
1770             if (SvLEN(sv) - SvCUR(sv) > 20) {
1771                 SvPV_shrink_to_cur(sv);
1772             }
1773             sv = sv_2mortal(newSV(80));
1774             continue;
1775         }
1776         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1777             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1778             const STRLEN new_len
1779                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1780             SvPV_renew(sv, new_len);
1781         }
1782         RETURN;
1783     }
1784 }
1785
1786 PP(pp_enter)
1787 {
1788     dVAR; dSP;
1789     register PERL_CONTEXT *cx;
1790     I32 gimme = OP_GIMME(PL_op, -1);
1791
1792     if (gimme == -1) {
1793         if (cxstack_ix >= 0) {
1794             /* If this flag is set, we're just inside a return, so we should
1795              * store the caller's context */
1796             gimme = (PL_op->op_flags & OPf_SPECIAL)
1797                 ? block_gimme()
1798                 : cxstack[cxstack_ix].blk_gimme;
1799         } else
1800             gimme = G_SCALAR;
1801     }
1802
1803     ENTER_with_name("block");
1804
1805     SAVETMPS;
1806     PUSHBLOCK(cx, CXt_BLOCK, SP);
1807
1808     RETURN;
1809 }
1810
1811 PP(pp_helem)
1812 {
1813     dVAR; dSP;
1814     HE* he;
1815     SV **svp;
1816     SV * const keysv = POPs;
1817     HV * const hv = MUTABLE_HV(POPs);
1818     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1819     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1820     SV *sv;
1821     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1822     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1823     bool preeminent = TRUE;
1824
1825     if (SvTYPE(hv) != SVt_PVHV)
1826         RETPUSHUNDEF;
1827
1828     if (localizing) {
1829         MAGIC *mg;
1830         HV *stash;
1831
1832         /* If we can determine whether the element exist,
1833          * Try to preserve the existenceness of a tied hash
1834          * element by using EXISTS and DELETE if possible.
1835          * Fallback to FETCH and STORE otherwise. */
1836         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1837             preeminent = hv_exists_ent(hv, keysv, 0);
1838     }
1839
1840     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1841     svp = he ? &HeVAL(he) : NULL;
1842     if (lval) {
1843         if (!svp || *svp == &PL_sv_undef) {
1844             SV* lv;
1845             SV* key2;
1846             if (!defer) {
1847                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1848             }
1849             lv = sv_newmortal();
1850             sv_upgrade(lv, SVt_PVLV);
1851             LvTYPE(lv) = 'y';
1852             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1853             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1854             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1855             LvTARGLEN(lv) = 1;
1856             PUSHs(lv);
1857             RETURN;
1858         }
1859         if (localizing) {
1860             if (HvNAME_get(hv) && isGV(*svp))
1861                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1862             else if (preeminent)
1863                 save_helem_flags(hv, keysv, svp,
1864                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1865             else
1866                 SAVEHDELETE(hv, keysv);
1867         }
1868         else if (PL_op->op_private & OPpDEREF)
1869             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1870     }
1871     sv = (svp ? *svp : &PL_sv_undef);
1872     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1873      * was to make C<local $tied{foo} = $tied{foo}> possible.
1874      * However, it seems no longer to be needed for that purpose, and
1875      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1876      * would loop endlessly since the pos magic is getting set on the
1877      * mortal copy and lost. However, the copy has the effect of
1878      * triggering the get magic, and losing it altogether made things like
1879      * c<$tied{foo};> in void context no longer do get magic, which some
1880      * code relied on. Also, delayed triggering of magic on @+ and friends
1881      * meant the original regex may be out of scope by now. So as a
1882      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1883      * being called too many times). */
1884     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1885         mg_get(sv);
1886     PUSHs(sv);
1887     RETURN;
1888 }
1889
1890 PP(pp_leave)
1891 {
1892     dVAR; dSP;
1893     register PERL_CONTEXT *cx;
1894     SV **newsp;
1895     PMOP *newpm;
1896     I32 gimme;
1897
1898     if (PL_op->op_flags & OPf_SPECIAL) {
1899         cx = &cxstack[cxstack_ix];
1900         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1901     }
1902
1903     POPBLOCK(cx,newpm);
1904
1905     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1906
1907     TAINT_NOT;
1908     if (gimme == G_VOID)
1909         SP = newsp;
1910     else if (gimme == G_SCALAR) {
1911         register SV **mark;
1912         MARK = newsp + 1;
1913         if (MARK <= SP) {
1914             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1915                 *MARK = TOPs;
1916             else
1917                 *MARK = sv_mortalcopy(TOPs);
1918         } else {
1919             MEXTEND(mark,0);
1920             *MARK = &PL_sv_undef;
1921         }
1922         SP = MARK;
1923     }
1924     else if (gimme == G_ARRAY) {
1925         /* in case LEAVE wipes old return values */
1926         register SV **mark;
1927         for (mark = newsp + 1; mark <= SP; mark++) {
1928             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1929                 *mark = sv_mortalcopy(*mark);
1930                 TAINT_NOT;      /* Each item is independent */
1931             }
1932         }
1933     }
1934     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1935
1936     LEAVE_with_name("block");
1937
1938     RETURN;
1939 }
1940
1941 PP(pp_iter)
1942 {
1943     dVAR; dSP;
1944     register PERL_CONTEXT *cx;
1945     SV *sv, *oldsv;
1946     SV **itersvp;
1947     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1948     bool av_is_stack = FALSE;
1949
1950     EXTEND(SP, 1);
1951     cx = &cxstack[cxstack_ix];
1952     if (!CxTYPE_is_LOOP(cx))
1953         DIE(aTHX_ "panic: pp_iter");
1954
1955     itersvp = CxITERVAR(cx);
1956     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1957             /* string increment */
1958             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1959             SV *end = cx->blk_loop.state_u.lazysv.end;
1960             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1961                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1962             STRLEN maxlen = 0;
1963             const char *max = SvPV_const(end, maxlen);
1964             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1965                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1966                     /* safe to reuse old SV */
1967                     sv_setsv(*itersvp, cur);
1968                 }
1969                 else
1970                 {
1971                     /* we need a fresh SV every time so that loop body sees a
1972                      * completely new SV for closures/references to work as
1973                      * they used to */
1974                     oldsv = *itersvp;
1975                     *itersvp = newSVsv(cur);
1976                     SvREFCNT_dec(oldsv);
1977                 }
1978                 if (strEQ(SvPVX_const(cur), max))
1979                     sv_setiv(cur, 0); /* terminate next time */
1980                 else
1981                     sv_inc(cur);
1982                 RETPUSHYES;
1983             }
1984             RETPUSHNO;
1985     }
1986     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1987         /* integer increment */
1988         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1989             RETPUSHNO;
1990
1991         /* don't risk potential race */
1992         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1993             /* safe to reuse old SV */
1994             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1995         }
1996         else
1997         {
1998             /* we need a fresh SV every time so that loop body sees a
1999              * completely new SV for closures/references to work as they
2000              * used to */
2001             oldsv = *itersvp;
2002             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
2003             SvREFCNT_dec(oldsv);
2004         }
2005
2006         /* Handle end of range at IV_MAX */
2007         if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
2008             (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
2009         {
2010             cx->blk_loop.state_u.lazyiv.cur++;
2011             cx->blk_loop.state_u.lazyiv.end++;
2012         }
2013
2014         RETPUSHYES;
2015     }
2016
2017     /* iterate array */
2018     assert(CxTYPE(cx) == CXt_LOOP_FOR);
2019     av = cx->blk_loop.state_u.ary.ary;
2020     if (!av) {
2021         av_is_stack = TRUE;
2022         av = PL_curstack;
2023     }
2024     if (PL_op->op_private & OPpITER_REVERSED) {
2025         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2026                                     ? cx->blk_loop.resetsp + 1 : 0))
2027             RETPUSHNO;
2028
2029         if (SvMAGICAL(av) || AvREIFY(av)) {
2030             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2031             sv = svp ? *svp : NULL;
2032         }
2033         else {
2034             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2035         }
2036     }
2037     else {
2038         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2039                                     AvFILL(av)))
2040             RETPUSHNO;
2041
2042         if (SvMAGICAL(av) || AvREIFY(av)) {
2043             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2044             sv = svp ? *svp : NULL;
2045         }
2046         else {
2047             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2048         }
2049     }
2050
2051     if (sv && SvIS_FREED(sv)) {
2052         *itersvp = NULL;
2053         Perl_croak(aTHX_ "Use of freed value in iteration");
2054     }
2055
2056     if (sv) {
2057         SvTEMP_off(sv);
2058         SvREFCNT_inc_simple_void_NN(sv);
2059     }
2060     else
2061         sv = &PL_sv_undef;
2062     if (!av_is_stack && sv == &PL_sv_undef) {
2063         SV *lv = newSV_type(SVt_PVLV);
2064         LvTYPE(lv) = 'y';
2065         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2066         LvTARG(lv) = SvREFCNT_inc_simple(av);
2067         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2068         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2069         sv = lv;
2070     }
2071
2072     oldsv = *itersvp;
2073     *itersvp = sv;
2074     SvREFCNT_dec(oldsv);
2075
2076     RETPUSHYES;
2077 }
2078
2079 /*
2080 A description of how taint works in pattern matching and substitution.
2081
2082 While the pattern is being assembled/concatenated and them compiled,
2083 PL_tainted will get set if any component of the pattern is tainted, e.g.
2084 /.*$tainted/.  At the end of pattern compilation, the RXf_TAINTED flag
2085 is set on the pattern if PL_tainted is set.
2086
2087 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2088 the pattern is marked as tainted. This means that subsequent usage, such
2089 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
2090
2091 During execution of a pattern, locale-variant ops such as ALNUML set the
2092 local flag RF_tainted. At the end of execution, the engine sets the
2093 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2094 otherwise.
2095
2096 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2097 of $1 et al to indicate whether the returned value should be tainted.
2098 It is the responsibility of the caller of the pattern (i.e. pp_match,
2099 pp_subst etc) to set this flag for any other circumstances where $1 needs
2100 to be tainted.
2101
2102 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2103
2104 There are three possible sources of taint
2105     * the source string
2106     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2107     * the replacement string (or expression under /e)
2108     
2109 There are four destinations of taint and they are affected by the sources
2110 according to the rules below:
2111
2112     * the return value (not including /r):
2113         tainted by the source string and pattern, but only for the
2114         number-of-iterations case; boolean returns aren't tainted;
2115     * the modified string (or modified copy under /r):
2116         tainted by the source string, pattern, and replacement strings;
2117     * $1 et al:
2118         tainted by the pattern, and under 'use re "taint"', by the source
2119         string too;
2120     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2121         should always be unset before executing subsequent code.
2122
2123 The overall action of pp_subst is:
2124
2125     * at the start, set bits in rxtainted indicating the taint status of
2126         the various sources.
2127
2128     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2129         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2130         pattern has subsequently become tainted via locale ops.
2131
2132     * If control is being passed to pp_substcont to execute a /e block,
2133         save rxtainted in the CXt_SUBST block, for future use by
2134         pp_substcont.
2135
2136     * Whenever control is being returned to perl code (either by falling
2137         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2138         use the flag bits in rxtainted to make all the appropriate types of
2139         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2140         et al will appear tainted.
2141
2142 pp_match is just a simpler version of the above.
2143
2144 */
2145
2146 PP(pp_subst)
2147 {
2148     dVAR; dSP; dTARG;
2149     register PMOP *pm = cPMOP;
2150     PMOP *rpm = pm;
2151     register char *s;
2152     char *strend;
2153     register char *m;
2154     const char *c;
2155     register char *d;
2156     STRLEN clen;
2157     I32 iters = 0;
2158     I32 maxiters;
2159     register I32 i;
2160     bool once;
2161     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2162                         See "how taint works" above */
2163     char *orig;
2164     U8 r_flags;
2165     register REGEXP *rx = PM_GETRE(pm);
2166     STRLEN len;
2167     int force_on_match = 0;
2168     const I32 oldsave = PL_savestack_ix;
2169     STRLEN slen;
2170     bool doutf8 = FALSE;
2171 #ifdef PERL_OLD_COPY_ON_WRITE
2172     bool is_cow;
2173 #endif
2174     SV *nsv = NULL;
2175     /* known replacement string? */
2176     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2177
2178     PERL_ASYNC_CHECK();
2179
2180     if (PL_op->op_flags & OPf_STACKED)
2181         TARG = POPs;
2182     else if (PL_op->op_private & OPpTARGET_MY)
2183         GETTARGET;
2184     else {
2185         TARG = DEFSV;
2186         EXTEND(SP,1);
2187     }
2188
2189     /* In non-destructive replacement mode, duplicate target scalar so it
2190      * remains unchanged. */
2191     if (rpm->op_pmflags & PMf_NONDESTRUCT)
2192         TARG = sv_2mortal(newSVsv(TARG));
2193
2194 #ifdef PERL_OLD_COPY_ON_WRITE
2195     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2196        because they make integers such as 256 "false".  */
2197     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2198 #else
2199     if (SvIsCOW(TARG))
2200         sv_force_normal_flags(TARG,0);
2201 #endif
2202     if (
2203 #ifdef PERL_OLD_COPY_ON_WRITE
2204         !is_cow &&
2205 #endif
2206         (SvREADONLY(TARG)
2207          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2208                || SvTYPE(TARG) > SVt_PVLV)
2209              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2210         Perl_croak_no_modify(aTHX);
2211     PUTBACK;
2212
2213   setup_match:
2214     s = SvPV_mutable(TARG, len);
2215     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2216         force_on_match = 1;
2217
2218     /* only replace once? */
2219     once = !(rpm->op_pmflags & PMf_GLOBAL);
2220
2221     /* See "how taint works" above */
2222     if (PL_tainting) {
2223         rxtainted  = (
2224             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2225           | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2226           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2227           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2228                 ? SUBST_TAINT_BOOLRET : 0));
2229         TAINT_NOT;
2230     }
2231
2232     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2233
2234   force_it:
2235     if (!pm || !s)
2236         DIE(aTHX_ "panic: pp_subst");
2237
2238     strend = s + len;
2239     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2240     maxiters = 2 * slen + 10;   /* We can match twice at each
2241                                    position, once with zero-length,
2242                                    second time with non-zero. */
2243
2244     if (!RX_PRELEN(rx) && PL_curpm) {
2245         pm = PL_curpm;
2246         rx = PM_GETRE(pm);
2247     }
2248     r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2249             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2250                ? REXEC_COPY_STR : 0;
2251     if (SvSCREAM(TARG))
2252         r_flags |= REXEC_SCREAM;
2253
2254     orig = m = s;
2255     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2256         PL_bostr = orig;
2257         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2258
2259         if (!s)
2260             goto ret_no;
2261         /* How to do it in subst? */
2262 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2263              && !PL_sawampersand
2264              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2265              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2266                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2267                       && (r_flags & REXEC_SCREAM))))
2268             goto yup;
2269 */
2270     }
2271
2272     if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2273                          r_flags | REXEC_CHECKED))
2274     {
2275       ret_no:
2276         SPAGAIN;
2277         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2278         LEAVE_SCOPE(oldsave);
2279         RETURN;
2280     }
2281
2282     /* known replacement string? */
2283     if (dstr) {
2284         if (SvTAINTED(dstr))
2285             rxtainted |= SUBST_TAINT_REPL;
2286
2287         /* Upgrade the source if the replacement is utf8 but the source is not,
2288          * but only if it matched; see
2289          * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2290          */
2291         if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2292             char * const orig_pvx =  SvPVX(TARG);
2293             const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2294
2295             /* If the lengths are the same, the pattern contains only
2296              * invariants, can keep going; otherwise, various internal markers
2297              * could be off, so redo */
2298             if (new_len != len || orig_pvx != SvPVX(TARG)) {
2299                 goto setup_match;
2300             }
2301         }
2302
2303         /* replacement needing upgrading? */
2304         if (DO_UTF8(TARG) && !doutf8) {
2305              nsv = sv_newmortal();
2306              SvSetSV(nsv, dstr);
2307              if (PL_encoding)
2308                   sv_recode_to_utf8(nsv, PL_encoding);
2309              else
2310                   sv_utf8_upgrade(nsv);
2311              c = SvPV_const(nsv, clen);
2312              doutf8 = TRUE;
2313         }
2314         else {
2315             c = SvPV_const(dstr, clen);
2316             doutf8 = DO_UTF8(dstr);
2317         }
2318     }
2319     else {
2320         c = NULL;
2321         doutf8 = FALSE;
2322     }
2323     
2324     /* can do inplace substitution? */
2325     if (c
2326 #ifdef PERL_OLD_COPY_ON_WRITE
2327         && !is_cow
2328 #endif
2329         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2330         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2331         && (!doutf8 || SvUTF8(TARG)))
2332     {
2333
2334 #ifdef PERL_OLD_COPY_ON_WRITE
2335         if (SvIsCOW(TARG)) {
2336             assert (!force_on_match);
2337             goto have_a_cow;
2338         }
2339 #endif
2340         if (force_on_match) {
2341             force_on_match = 0;
2342             s = SvPV_force(TARG, len);
2343             goto force_it;
2344         }
2345         d = s;
2346         PL_curpm = pm;
2347         SvSCREAM_off(TARG);     /* disable possible screamer */
2348         if (once) {
2349             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2350                 rxtainted |= SUBST_TAINT_PAT;
2351             m = orig + RX_OFFS(rx)[0].start;
2352             d = orig + RX_OFFS(rx)[0].end;
2353             s = orig;
2354             if (m - s > strend - d) {  /* faster to shorten from end */
2355                 if (clen) {
2356                     Copy(c, m, clen, char);
2357                     m += clen;
2358                 }
2359                 i = strend - d;
2360                 if (i > 0) {
2361                     Move(d, m, i, char);
2362                     m += i;
2363                 }
2364                 *m = '\0';
2365                 SvCUR_set(TARG, m - s);
2366             }
2367             else if ((i = m - s)) {     /* faster from front */
2368                 d -= clen;
2369                 m = d;
2370                 Move(s, d - i, i, char);
2371                 sv_chop(TARG, d-i);
2372                 if (clen)
2373                     Copy(c, m, clen, char);
2374             }
2375             else if (clen) {
2376                 d -= clen;
2377                 sv_chop(TARG, d);
2378                 Copy(c, d, clen, char);
2379             }
2380             else {
2381                 sv_chop(TARG, d);
2382             }
2383             SPAGAIN;
2384             PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
2385         }
2386         else {
2387             do {
2388                 if (iters++ > maxiters)
2389                     DIE(aTHX_ "Substitution loop");
2390                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2391                     rxtainted |= SUBST_TAINT_PAT;
2392                 m = RX_OFFS(rx)[0].start + orig;
2393                 if ((i = m - s)) {
2394                     if (s != d)
2395                         Move(s, d, i, char);
2396                     d += i;
2397                 }
2398                 if (clen) {
2399                     Copy(c, d, clen, char);
2400                     d += clen;
2401                 }
2402                 s = RX_OFFS(rx)[0].end + orig;
2403             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2404                                  TARG, NULL,
2405                                  /* don't match same null twice */
2406                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2407             if (s != d) {
2408                 i = strend - s;
2409                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2410                 Move(s, d, i+1, char);          /* include the NUL */
2411             }
2412             SPAGAIN;
2413             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2414                 PUSHs(TARG);
2415             else
2416                 mPUSHi((I32)iters);
2417         }
2418     }
2419     else {
2420         if (force_on_match) {
2421             force_on_match = 0;
2422             s = SvPV_force(TARG, len);
2423             goto force_it;
2424         }
2425 #ifdef PERL_OLD_COPY_ON_WRITE
2426       have_a_cow:
2427 #endif
2428         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2429             rxtainted |= SUBST_TAINT_PAT;
2430         dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2431         SAVEFREESV(dstr);
2432         PL_curpm = pm;
2433         if (!c) {
2434             register PERL_CONTEXT *cx;
2435             SPAGAIN;
2436             /* note that a whole bunch of local vars are saved here for
2437              * use by pp_substcont: here's a list of them in case you're
2438              * searching for places in this sub that uses a particular var:
2439              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2440              * s m strend rx once */
2441             PUSHSUBST(cx);
2442             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2443         }
2444         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2445         do {
2446             if (iters++ > maxiters)
2447                 DIE(aTHX_ "Substitution loop");
2448             if (RX_MATCH_TAINTED(rx))
2449                 rxtainted |= SUBST_TAINT_PAT;
2450             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2451                 m = s;
2452                 s = orig;
2453                 orig = RX_SUBBEG(rx);
2454                 s = orig + (m - s);
2455                 strend = s + (strend - m);
2456             }
2457             m = RX_OFFS(rx)[0].start + orig;
2458             if (doutf8 && !SvUTF8(dstr))
2459                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2460             else
2461                 sv_catpvn(dstr, s, m-s);
2462             s = RX_OFFS(rx)[0].end + orig;
2463             if (clen)
2464                 sv_catpvn(dstr, c, clen);
2465             if (once)
2466                 break;
2467         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2468                              TARG, NULL, r_flags));
2469         if (doutf8 && !DO_UTF8(TARG))
2470             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2471         else
2472             sv_catpvn(dstr, s, strend - s);
2473
2474 #ifdef PERL_OLD_COPY_ON_WRITE
2475         /* The match may make the string COW. If so, brilliant, because that's
2476            just saved us one malloc, copy and free - the regexp has donated
2477            the old buffer, and we malloc an entirely new one, rather than the
2478            regexp malloc()ing a buffer and copying our original, only for
2479            us to throw it away here during the substitution.  */
2480         if (SvIsCOW(TARG)) {
2481             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2482         } else
2483 #endif
2484         {
2485             SvPV_free(TARG);
2486         }
2487         SvPV_set(TARG, SvPVX(dstr));
2488         SvCUR_set(TARG, SvCUR(dstr));
2489         SvLEN_set(TARG, SvLEN(dstr));
2490         doutf8 |= DO_UTF8(dstr);
2491         SvPV_set(dstr, NULL);
2492
2493         SPAGAIN;
2494         if (rpm->op_pmflags & PMf_NONDESTRUCT)
2495             PUSHs(TARG);
2496         else
2497             mPUSHi((I32)iters);
2498     }
2499     (void)SvPOK_only_UTF8(TARG);
2500     if (doutf8)
2501         SvUTF8_on(TARG);
2502
2503     /* See "how taint works" above */
2504     if (PL_tainting) {
2505         if ((rxtainted & SUBST_TAINT_PAT) ||
2506             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2507                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2508         )
2509             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2510
2511         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2512             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2513         )
2514             SvTAINTED_on(TOPs);  /* taint return value */
2515         else
2516             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2517
2518         /* needed for mg_set below */
2519         PL_tainted =
2520           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2521         SvTAINT(TARG);
2522     }
2523     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2524     TAINT_NOT;
2525     LEAVE_SCOPE(oldsave);
2526     RETURN;
2527 }
2528
2529 PP(pp_grepwhile)
2530 {
2531     dVAR; dSP;
2532
2533     if (SvTRUEx(POPs))
2534         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2535     ++*PL_markstack_ptr;
2536     FREETMPS;
2537     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2538
2539     /* All done yet? */
2540     if (PL_stack_base + *PL_markstack_ptr > SP) {
2541         I32 items;
2542         const I32 gimme = GIMME_V;
2543
2544         LEAVE_with_name("grep");                                        /* exit outer scope */
2545         (void)POPMARK;                          /* pop src */
2546         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2547         (void)POPMARK;                          /* pop dst */
2548         SP = PL_stack_base + POPMARK;           /* pop original mark */
2549         if (gimme == G_SCALAR) {
2550             if (PL_op->op_private & OPpGREP_LEX) {
2551                 SV* const sv = sv_newmortal();
2552                 sv_setiv(sv, items);
2553                 PUSHs(sv);
2554             }
2555             else {
2556                 dTARGET;
2557                 XPUSHi(items);
2558             }
2559         }
2560         else if (gimme == G_ARRAY)
2561             SP += items;
2562         RETURN;
2563     }
2564     else {
2565         SV *src;
2566
2567         ENTER_with_name("grep_item");                                   /* enter inner scope */
2568         SAVEVPTR(PL_curpm);
2569
2570         src = PL_stack_base[*PL_markstack_ptr];
2571         SvTEMP_off(src);
2572         if (PL_op->op_private & OPpGREP_LEX)
2573             PAD_SVl(PL_op->op_targ) = src;
2574         else
2575             DEFSV_set(src);
2576
2577         RETURNOP(cLOGOP->op_other);
2578     }
2579 }
2580
2581 PP(pp_leavesub)
2582 {
2583     dVAR; dSP;
2584     SV **mark;
2585     SV **newsp;
2586     PMOP *newpm;
2587     I32 gimme;
2588     register PERL_CONTEXT *cx;
2589     SV *sv;
2590
2591     if (CxMULTICALL(&cxstack[cxstack_ix]))
2592         return 0;
2593
2594     POPBLOCK(cx,newpm);
2595     cxstack_ix++; /* temporarily protect top context */
2596
2597     TAINT_NOT;
2598     if (gimme == G_SCALAR) {
2599         MARK = newsp + 1;
2600         if (MARK <= SP) {
2601             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2602                 if (SvTEMP(TOPs)) {
2603                     *MARK = SvREFCNT_inc(TOPs);
2604                     FREETMPS;
2605                     sv_2mortal(*MARK);
2606                 }
2607                 else {
2608                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2609                     FREETMPS;
2610                     *MARK = sv_mortalcopy(sv);
2611                     SvREFCNT_dec(sv);
2612                 }
2613             }
2614             else
2615                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2616         }
2617         else {
2618             MEXTEND(MARK, 0);
2619             *MARK = &PL_sv_undef;
2620         }
2621         SP = MARK;
2622     }
2623     else if (gimme == G_ARRAY) {
2624         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2625             if (!SvTEMP(*MARK)) {
2626                 *MARK = sv_mortalcopy(*MARK);
2627                 TAINT_NOT;      /* Each item is independent */
2628             }
2629         }
2630     }
2631     PUTBACK;
2632
2633     LEAVE;
2634     cxstack_ix--;
2635     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2636     PL_curpm = newpm;   /* ... and pop $1 et al */
2637
2638     LEAVESUB(sv);
2639     return cx->blk_sub.retop;
2640 }
2641
2642 /* This duplicates the above code because the above code must not
2643  * get any slower by more conditions */
2644 PP(pp_leavesublv)
2645 {
2646     dVAR; dSP;
2647     SV **mark;
2648     SV **newsp;
2649     PMOP *newpm;
2650     I32 gimme;
2651     register PERL_CONTEXT *cx;
2652     SV *sv;
2653
2654     if (CxMULTICALL(&cxstack[cxstack_ix]))
2655         return 0;
2656
2657     POPBLOCK(cx,newpm);
2658     cxstack_ix++; /* temporarily protect top context */
2659
2660     TAINT_NOT;
2661
2662     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2663         /* We are an argument to a function or grep().
2664          * This kind of lvalueness was legal before lvalue
2665          * subroutines too, so be backward compatible:
2666          * cannot report errors.  */
2667
2668         /* Scalar context *is* possible, on the LHS of -> only,
2669          * as in f()->meth().  But this is not an lvalue. */
2670         if (gimme == G_SCALAR)
2671             goto temporise;
2672         if (gimme == G_ARRAY) {
2673             mark = newsp + 1;
2674             /* We want an array here, but padav will have left us an arrayref for an lvalue,
2675              * so we need to expand it */
2676             if(SvTYPE(*mark) == SVt_PVAV) {
2677                 AV *const av = MUTABLE_AV(*mark);
2678                 const I32 maxarg = AvFILL(av) + 1;
2679                 (void)POPs; /* get rid of the array ref */
2680                 EXTEND(SP, maxarg);
2681                 if (SvRMAGICAL(av)) {
2682                     U32 i;
2683                     for (i=0; i < (U32)maxarg; i++) {
2684                         SV ** const svp = av_fetch(av, i, FALSE);
2685                         SP[i+1] = svp
2686                             ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
2687                             : &PL_sv_undef;
2688                     }
2689                 }
2690                 else {
2691                     Copy(AvARRAY(av), SP+1, maxarg, SV*);
2692                 }
2693                 SP += maxarg;
2694                 PUTBACK;
2695             }
2696             if (!CvLVALUE(cx->blk_sub.cv))
2697                 goto temporise_array;
2698             EXTEND_MORTAL(SP - newsp);
2699             for (mark = newsp + 1; mark <= SP; mark++) {
2700                 if (SvTEMP(*mark))
2701                     NOOP;
2702                 else if (SvFLAGS(*mark) & (SVs_PADTMP | 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           temporise:
2797             MARK = newsp + 1;
2798             if (MARK <= SP) {
2799                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2800                     if (SvTEMP(TOPs)) {
2801                         *MARK = SvREFCNT_inc(TOPs);
2802                         FREETMPS;
2803                         sv_2mortal(*MARK);
2804                     }
2805                     else {
2806                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2807                         FREETMPS;
2808                         *MARK = sv_mortalcopy(sv);
2809                         SvREFCNT_dec(sv);
2810                     }
2811                 }
2812                 else
2813                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2814             }
2815             else {
2816                 MEXTEND(MARK, 0);
2817                 *MARK = &PL_sv_undef;
2818             }
2819             SP = MARK;
2820         }
2821         else if (gimme == G_ARRAY) {
2822           temporise_array:
2823             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2824                 if (!SvTEMP(*MARK)) {
2825                     *MARK = sv_mortalcopy(*MARK);
2826                     TAINT_NOT;  /* Each item is independent */
2827                 }
2828             }
2829         }
2830     }
2831     PUTBACK;
2832
2833     LEAVE;
2834     cxstack_ix--;
2835     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2836     PL_curpm = newpm;   /* ... and pop $1 et al */
2837
2838     LEAVESUB(sv);
2839     return cx->blk_sub.retop;
2840 }
2841
2842 PP(pp_entersub)
2843 {
2844     dVAR; dSP; dPOPss;
2845     GV *gv;
2846     register CV *cv;
2847     register PERL_CONTEXT *cx;
2848     I32 gimme;
2849     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2850
2851     if (!sv)
2852         DIE(aTHX_ "Not a CODE reference");
2853     switch (SvTYPE(sv)) {
2854         /* This is overwhelming the most common case:  */
2855     case SVt_PVGV:
2856         if (!isGV_with_GP(sv))
2857             DIE(aTHX_ "Not a CODE reference");
2858       we_have_a_glob:
2859         if (!(cv = GvCVu((const GV *)sv))) {
2860             HV *stash;
2861             cv = sv_2cv(sv, &stash, &gv, 0);
2862         }
2863         if (!cv) {
2864             ENTER;
2865             SAVETMPS;
2866             goto try_autoload;
2867         }
2868         break;
2869     case SVt_PVLV:
2870         if(isGV_with_GP(sv)) goto we_have_a_glob;
2871         /*FALLTHROUGH*/
2872     default:
2873         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2874             if (hasargs)
2875                 SP = PL_stack_base + POPMARK;
2876             else
2877                 (void)POPMARK;
2878             RETURN;
2879         }
2880         SvGETMAGIC(sv);
2881         if (SvROK(sv)) {
2882             if (SvAMAGIC(sv)) {
2883                 sv = amagic_deref_call(sv, to_cv_amg);
2884                 /* Don't SPAGAIN here.  */
2885             }
2886         }
2887         else {
2888             const char *sym;
2889             STRLEN len;
2890             sym = SvPV_nomg_const(sv, len);
2891             if (!sym)
2892                 DIE(aTHX_ PL_no_usym, "a subroutine");
2893             if (PL_op->op_private & HINT_STRICT_REFS)
2894                 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2895             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2896             break;
2897         }
2898         cv = MUTABLE_CV(SvRV(sv));
2899         if (SvTYPE(cv) == SVt_PVCV)
2900             break;
2901         /* FALL THROUGH */
2902     case SVt_PVHV:
2903     case SVt_PVAV:
2904         DIE(aTHX_ "Not a CODE reference");
2905         /* This is the second most common case:  */
2906     case SVt_PVCV:
2907         cv = MUTABLE_CV(sv);
2908         break;
2909     }
2910
2911     ENTER;
2912     SAVETMPS;
2913
2914   retry:
2915     if (CvCLONE(cv) && ! CvCLONED(cv))
2916         DIE(aTHX_ "Closure prototype called");
2917     if (!CvROOT(cv) && !CvXSUB(cv)) {
2918         GV* autogv;
2919         SV* sub_name;
2920
2921         /* anonymous or undef'd function leaves us no recourse */
2922         if (CvANON(cv) || !(gv = CvGV(cv)))
2923             DIE(aTHX_ "Undefined subroutine called");
2924
2925         /* autoloaded stub? */
2926         if (cv != GvCV(gv)) {
2927             cv = GvCV(gv);
2928         }
2929         /* should call AUTOLOAD now? */
2930         else {
2931 try_autoload:
2932             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2933                                    FALSE)))
2934             {
2935                 cv = GvCV(autogv);
2936             }
2937             /* sorry */
2938             else {
2939                 sub_name = sv_newmortal();
2940                 gv_efullname3(sub_name, gv, NULL);
2941                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2942             }
2943         }
2944         if (!cv)
2945             DIE(aTHX_ "Not a CODE reference");
2946         goto retry;
2947     }
2948
2949     gimme = GIMME_V;
2950     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2951          Perl_get_db_sub(aTHX_ &sv, cv);
2952          if (CvISXSUB(cv))
2953              PL_curcopdb = PL_curcop;
2954          if (CvLVALUE(cv)) {
2955              /* check for lsub that handles lvalue subroutines */
2956              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2957              /* if lsub not found then fall back to DB::sub */
2958              if (!cv) cv = GvCV(PL_DBsub);
2959          } else {
2960              cv = GvCV(PL_DBsub);
2961          }
2962
2963         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2964             DIE(aTHX_ "No DB::sub routine defined");
2965     }
2966
2967     if (!(CvISXSUB(cv))) {
2968         /* This path taken at least 75% of the time   */
2969         dMARK;
2970         register I32 items = SP - MARK;
2971         AV* const padlist = CvPADLIST(cv);
2972         PUSHBLOCK(cx, CXt_SUB, MARK);
2973         PUSHSUB(cx);
2974         cx->blk_sub.retop = PL_op->op_next;
2975         CvDEPTH(cv)++;
2976         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2977          * that eval'' ops within this sub know the correct lexical space.
2978          * Owing the speed considerations, we choose instead to search for
2979          * the cv using find_runcv() when calling doeval().
2980          */
2981         if (CvDEPTH(cv) >= 2) {
2982             PERL_STACK_OVERFLOW_CHECK();
2983             pad_push(padlist, CvDEPTH(cv));
2984         }
2985         SAVECOMPPAD();
2986         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2987         if (hasargs) {
2988             AV *const av = MUTABLE_AV(PAD_SVl(0));
2989             if (AvREAL(av)) {
2990                 /* @_ is normally not REAL--this should only ever
2991                  * happen when DB::sub() calls things that modify @_ */
2992                 av_clear(av);
2993                 AvREAL_off(av);
2994                 AvREIFY_on(av);
2995             }
2996             cx->blk_sub.savearray = GvAV(PL_defgv);
2997             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2998             CX_CURPAD_SAVE(cx->blk_sub);
2999             cx->blk_sub.argarray = av;
3000             ++MARK;
3001
3002             if (items > AvMAX(av) + 1) {
3003                 SV **ary = AvALLOC(av);
3004                 if (AvARRAY(av) != ary) {
3005                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
3006                     AvARRAY(av) = ary;
3007                 }
3008                 if (items > AvMAX(av) + 1) {
3009                     AvMAX(av) = items - 1;
3010                     Renew(ary,items,SV*);
3011                     AvALLOC(av) = ary;
3012                     AvARRAY(av) = ary;
3013                 }
3014             }
3015             Copy(MARK,AvARRAY(av),items,SV*);
3016             AvFILLp(av) = items - 1;
3017         
3018             while (items--) {
3019                 if (*MARK)
3020                     SvTEMP_off(*MARK);
3021                 MARK++;
3022             }
3023         }
3024         /* warning must come *after* we fully set up the context
3025          * stuff so that __WARN__ handlers can safely dounwind()
3026          * if they want to
3027          */
3028         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
3029             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
3030             sub_crush_depth(cv);
3031         RETURNOP(CvSTART(cv));
3032     }
3033     else {
3034         I32 markix = TOPMARK;
3035
3036         PUTBACK;
3037
3038         if (!hasargs) {
3039             /* Need to copy @_ to stack. Alternative may be to
3040              * switch stack to @_, and copy return values
3041              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3042             AV * const av = GvAV(PL_defgv);
3043             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
3044
3045             if (items) {
3046                 /* Mark is at the end of the stack. */
3047                 EXTEND(SP, items);
3048                 Copy(AvARRAY(av), SP + 1, items, SV*);
3049                 SP += items;
3050                 PUTBACK ;               
3051             }
3052         }
3053         /* We assume first XSUB in &DB::sub is the called one. */
3054         if (PL_curcopdb) {
3055             SAVEVPTR(PL_curcop);
3056             PL_curcop = PL_curcopdb;
3057             PL_curcopdb = NULL;
3058         }
3059         /* Do we need to open block here? XXXX */
3060
3061         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3062         assert(CvXSUB(cv));
3063         CvXSUB(cv)(aTHX_ cv);
3064
3065         /* Enforce some sanity in scalar context. */
3066         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
3067             if (markix > PL_stack_sp - PL_stack_base)
3068                 *(PL_stack_base + markix) = &PL_sv_undef;
3069             else
3070                 *(PL_stack_base + markix) = *PL_stack_sp;
3071             PL_stack_sp = PL_stack_base + markix;
3072         }
3073         LEAVE;
3074         return NORMAL;
3075     }
3076 }
3077
3078 void
3079 Perl_sub_crush_depth(pTHX_ CV *cv)
3080 {
3081     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3082
3083     if (CvANON(cv))
3084         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3085     else {
3086         SV* const tmpstr = sv_newmortal();
3087         gv_efullname3(tmpstr, CvGV(cv), NULL);
3088         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3089                     SVfARG(tmpstr));
3090     }
3091 }
3092
3093 PP(pp_aelem)
3094 {
3095     dVAR; dSP;
3096     SV** svp;
3097     SV* const elemsv = POPs;
3098     IV elem = SvIV(elemsv);
3099     AV *const av = MUTABLE_AV(POPs);
3100     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3101     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
3102     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3103     bool preeminent = TRUE;
3104     SV *sv;
3105
3106     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3107         Perl_warner(aTHX_ packWARN(WARN_MISC),
3108                     "Use of reference \"%"SVf"\" as array index",
3109                     SVfARG(elemsv));
3110     if (elem > 0)
3111         elem -= CopARYBASE_get(PL_curcop);
3112     if (SvTYPE(av) != SVt_PVAV)
3113         RETPUSHUNDEF;
3114
3115     if (localizing) {
3116         MAGIC *mg;
3117         HV *stash;
3118
3119         /* If we can determine whether the element exist,
3120          * Try to preserve the existenceness of a tied array
3121          * element by using EXISTS and DELETE if possible.
3122          * Fallback to FETCH and STORE otherwise. */
3123         if (SvCANEXISTDELETE(av))
3124             preeminent = av_exists(av, elem);
3125     }
3126
3127     svp = av_fetch(av, elem, lval && !defer);
3128     if (lval) {
3129 #ifdef PERL_MALLOC_WRAP
3130          if (SvUOK(elemsv)) {
3131               const UV uv = SvUV(elemsv);
3132               elem = uv > IV_MAX ? IV_MAX : uv;
3133          }
3134          else if (SvNOK(elemsv))
3135               elem = (IV)SvNV(elemsv);
3136          if (elem > 0) {
3137               static const char oom_array_extend[] =
3138                 "Out of memory during array extend"; /* Duplicated in av.c */
3139               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3140          }
3141 #endif
3142         if (!svp || *svp == &PL_sv_undef) {
3143             SV* lv;
3144             if (!defer)
3145                 DIE(aTHX_ PL_no_aelem, elem);
3146             lv = sv_newmortal();
3147             sv_upgrade(lv, SVt_PVLV);
3148             LvTYPE(lv) = 'y';
3149             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3150             LvTARG(lv) = SvREFCNT_inc_simple(av);
3151             LvTARGOFF(lv) = elem;
3152             LvTARGLEN(lv) = 1;
3153             PUSHs(lv);
3154             RETURN;
3155         }
3156         if (localizing) {
3157             if (preeminent)
3158                 save_aelem(av, elem, svp);
3159             else
3160                 SAVEADELETE(av, elem);
3161         }
3162         else if (PL_op->op_private & OPpDEREF)
3163             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3164     }
3165     sv = (svp ? *svp : &PL_sv_undef);
3166     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3167         mg_get(sv);
3168     PUSHs(sv);
3169     RETURN;
3170 }
3171
3172 void
3173 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3174 {
3175     PERL_ARGS_ASSERT_VIVIFY_REF;
3176
3177     SvGETMAGIC(sv);
3178     if (!SvOK(sv)) {
3179         if (SvREADONLY(sv))
3180             Perl_croak_no_modify(aTHX);
3181         prepare_SV_for_RV(sv);
3182         switch (to_what) {
3183         case OPpDEREF_SV:
3184             SvRV_set(sv, newSV(0));
3185             break;
3186         case OPpDEREF_AV:
3187             SvRV_set(sv, MUTABLE_SV(newAV()));
3188             break;
3189         case OPpDEREF_HV:
3190             SvRV_set(sv, MUTABLE_SV(newHV()));
3191             break;
3192         }
3193         SvROK_on(sv);
3194         SvSETMAGIC(sv);
3195     }
3196 }
3197
3198 PP(pp_method)
3199 {
3200     dVAR; dSP;
3201     SV* const sv = TOPs;
3202
3203     if (SvROK(sv)) {
3204         SV* const rsv = SvRV(sv);
3205         if (SvTYPE(rsv) == SVt_PVCV) {
3206             SETs(rsv);
3207             RETURN;
3208         }
3209     }
3210
3211     SETs(method_common(sv, NULL));
3212     RETURN;
3213 }
3214
3215 PP(pp_method_named)
3216 {
3217     dVAR; dSP;
3218     SV* const sv = cSVOP_sv;
3219     U32 hash = SvSHARED_HASH(sv);
3220
3221     XPUSHs(method_common(sv, &hash));
3222     RETURN;
3223 }
3224
3225 STATIC SV *
3226 S_method_common(pTHX_ SV* meth, U32* hashp)
3227 {
3228     dVAR;
3229     SV* ob;
3230     GV* gv;
3231     HV* stash;
3232     const char* packname = NULL;
3233     SV *packsv = NULL;
3234     STRLEN packlen;
3235     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3236
3237     PERL_ARGS_ASSERT_METHOD_COMMON;
3238
3239     if (!sv)
3240         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3241                    SVfARG(meth));
3242
3243     SvGETMAGIC(sv);
3244     if (SvROK(sv))
3245         ob = MUTABLE_SV(SvRV(sv));
3246     else {
3247         GV* iogv;
3248
3249         /* this isn't a reference */
3250         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3251           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3252           if (he) { 
3253             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3254             goto fetch;
3255           }
3256         }
3257
3258         if (!SvOK(sv) ||
3259             !(packname) ||
3260             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3261             !(ob=MUTABLE_SV(GvIO(iogv))))
3262         {
3263             /* this isn't the name of a filehandle either */
3264             if (!packname ||
3265                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3266                     ? !isIDFIRST_utf8((U8*)packname)
3267                     : !isIDFIRST(*packname)
3268                 ))
3269             {
3270                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3271                            SVfARG(meth),
3272                            SvOK(sv) ? "without a package or object reference"
3273                                     : "on an undefined value");
3274             }
3275             /* assume it's a package name */
3276             stash = gv_stashpvn(packname, packlen, 0);
3277             if (!stash)
3278                 packsv = sv;
3279             else {
3280                 SV* const ref = newSViv(PTR2IV(stash));
3281                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3282             }
3283             goto fetch;
3284         }
3285         /* it _is_ a filehandle name -- replace with a reference */
3286         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3287     }
3288
3289     /* if we got here, ob should be a reference or a glob */
3290     if (!ob || !(SvOBJECT(ob)
3291                  || (SvTYPE(ob) == SVt_PVGV 
3292                      && isGV_with_GP(ob)
3293                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3294                      && SvOBJECT(ob))))
3295     {
3296         const char * const name = SvPV_nolen_const(meth);
3297         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3298                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3299                    name);
3300     }
3301
3302     stash = SvSTASH(ob);
3303
3304   fetch:
3305     /* NOTE: stash may be null, hope hv_fetch_ent and
3306        gv_fetchmethod can cope (it seems they can) */
3307
3308     /* shortcut for simple names */
3309     if (hashp) {
3310         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3311         if (he) {
3312             gv = MUTABLE_GV(HeVAL(he));
3313             if (isGV(gv) && GvCV(gv) &&
3314                 (!GvCVGEN(gv) || GvCVGEN(gv)
3315                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3316                 return MUTABLE_SV(GvCV(gv));
3317         }
3318     }
3319
3320     gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3321                               SvPV_nolen_const(meth),
3322                               GV_AUTOLOAD | GV_CROAK);
3323
3324     assert(gv);
3325
3326     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3327 }
3328
3329 /*
3330  * Local variables:
3331  * c-indentation-style: bsd
3332  * c-basic-offset: 4
3333  * indent-tabs-mode: t
3334  * End:
3335  *
3336  * ex: set ts=8 sts=4 sw=4 noet:
3337  */