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