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