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