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