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