This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't copy all of the match string buffer
[perl5.git] / pp_hot.c
1 /*    pp_hot.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
13  * shaking the air.
14  *
15  *                  Awake!  Awake!  Fear, Fire, Foes!  Awake!
16  *                               Fire, Foes!  Awake!
17  *
18  *     [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
19  */
20
21 /* This file contains 'hot' pp ("push/pop") functions that
22  * execute the opcodes that make up a perl program. A typical pp function
23  * expects to find its arguments on the stack, and usually pushes its
24  * results onto the stack, hence the 'pp' terminology. Each OP structure
25  * contains a pointer to the relevant pp_foo() function.
26  *
27  * By 'hot', we mean common ops whose execution speed is critical.
28  * By gathering them together into a single file, we encourage
29  * CPU cache hits on hot code. Also it could be taken as a warning not to
30  * change any code in this file unless you're sure it won't affect
31  * performance.
32  */
33
34 #include "EXTERN.h"
35 #define PERL_IN_PP_HOT_C
36 #include "perl.h"
37
38 /* Hot code. */
39
40 PP(pp_const)
41 {
42     dVAR;
43     dSP;
44     XPUSHs(cSVOP_sv);
45     RETURN;
46 }
47
48 PP(pp_nextstate)
49 {
50     dVAR;
51     PL_curcop = (COP*)PL_op;
52     TAINT_NOT;          /* Each statement is presumed innocent */
53     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
54     FREETMPS;
55     PERL_ASYNC_CHECK();
56     return NORMAL;
57 }
58
59 PP(pp_gvsv)
60 {
61     dVAR;
62     dSP;
63     EXTEND(SP,1);
64     if (PL_op->op_private & OPpLVAL_INTRO)
65         PUSHs(save_scalar(cGVOP_gv));
66     else
67         PUSHs(GvSVn(cGVOP_gv));
68     RETURN;
69 }
70
71 PP(pp_null)
72 {
73     dVAR;
74     return NORMAL;
75 }
76
77 /* This is sometimes called directly by pp_coreargs 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     /* XXX: comment out !global get safe $1 vars after a
1323        match, BUT be aware that this leads to dramatic slowdowns on
1324        /g matches against large strings.  So far a solution to this problem
1325        appears to be quite tricky.
1326        Test for the unsafe vars are TODO for now. */
1327     if (       (!global && RX_NPARENS(rx))
1328             || PL_sawampersand
1329             || SvTEMP(TARG)
1330             || SvAMAGIC(TARG)
1331             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1332     ) {
1333         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1334         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1335          * only on the first iteration. Therefore we need to copy $' as well
1336          * as $&, to make the rest of the string available for captures in
1337          * subsequent iterations */
1338         if (! (global && gimme == G_ARRAY))
1339             r_flags |= REXEC_COPY_SKIP_POST;
1340     };
1341
1342   play_it_again:
1343     if (global && RX_OFFS(rx)[0].start != -1) {
1344         t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1345         if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
1346             DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
1347             goto nope;
1348         }
1349         if (update_minmatch++)
1350             minmatch = had_zerolen;
1351     }
1352     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1353         DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1354         /* FIXME - can PL_bostr be made const char *?  */
1355         PL_bostr = (char *)truebase;
1356         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1357
1358         if (!s)
1359             goto nope;
1360         if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1361              && !PL_sawampersand
1362              && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1363              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1364             goto yup;
1365     }
1366     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1367                      minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1368         goto ret_no;
1369
1370     PL_curpm = pm;
1371     if (dynpm->op_pmflags & PMf_ONCE) {
1372 #ifdef USE_ITHREADS
1373         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1374 #else
1375         dynpm->op_pmflags |= PMf_USED;
1376 #endif
1377     }
1378
1379   gotcha:
1380     if (rxtainted)
1381         RX_MATCH_TAINTED_on(rx);
1382     TAINT_IF(RX_MATCH_TAINTED(rx));
1383     if (gimme == G_ARRAY) {
1384         const I32 nparens = RX_NPARENS(rx);
1385         I32 i = (global && !nparens) ? 1 : 0;
1386
1387         SPAGAIN;                        /* EVAL blocks could move the stack. */
1388         EXTEND(SP, nparens + i);
1389         EXTEND_MORTAL(nparens + i);
1390         for (i = !i; i <= nparens; i++) {
1391             PUSHs(sv_newmortal());
1392             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1393                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1394                 s = RX_OFFS(rx)[i].start + truebase;
1395                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1396                     len < 0 || len > strend - s)
1397                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1398                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1399                         (long) i, (long) RX_OFFS(rx)[i].start,
1400                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1401                 sv_setpvn(*SP, s, len);
1402                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1403                     SvUTF8_on(*SP);
1404             }
1405         }
1406         if (global) {
1407             if (dynpm->op_pmflags & PMf_CONTINUE) {
1408                 MAGIC* mg = NULL;
1409                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1410                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1411                 if (!mg) {
1412 #ifdef PERL_OLD_COPY_ON_WRITE
1413                     if (SvIsCOW(TARG))
1414                         sv_force_normal_flags(TARG, 0);
1415 #endif
1416                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1417                                      &PL_vtbl_mglob, NULL, 0);
1418                 }
1419                 if (RX_OFFS(rx)[0].start != -1) {
1420                     mg->mg_len = RX_OFFS(rx)[0].end;
1421                     if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1422                         mg->mg_flags |= MGf_MINMATCH;
1423                     else
1424                         mg->mg_flags &= ~MGf_MINMATCH;
1425                 }
1426             }
1427             had_zerolen = (RX_OFFS(rx)[0].start != -1
1428                            && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1429                                == (UV)RX_OFFS(rx)[0].end));
1430             PUTBACK;                    /* EVAL blocks may use stack */
1431             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1432             goto play_it_again;
1433         }
1434         else if (!nparens)
1435             XPUSHs(&PL_sv_yes);
1436         LEAVE_SCOPE(oldsave);
1437         RETURN;
1438     }
1439     else {
1440         if (global) {
1441             MAGIC* mg;
1442             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1443                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1444             else
1445                 mg = NULL;
1446             if (!mg) {
1447 #ifdef PERL_OLD_COPY_ON_WRITE
1448                 if (SvIsCOW(TARG))
1449                     sv_force_normal_flags(TARG, 0);
1450 #endif
1451                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1452                                  &PL_vtbl_mglob, NULL, 0);
1453             }
1454             if (RX_OFFS(rx)[0].start != -1) {
1455                 mg->mg_len = RX_OFFS(rx)[0].end;
1456                 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1457                     mg->mg_flags |= MGf_MINMATCH;
1458                 else
1459                     mg->mg_flags &= ~MGf_MINMATCH;
1460             }
1461         }
1462         LEAVE_SCOPE(oldsave);
1463         RETPUSHYES;
1464     }
1465
1466 yup:                                    /* Confirmed by INTUIT */
1467     if (rxtainted)
1468         RX_MATCH_TAINTED_on(rx);
1469     TAINT_IF(RX_MATCH_TAINTED(rx));
1470     PL_curpm = pm;
1471     if (dynpm->op_pmflags & PMf_ONCE) {
1472 #ifdef USE_ITHREADS
1473         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1474 #else
1475         dynpm->op_pmflags |= PMf_USED;
1476 #endif
1477     }
1478     if (RX_MATCH_COPIED(rx))
1479         Safefree(RX_SUBBEG(rx));
1480     RX_MATCH_COPIED_off(rx);
1481     RX_SUBBEG(rx) = NULL;
1482     if (global) {
1483         /* FIXME - should rx->subbeg be const char *?  */
1484         RX_SUBBEG(rx) = (char *) truebase;
1485         RX_SUBOFFSET(rx) = 0;
1486         RX_SUBCOFFSET(rx) = 0;
1487         RX_OFFS(rx)[0].start = s - truebase;
1488         if (RX_MATCH_UTF8(rx)) {
1489             char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1490             RX_OFFS(rx)[0].end = t - truebase;
1491         }
1492         else {
1493             RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1494         }
1495         RX_SUBLEN(rx) = strend - truebase;
1496         goto gotcha;
1497     }
1498     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1499         I32 off;
1500 #ifdef PERL_OLD_COPY_ON_WRITE
1501         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1502             if (DEBUG_C_TEST) {
1503                 PerlIO_printf(Perl_debug_log,
1504                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1505                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1506                               (int)(t-truebase));
1507             }
1508             RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1509             RX_SUBBEG(rx)
1510                 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1511             assert (SvPOKp(RX_SAVED_COPY(rx)));
1512         } else
1513 #endif
1514         {
1515
1516             RX_SUBBEG(rx) = savepvn(t, strend - t);
1517 #ifdef PERL_OLD_COPY_ON_WRITE
1518             RX_SAVED_COPY(rx) = NULL;
1519 #endif
1520         }
1521         RX_SUBLEN(rx) = strend - t;
1522         RX_SUBOFFSET(rx) = 0;
1523         RX_SUBCOFFSET(rx) = 0;
1524         RX_MATCH_COPIED_on(rx);
1525         off = RX_OFFS(rx)[0].start = s - t;
1526         RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1527     }
1528     else {                      /* startp/endp are used by @- @+. */
1529         RX_OFFS(rx)[0].start = s - truebase;
1530         RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1531     }
1532     /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
1533     assert(!RX_NPARENS(rx));
1534     RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
1535     LEAVE_SCOPE(oldsave);
1536     RETPUSHYES;
1537
1538 nope:
1539 ret_no:
1540     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1541         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1542             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1543             if (mg)
1544                 mg->mg_len = -1;
1545         }
1546     }
1547     LEAVE_SCOPE(oldsave);
1548     if (gimme == G_ARRAY)
1549         RETURN;
1550     RETPUSHNO;
1551 }
1552
1553 OP *
1554 Perl_do_readline(pTHX)
1555 {
1556     dVAR; dSP; dTARGETSTACKED;
1557     SV *sv;
1558     STRLEN tmplen = 0;
1559     STRLEN offset;
1560     PerlIO *fp;
1561     IO * const io = GvIO(PL_last_in_gv);
1562     const I32 type = PL_op->op_type;
1563     const I32 gimme = GIMME_V;
1564
1565     if (io) {
1566         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1567         if (mg) {
1568             Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1569             if (gimme == G_SCALAR) {
1570                 SPAGAIN;
1571                 SvSetSV_nosteal(TARG, TOPs);
1572                 SETTARG;
1573             }
1574             return NORMAL;
1575         }
1576     }
1577     fp = NULL;
1578     if (io) {
1579         fp = IoIFP(io);
1580         if (!fp) {
1581             if (IoFLAGS(io) & IOf_ARGV) {
1582                 if (IoFLAGS(io) & IOf_START) {
1583                     IoLINES(io) = 0;
1584                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1585                         IoFLAGS(io) &= ~IOf_START;
1586                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1587                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1588                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1589                         SvSETMAGIC(GvSV(PL_last_in_gv));
1590                         fp = IoIFP(io);
1591                         goto have_fp;
1592                     }
1593                 }
1594                 fp = nextargv(PL_last_in_gv);
1595                 if (!fp) { /* Note: fp != IoIFP(io) */
1596                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1597                 }
1598             }
1599             else if (type == OP_GLOB)
1600                 fp = Perl_start_glob(aTHX_ POPs, io);
1601         }
1602         else if (type == OP_GLOB)
1603             SP--;
1604         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1605             report_wrongway_fh(PL_last_in_gv, '>');
1606         }
1607     }
1608     if (!fp) {
1609         if ((!io || !(IoFLAGS(io) & IOf_START))
1610             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1611         {
1612             if (type == OP_GLOB)
1613                 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
1614                             "glob failed (can't start child: %s)",
1615                             Strerror(errno));
1616             else
1617                 report_evil_fh(PL_last_in_gv);
1618         }
1619         if (gimme == G_SCALAR) {
1620             /* undef TARG, and push that undefined value */
1621             if (type != OP_RCATLINE) {
1622                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1623                 SvOK_off(TARG);
1624             }
1625             PUSHTARG;
1626         }
1627         RETURN;
1628     }
1629   have_fp:
1630     if (gimme == G_SCALAR) {
1631         sv = TARG;
1632         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1633             mg_get(sv);
1634         if (SvROK(sv)) {
1635             if (type == OP_RCATLINE)
1636                 SvPV_force_nomg_nolen(sv);
1637             else
1638                 sv_unref(sv);
1639         }
1640         else if (isGV_with_GP(sv)) {
1641             SvPV_force_nomg_nolen(sv);
1642         }
1643         SvUPGRADE(sv, SVt_PV);
1644         tmplen = SvLEN(sv);     /* remember if already alloced */
1645         if (!tmplen && !SvREADONLY(sv)) {
1646             /* try short-buffering it. Please update t/op/readline.t
1647              * if you change the growth length.
1648              */
1649             Sv_Grow(sv, 80);
1650         }
1651         offset = 0;
1652         if (type == OP_RCATLINE && SvOK(sv)) {
1653             if (!SvPOK(sv)) {
1654                 SvPV_force_nomg_nolen(sv);
1655             }
1656             offset = SvCUR(sv);
1657         }
1658     }
1659     else {
1660         sv = sv_2mortal(newSV(80));
1661         offset = 0;
1662     }
1663
1664     /* This should not be marked tainted if the fp is marked clean */
1665 #define MAYBE_TAINT_LINE(io, sv) \
1666     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1667         TAINT;                          \
1668         SvTAINTED_on(sv);               \
1669     }
1670
1671 /* delay EOF state for a snarfed empty file */
1672 #define SNARF_EOF(gimme,rs,io,sv) \
1673     (gimme != G_SCALAR || SvCUR(sv)                                     \
1674      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1675
1676     for (;;) {
1677         PUTBACK;
1678         if (!sv_gets(sv, fp, offset)
1679             && (type == OP_GLOB
1680                 || SNARF_EOF(gimme, PL_rs, io, sv)
1681                 || PerlIO_error(fp)))
1682         {
1683             PerlIO_clearerr(fp);
1684             if (IoFLAGS(io) & IOf_ARGV) {
1685                 fp = nextargv(PL_last_in_gv);
1686                 if (fp)
1687                     continue;
1688                 (void)do_close(PL_last_in_gv, FALSE);
1689             }
1690             else if (type == OP_GLOB) {
1691                 if (!do_close(PL_last_in_gv, FALSE)) {
1692                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1693                                    "glob failed (child exited with status %d%s)",
1694                                    (int)(STATUS_CURRENT >> 8),
1695                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1696                 }
1697             }
1698             if (gimme == G_SCALAR) {
1699                 if (type != OP_RCATLINE) {
1700                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1701                     SvOK_off(TARG);
1702                 }
1703                 SPAGAIN;
1704                 PUSHTARG;
1705             }
1706             MAYBE_TAINT_LINE(io, sv);
1707             RETURN;
1708         }
1709         MAYBE_TAINT_LINE(io, sv);
1710         IoLINES(io)++;
1711         IoFLAGS(io) |= IOf_NOLINE;
1712         SvSETMAGIC(sv);
1713         SPAGAIN;
1714         XPUSHs(sv);
1715         if (type == OP_GLOB) {
1716             const char *t1;
1717
1718             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1719                 char * const tmps = SvEND(sv) - 1;
1720                 if (*tmps == *SvPVX_const(PL_rs)) {
1721                     *tmps = '\0';
1722                     SvCUR_set(sv, SvCUR(sv) - 1);
1723                 }
1724             }
1725             for (t1 = SvPVX_const(sv); *t1; t1++)
1726                 if (!isALNUMC(*t1) &&
1727                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1728                         break;
1729             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1730                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1731                 continue;
1732             }
1733         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1734              if (ckWARN(WARN_UTF8)) {
1735                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1736                 const STRLEN len = SvCUR(sv) - offset;
1737                 const U8 *f;
1738
1739                 if (!is_utf8_string_loc(s, len, &f))
1740                     /* Emulate :encoding(utf8) warning in the same case. */
1741                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1742                                 "utf8 \"\\x%02X\" does not map to Unicode",
1743                                 f < (U8*)SvEND(sv) ? *f : 0);
1744              }
1745         }
1746         if (gimme == G_ARRAY) {
1747             if (SvLEN(sv) - SvCUR(sv) > 20) {
1748                 SvPV_shrink_to_cur(sv);
1749             }
1750             sv = sv_2mortal(newSV(80));
1751             continue;
1752         }
1753         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1754             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1755             const STRLEN new_len
1756                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1757             SvPV_renew(sv, new_len);
1758         }
1759         RETURN;
1760     }
1761 }
1762
1763 PP(pp_helem)
1764 {
1765     dVAR; dSP;
1766     HE* he;
1767     SV **svp;
1768     SV * const keysv = POPs;
1769     HV * const hv = MUTABLE_HV(POPs);
1770     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1771     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1772     SV *sv;
1773     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1774     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1775     bool preeminent = TRUE;
1776
1777     if (SvTYPE(hv) != SVt_PVHV)
1778         RETPUSHUNDEF;
1779
1780     if (localizing) {
1781         MAGIC *mg;
1782         HV *stash;
1783
1784         /* If we can determine whether the element exist,
1785          * Try to preserve the existenceness of a tied hash
1786          * element by using EXISTS and DELETE if possible.
1787          * Fallback to FETCH and STORE otherwise. */
1788         if (SvCANEXISTDELETE(hv))
1789             preeminent = hv_exists_ent(hv, keysv, 0);
1790     }
1791
1792     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1793     svp = he ? &HeVAL(he) : NULL;
1794     if (lval) {
1795         if (!svp || !*svp || *svp == &PL_sv_undef) {
1796             SV* lv;
1797             SV* key2;
1798             if (!defer) {
1799                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1800             }
1801             lv = sv_newmortal();
1802             sv_upgrade(lv, SVt_PVLV);
1803             LvTYPE(lv) = 'y';
1804             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1805             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1806             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1807             LvTARGLEN(lv) = 1;
1808             PUSHs(lv);
1809             RETURN;
1810         }
1811         if (localizing) {
1812             if (HvNAME_get(hv) && isGV(*svp))
1813                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1814             else if (preeminent)
1815                 save_helem_flags(hv, keysv, svp,
1816                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1817             else
1818                 SAVEHDELETE(hv, keysv);
1819         }
1820         else if (PL_op->op_private & OPpDEREF) {
1821             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1822             RETURN;
1823         }
1824     }
1825     sv = (svp && *svp ? *svp : &PL_sv_undef);
1826     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1827      * was to make C<local $tied{foo} = $tied{foo}> possible.
1828      * However, it seems no longer to be needed for that purpose, and
1829      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1830      * would loop endlessly since the pos magic is getting set on the
1831      * mortal copy and lost. However, the copy has the effect of
1832      * triggering the get magic, and losing it altogether made things like
1833      * c<$tied{foo};> in void context no longer do get magic, which some
1834      * code relied on. Also, delayed triggering of magic on @+ and friends
1835      * meant the original regex may be out of scope by now. So as a
1836      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1837      * being called too many times). */
1838     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1839         mg_get(sv);
1840     PUSHs(sv);
1841     RETURN;
1842 }
1843
1844 PP(pp_iter)
1845 {
1846     dVAR; dSP;
1847     PERL_CONTEXT *cx;
1848     SV *sv, *oldsv;
1849     SV **itersvp;
1850     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1851     bool av_is_stack = FALSE;
1852
1853     EXTEND(SP, 1);
1854     cx = &cxstack[cxstack_ix];
1855     if (!CxTYPE_is_LOOP(cx))
1856         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1857
1858     itersvp = CxITERVAR(cx);
1859     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1860             /* string increment */
1861             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1862             SV *end = cx->blk_loop.state_u.lazysv.end;
1863             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1864                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1865             STRLEN maxlen = 0;
1866             const char *max = SvPV_const(end, maxlen);
1867             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1868                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1869                     /* safe to reuse old SV */
1870                     sv_setsv(*itersvp, cur);
1871                 }
1872                 else
1873                 {
1874                     /* we need a fresh SV every time so that loop body sees a
1875                      * completely new SV for closures/references to work as
1876                      * they used to */
1877                     oldsv = *itersvp;
1878                     *itersvp = newSVsv(cur);
1879                     SvREFCNT_dec(oldsv);
1880                 }
1881                 if (strEQ(SvPVX_const(cur), max))
1882                     sv_setiv(cur, 0); /* terminate next time */
1883                 else
1884                     sv_inc(cur);
1885                 RETPUSHYES;
1886             }
1887             RETPUSHNO;
1888     }
1889     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1890         /* integer increment */
1891         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1892             RETPUSHNO;
1893
1894         /* don't risk potential race */
1895         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1896             /* safe to reuse old SV */
1897             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur);
1898         }
1899         else
1900         {
1901             /* we need a fresh SV every time so that loop body sees a
1902              * completely new SV for closures/references to work as they
1903              * used to */
1904             oldsv = *itersvp;
1905             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur);
1906             SvREFCNT_dec(oldsv);
1907         }
1908
1909         if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) {
1910             /* Handle end of range at IV_MAX */
1911             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1912         } else
1913             ++cx->blk_loop.state_u.lazyiv.cur;
1914
1915         RETPUSHYES;
1916     }
1917
1918     /* iterate array */
1919     assert(CxTYPE(cx) == CXt_LOOP_FOR);
1920     av = cx->blk_loop.state_u.ary.ary;
1921     if (!av) {
1922         av_is_stack = TRUE;
1923         av = PL_curstack;
1924     }
1925     if (PL_op->op_private & OPpITER_REVERSED) {
1926         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1927                                     ? cx->blk_loop.resetsp + 1 : 0))
1928             RETPUSHNO;
1929
1930         if (SvMAGICAL(av) || AvREIFY(av)) {
1931             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1932             sv = svp ? *svp : NULL;
1933         }
1934         else {
1935             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1936         }
1937     }
1938     else {
1939         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1940                                     AvFILL(av)))
1941             RETPUSHNO;
1942
1943         if (SvMAGICAL(av) || AvREIFY(av)) {
1944             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1945             sv = svp ? *svp : NULL;
1946         }
1947         else {
1948             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1949         }
1950     }
1951
1952     if (sv && SvIS_FREED(sv)) {
1953         *itersvp = NULL;
1954         Perl_croak(aTHX_ "Use of freed value in iteration");
1955     }
1956
1957     if (sv) {
1958         SvTEMP_off(sv);
1959         SvREFCNT_inc_simple_void_NN(sv);
1960     }
1961     else
1962         sv = &PL_sv_undef;
1963     if (!av_is_stack && sv == &PL_sv_undef) {
1964         SV *lv = newSV_type(SVt_PVLV);
1965         LvTYPE(lv) = 'y';
1966         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1967         LvTARG(lv) = SvREFCNT_inc_simple(av);
1968         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1969         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1970         sv = lv;
1971     }
1972
1973     oldsv = *itersvp;
1974     *itersvp = sv;
1975     SvREFCNT_dec(oldsv);
1976
1977     RETPUSHYES;
1978 }
1979
1980 /*
1981 A description of how taint works in pattern matching and substitution.
1982
1983 While the pattern is being assembled/concatenated and then compiled,
1984 PL_tainted will get set if any component of the pattern is tainted, e.g.
1985 /.*$tainted/.  At the end of pattern compilation, the RXf_TAINTED flag
1986 is set on the pattern if PL_tainted is set.
1987
1988 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1989 the pattern is marked as tainted. This means that subsequent usage, such
1990 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1991
1992 During execution of a pattern, locale-variant ops such as ALNUML set the
1993 local flag RF_tainted. At the end of execution, the engine sets the
1994 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1995 otherwise.
1996
1997 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1998 of $1 et al to indicate whether the returned value should be tainted.
1999 It is the responsibility of the caller of the pattern (i.e. pp_match,
2000 pp_subst etc) to set this flag for any other circumstances where $1 needs
2001 to be tainted.
2002
2003 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2004
2005 There are three possible sources of taint
2006     * the source string
2007     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2008     * the replacement string (or expression under /e)
2009     
2010 There are four destinations of taint and they are affected by the sources
2011 according to the rules below:
2012
2013     * the return value (not including /r):
2014         tainted by the source string and pattern, but only for the
2015         number-of-iterations case; boolean returns aren't tainted;
2016     * the modified string (or modified copy under /r):
2017         tainted by the source string, pattern, and replacement strings;
2018     * $1 et al:
2019         tainted by the pattern, and under 'use re "taint"', by the source
2020         string too;
2021     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2022         should always be unset before executing subsequent code.
2023
2024 The overall action of pp_subst is:
2025
2026     * at the start, set bits in rxtainted indicating the taint status of
2027         the various sources.
2028
2029     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2030         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2031         pattern has subsequently become tainted via locale ops.
2032
2033     * If control is being passed to pp_substcont to execute a /e block,
2034         save rxtainted in the CXt_SUBST block, for future use by
2035         pp_substcont.
2036
2037     * Whenever control is being returned to perl code (either by falling
2038         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2039         use the flag bits in rxtainted to make all the appropriate types of
2040         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2041         et al will appear tainted.
2042
2043 pp_match is just a simpler version of the above.
2044
2045 */
2046
2047 PP(pp_subst)
2048 {
2049     dVAR; dSP; dTARG;
2050     PMOP *pm = cPMOP;
2051     PMOP *rpm = pm;
2052     char *s;
2053     char *strend;
2054     char *m;
2055     const char *c;
2056     char *d;
2057     STRLEN clen;
2058     I32 iters = 0;
2059     I32 maxiters;
2060     I32 i;
2061     bool once;
2062     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2063                         See "how taint works" above */
2064     char *orig;
2065     U8 r_flags;
2066     REGEXP *rx = PM_GETRE(pm);
2067     STRLEN len;
2068     int force_on_match = 0;
2069     const I32 oldsave = PL_savestack_ix;
2070     STRLEN slen;
2071     bool doutf8 = FALSE;
2072 #ifdef PERL_OLD_COPY_ON_WRITE
2073     bool is_cow;
2074 #endif
2075     SV *nsv = NULL;
2076     /* known replacement string? */
2077     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2078
2079     PERL_ASYNC_CHECK();
2080
2081     if (PL_op->op_flags & OPf_STACKED)
2082         TARG = POPs;
2083     else if (PL_op->op_private & OPpTARGET_MY)
2084         GETTARGET;
2085     else {
2086         TARG = DEFSV;
2087         EXTEND(SP,1);
2088     }
2089
2090 #ifdef PERL_OLD_COPY_ON_WRITE
2091     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2092        because they make integers such as 256 "false".  */
2093     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2094 #else
2095     if (SvIsCOW(TARG))
2096         sv_force_normal_flags(TARG,0);
2097 #endif
2098     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2099 #ifdef PERL_OLD_COPY_ON_WRITE
2100         && !is_cow
2101 #endif
2102         && (SvREADONLY(TARG)
2103             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2104                   || SvTYPE(TARG) > SVt_PVLV)
2105                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2106         Perl_croak_no_modify(aTHX);
2107     PUTBACK;
2108
2109   setup_match:
2110     s = SvPV_mutable(TARG, len);
2111     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2112         force_on_match = 1;
2113
2114     /* only replace once? */
2115     once = !(rpm->op_pmflags & PMf_GLOBAL);
2116
2117     /* See "how taint works" above */
2118     if (PL_tainting) {
2119         rxtainted  = (
2120             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2121           | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2122           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2123           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2124                 ? SUBST_TAINT_BOOLRET : 0));
2125         TAINT_NOT;
2126     }
2127
2128     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2129
2130   force_it:
2131     if (!pm || !s)
2132         DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2133
2134     strend = s + len;
2135     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2136     maxiters = 2 * slen + 10;   /* We can match twice at each
2137                                    position, once with zero-length,
2138                                    second time with non-zero. */
2139
2140     if (!RX_PRELEN(rx) && PL_curpm) {
2141         pm = PL_curpm;
2142         rx = PM_GETRE(pm);
2143     }
2144
2145     r_flags = (    RX_NPARENS(rx)
2146                 || PL_sawampersand
2147                 || SvTEMP(TARG)
2148                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2149               )
2150           ? REXEC_COPY_STR
2151           : 0;
2152
2153     orig = m = s;
2154     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2155         PL_bostr = orig;
2156         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2157
2158         if (!s)
2159             goto ret_no;
2160         /* How to do it in subst? */
2161 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2162              && !PL_sawampersand
2163              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
2164             goto yup;
2165 */
2166     }
2167
2168     if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2169                          r_flags | REXEC_CHECKED))
2170     {
2171       ret_no:
2172         SPAGAIN;
2173         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2174         LEAVE_SCOPE(oldsave);
2175         RETURN;
2176     }
2177
2178     /* known replacement string? */
2179     if (dstr) {
2180         if (SvTAINTED(dstr))
2181             rxtainted |= SUBST_TAINT_REPL;
2182
2183         /* Upgrade the source if the replacement is utf8 but the source is not,
2184          * but only if it matched; see
2185          * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2186          */
2187         if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2188             char * const orig_pvx =  SvPVX(TARG);
2189             const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2190
2191             /* If the lengths are the same, the pattern contains only
2192              * invariants, can keep going; otherwise, various internal markers
2193              * could be off, so redo */
2194             if (new_len != len || orig_pvx != SvPVX(TARG)) {
2195                 goto setup_match;
2196             }
2197         }
2198
2199         /* replacement needing upgrading? */
2200         if (DO_UTF8(TARG) && !doutf8) {
2201              nsv = sv_newmortal();
2202              SvSetSV(nsv, dstr);
2203              if (PL_encoding)
2204                   sv_recode_to_utf8(nsv, PL_encoding);
2205              else
2206                   sv_utf8_upgrade(nsv);
2207              c = SvPV_const(nsv, clen);
2208              doutf8 = TRUE;
2209         }
2210         else {
2211             c = SvPV_const(dstr, clen);
2212             doutf8 = DO_UTF8(dstr);
2213         }
2214     }
2215     else {
2216         c = NULL;
2217         doutf8 = FALSE;
2218     }
2219     
2220     /* can do inplace substitution? */
2221     if (c
2222 #ifdef PERL_OLD_COPY_ON_WRITE
2223         && !is_cow
2224 #endif
2225         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2226         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2227         && (!doutf8 || SvUTF8(TARG))
2228         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2229     {
2230
2231 #ifdef PERL_OLD_COPY_ON_WRITE
2232         if (SvIsCOW(TARG)) {
2233             assert (!force_on_match);
2234             goto have_a_cow;
2235         }
2236 #endif
2237         if (force_on_match) {
2238             force_on_match = 0;
2239             s = SvPV_force(TARG, len);
2240             goto force_it;
2241         }
2242         d = s;
2243         PL_curpm = pm;
2244         if (once) {
2245             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2246                 rxtainted |= SUBST_TAINT_PAT;
2247             m = orig + RX_OFFS(rx)[0].start;
2248             d = orig + RX_OFFS(rx)[0].end;
2249             s = orig;
2250             if (m - s > strend - d) {  /* faster to shorten from end */
2251                 if (clen) {
2252                     Copy(c, m, clen, char);
2253                     m += clen;
2254                 }
2255                 i = strend - d;
2256                 if (i > 0) {
2257                     Move(d, m, i, char);
2258                     m += i;
2259                 }
2260                 *m = '\0';
2261                 SvCUR_set(TARG, m - s);
2262             }
2263             else if ((i = m - s)) {     /* faster from front */
2264                 d -= clen;
2265                 m = d;
2266                 Move(s, d - i, i, char);
2267                 sv_chop(TARG, d-i);
2268                 if (clen)
2269                     Copy(c, m, clen, char);
2270             }
2271             else if (clen) {
2272                 d -= clen;
2273                 sv_chop(TARG, d);
2274                 Copy(c, d, clen, char);
2275             }
2276             else {
2277                 sv_chop(TARG, d);
2278             }
2279             SPAGAIN;
2280             PUSHs(&PL_sv_yes);
2281         }
2282         else {
2283             do {
2284                 if (iters++ > maxiters)
2285                     DIE(aTHX_ "Substitution loop");
2286                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2287                     rxtainted |= SUBST_TAINT_PAT;
2288                 m = RX_OFFS(rx)[0].start + orig;
2289                 if ((i = m - s)) {
2290                     if (s != d)
2291                         Move(s, d, i, char);
2292                     d += i;
2293                 }
2294                 if (clen) {
2295                     Copy(c, d, clen, char);
2296                     d += clen;
2297                 }
2298                 s = RX_OFFS(rx)[0].end + orig;
2299             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2300                                  TARG, NULL,
2301                                  /* don't match same null twice */
2302                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2303             if (s != d) {
2304                 i = strend - s;
2305                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2306                 Move(s, d, i+1, char);          /* include the NUL */
2307             }
2308             SPAGAIN;
2309             mPUSHi((I32)iters);
2310         }
2311     }
2312     else {
2313         if (force_on_match) {
2314             force_on_match = 0;
2315             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2316                 /* I feel that it should be possible to avoid this mortal copy
2317                    given that the code below copies into a new destination.
2318                    However, I suspect it isn't worth the complexity of
2319                    unravelling the C<goto force_it> for the small number of
2320                    cases where it would be viable to drop into the copy code. */
2321                 TARG = sv_2mortal(newSVsv(TARG));
2322             }
2323             s = SvPV_force(TARG, len);
2324             goto force_it;
2325         }
2326 #ifdef PERL_OLD_COPY_ON_WRITE
2327       have_a_cow:
2328 #endif
2329         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2330             rxtainted |= SUBST_TAINT_PAT;
2331         dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2332         PL_curpm = pm;
2333         if (!c) {
2334             PERL_CONTEXT *cx;
2335             SPAGAIN;
2336             /* note that a whole bunch of local vars are saved here for
2337              * use by pp_substcont: here's a list of them in case you're
2338              * searching for places in this sub that uses a particular var:
2339              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2340              * s m strend rx once */
2341             PUSHSUBST(cx);
2342             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2343         }
2344         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2345         do {
2346             if (iters++ > maxiters)
2347                 DIE(aTHX_ "Substitution loop");
2348             if (RX_MATCH_TAINTED(rx))
2349                 rxtainted |= SUBST_TAINT_PAT;
2350             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2351                 m = s;
2352                 s = orig;
2353                 assert(RX_SUBOFFSET(rx) == 0);
2354                 orig = RX_SUBBEG(rx);
2355                 s = orig + (m - s);
2356                 strend = s + (strend - m);
2357             }
2358             m = RX_OFFS(rx)[0].start + orig;
2359             if (doutf8 && !SvUTF8(dstr))
2360                 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
2361             else
2362                 sv_catpvn_nomg(dstr, s, m-s);
2363             s = RX_OFFS(rx)[0].end + orig;
2364             if (clen)
2365                 sv_catpvn_nomg(dstr, c, clen);
2366             if (once)
2367                 break;
2368         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2369                              TARG, NULL, r_flags));
2370         if (doutf8 && !DO_UTF8(TARG))
2371             sv_catpvn_nomg_utf8_upgrade(dstr, s, strend - s, nsv);
2372         else
2373             sv_catpvn_nomg(dstr, s, strend - s);
2374
2375         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2376             /* From here on down we're using the copy, and leaving the original
2377                untouched.  */
2378             TARG = dstr;
2379             SPAGAIN;
2380             PUSHs(dstr);
2381         } else {
2382 #ifdef PERL_OLD_COPY_ON_WRITE
2383             /* The match may make the string COW. If so, brilliant, because
2384                that's just saved us one malloc, copy and free - the regexp has
2385                donated the old buffer, and we malloc an entirely new one, rather
2386                than the regexp malloc()ing a buffer and copying our original,
2387                only for us to throw it away here during the substitution.  */
2388             if (SvIsCOW(TARG)) {
2389                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2390             } else
2391 #endif
2392             {
2393                 SvPV_free(TARG);
2394             }
2395             SvPV_set(TARG, SvPVX(dstr));
2396             SvCUR_set(TARG, SvCUR(dstr));
2397             SvLEN_set(TARG, SvLEN(dstr));
2398             doutf8 |= DO_UTF8(dstr);
2399             SvPV_set(dstr, NULL);
2400
2401             SPAGAIN;
2402             mPUSHi((I32)iters);
2403         }
2404     }
2405
2406     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2407         (void)SvPOK_only_UTF8(TARG);
2408         if (doutf8)
2409             SvUTF8_on(TARG);
2410     }
2411
2412     /* See "how taint works" above */
2413     if (PL_tainting) {
2414         if ((rxtainted & SUBST_TAINT_PAT) ||
2415             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2416                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2417         )
2418             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2419
2420         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2421             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2422         )
2423             SvTAINTED_on(TOPs);  /* taint return value */
2424         else
2425             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2426
2427         /* needed for mg_set below */
2428         PL_tainted =
2429           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2430         SvTAINT(TARG);
2431     }
2432     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2433     TAINT_NOT;
2434     LEAVE_SCOPE(oldsave);
2435     RETURN;
2436 }
2437
2438 PP(pp_grepwhile)
2439 {
2440     dVAR; dSP;
2441
2442     if (SvTRUEx(POPs))
2443         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2444     ++*PL_markstack_ptr;
2445     FREETMPS;
2446     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2447
2448     /* All done yet? */
2449     if (PL_stack_base + *PL_markstack_ptr > SP) {
2450         I32 items;
2451         const I32 gimme = GIMME_V;
2452
2453         LEAVE_with_name("grep");                                        /* exit outer scope */
2454         (void)POPMARK;                          /* pop src */
2455         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2456         (void)POPMARK;                          /* pop dst */
2457         SP = PL_stack_base + POPMARK;           /* pop original mark */
2458         if (gimme == G_SCALAR) {
2459             if (PL_op->op_private & OPpGREP_LEX) {
2460                 SV* const sv = sv_newmortal();
2461                 sv_setiv(sv, items);
2462                 PUSHs(sv);
2463             }
2464             else {
2465                 dTARGET;
2466                 XPUSHi(items);
2467             }
2468         }
2469         else if (gimme == G_ARRAY)
2470             SP += items;
2471         RETURN;
2472     }
2473     else {
2474         SV *src;
2475
2476         ENTER_with_name("grep_item");                                   /* enter inner scope */
2477         SAVEVPTR(PL_curpm);
2478
2479         src = PL_stack_base[*PL_markstack_ptr];
2480         SvTEMP_off(src);
2481         if (PL_op->op_private & OPpGREP_LEX)
2482             PAD_SVl(PL_op->op_targ) = src;
2483         else
2484             DEFSV_set(src);
2485
2486         RETURNOP(cLOGOP->op_other);
2487     }
2488 }
2489
2490 PP(pp_leavesub)
2491 {
2492     dVAR; dSP;
2493     SV **mark;
2494     SV **newsp;
2495     PMOP *newpm;
2496     I32 gimme;
2497     PERL_CONTEXT *cx;
2498     SV *sv;
2499
2500     if (CxMULTICALL(&cxstack[cxstack_ix]))
2501         return 0;
2502
2503     POPBLOCK(cx,newpm);
2504     cxstack_ix++; /* temporarily protect top context */
2505
2506     TAINT_NOT;
2507     if (gimme == G_SCALAR) {
2508         MARK = newsp + 1;
2509         if (MARK <= SP) {
2510             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2511                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2512                      && !SvMAGICAL(TOPs)) {
2513                     *MARK = SvREFCNT_inc(TOPs);
2514                     FREETMPS;
2515                     sv_2mortal(*MARK);
2516                 }
2517                 else {
2518                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2519                     FREETMPS;
2520                     *MARK = sv_mortalcopy(sv);
2521                     SvREFCNT_dec(sv);
2522                 }
2523             }
2524             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2525                      && !SvMAGICAL(TOPs)) {
2526                 *MARK = TOPs;
2527             }
2528             else
2529                 *MARK = sv_mortalcopy(TOPs);
2530         }
2531         else {
2532             MEXTEND(MARK, 0);
2533             *MARK = &PL_sv_undef;
2534         }
2535         SP = MARK;
2536     }
2537     else if (gimme == G_ARRAY) {
2538         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2539             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2540                  || SvMAGICAL(*MARK)) {
2541                 *MARK = sv_mortalcopy(*MARK);
2542                 TAINT_NOT;      /* Each item is independent */
2543             }
2544         }
2545     }
2546     PUTBACK;
2547
2548     LEAVE;
2549     cxstack_ix--;
2550     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2551     PL_curpm = newpm;   /* ... and pop $1 et al */
2552
2553     LEAVESUB(sv);
2554     return cx->blk_sub.retop;
2555 }
2556
2557 PP(pp_entersub)
2558 {
2559     dVAR; dSP; dPOPss;
2560     GV *gv;
2561     CV *cv;
2562     PERL_CONTEXT *cx;
2563     I32 gimme;
2564     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2565
2566     if (!sv)
2567         DIE(aTHX_ "Not a CODE reference");
2568     switch (SvTYPE(sv)) {
2569         /* This is overwhelming the most common case:  */
2570     case SVt_PVGV:
2571       we_have_a_glob:
2572         if (!(cv = GvCVu((const GV *)sv))) {
2573             HV *stash;
2574             cv = sv_2cv(sv, &stash, &gv, 0);
2575         }
2576         if (!cv) {
2577             ENTER;
2578             SAVETMPS;
2579             goto try_autoload;
2580         }
2581         break;
2582     case SVt_PVLV:
2583         if(isGV_with_GP(sv)) goto we_have_a_glob;
2584         /*FALLTHROUGH*/
2585     default:
2586         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2587             if (hasargs)
2588                 SP = PL_stack_base + POPMARK;
2589             else
2590                 (void)POPMARK;
2591             RETURN;
2592         }
2593         SvGETMAGIC(sv);
2594         if (SvROK(sv)) {
2595             if (SvAMAGIC(sv)) {
2596                 sv = amagic_deref_call(sv, to_cv_amg);
2597                 /* Don't SPAGAIN here.  */
2598             }
2599         }
2600         else {
2601             const char *sym;
2602             STRLEN len;
2603             if (!SvOK(sv))
2604                 DIE(aTHX_ PL_no_usym, "a subroutine");
2605             sym = SvPV_nomg_const(sv, len);
2606             if (PL_op->op_private & HINT_STRICT_REFS)
2607                 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2608             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2609             break;
2610         }
2611         cv = MUTABLE_CV(SvRV(sv));
2612         if (SvTYPE(cv) == SVt_PVCV)
2613             break;
2614         /* FALL THROUGH */
2615     case SVt_PVHV:
2616     case SVt_PVAV:
2617         DIE(aTHX_ "Not a CODE reference");
2618         /* This is the second most common case:  */
2619     case SVt_PVCV:
2620         cv = MUTABLE_CV(sv);
2621         break;
2622     }
2623
2624     ENTER;
2625     SAVETMPS;
2626
2627   retry:
2628     if (CvCLONE(cv) && ! CvCLONED(cv))
2629         DIE(aTHX_ "Closure prototype called");
2630     if (!CvROOT(cv) && !CvXSUB(cv)) {
2631         GV* autogv;
2632         SV* sub_name;
2633
2634         /* anonymous or undef'd function leaves us no recourse */
2635         if (CvANON(cv) || !(gv = CvGV(cv)))
2636             DIE(aTHX_ "Undefined subroutine called");
2637
2638         /* autoloaded stub? */
2639         if (cv != GvCV(gv)) {
2640             cv = GvCV(gv);
2641         }
2642         /* should call AUTOLOAD now? */
2643         else {
2644 try_autoload:
2645             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2646                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2647             {
2648                 cv = GvCV(autogv);
2649             }
2650             else {
2651                sorry:
2652                 sub_name = sv_newmortal();
2653                 gv_efullname3(sub_name, gv, NULL);
2654                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2655             }
2656         }
2657         if (!cv)
2658             goto sorry;
2659         goto retry;
2660     }
2661
2662     gimme = GIMME_V;
2663     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2664          Perl_get_db_sub(aTHX_ &sv, cv);
2665          if (CvISXSUB(cv))
2666              PL_curcopdb = PL_curcop;
2667          if (CvLVALUE(cv)) {
2668              /* check for lsub that handles lvalue subroutines */
2669              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2670              /* if lsub not found then fall back to DB::sub */
2671              if (!cv) cv = GvCV(PL_DBsub);
2672          } else {
2673              cv = GvCV(PL_DBsub);
2674          }
2675
2676         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2677             DIE(aTHX_ "No DB::sub routine defined");
2678     }
2679
2680     if (!(CvISXSUB(cv))) {
2681         /* This path taken at least 75% of the time   */
2682         dMARK;
2683         I32 items = SP - MARK;
2684         PADLIST * const padlist = CvPADLIST(cv);
2685         PUSHBLOCK(cx, CXt_SUB, MARK);
2686         PUSHSUB(cx);
2687         cx->blk_sub.retop = PL_op->op_next;
2688         CvDEPTH(cv)++;
2689         if (CvDEPTH(cv) >= 2) {
2690             PERL_STACK_OVERFLOW_CHECK();
2691             pad_push(padlist, CvDEPTH(cv));
2692         }
2693         SAVECOMPPAD();
2694         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2695         if (hasargs) {
2696             AV *const av = MUTABLE_AV(PAD_SVl(0));
2697             if (AvREAL(av)) {
2698                 /* @_ is normally not REAL--this should only ever
2699                  * happen when DB::sub() calls things that modify @_ */
2700                 av_clear(av);
2701                 AvREAL_off(av);
2702                 AvREIFY_on(av);
2703             }
2704             cx->blk_sub.savearray = GvAV(PL_defgv);
2705             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2706             CX_CURPAD_SAVE(cx->blk_sub);
2707             cx->blk_sub.argarray = av;
2708             ++MARK;
2709
2710             if (items > AvMAX(av) + 1) {
2711                 SV **ary = AvALLOC(av);
2712                 if (AvARRAY(av) != ary) {
2713                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2714                     AvARRAY(av) = ary;
2715                 }
2716                 if (items > AvMAX(av) + 1) {
2717                     AvMAX(av) = items - 1;
2718                     Renew(ary,items,SV*);
2719                     AvALLOC(av) = ary;
2720                     AvARRAY(av) = ary;
2721                 }
2722             }
2723             Copy(MARK,AvARRAY(av),items,SV*);
2724             AvFILLp(av) = items - 1;
2725         
2726             while (items--) {
2727                 if (*MARK)
2728                     SvTEMP_off(*MARK);
2729                 MARK++;
2730             }
2731         }
2732         if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2733             !CvLVALUE(cv))
2734             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2735         /* warning must come *after* we fully set up the context
2736          * stuff so that __WARN__ handlers can safely dounwind()
2737          * if they want to
2738          */
2739         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2740             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2741             sub_crush_depth(cv);
2742         RETURNOP(CvSTART(cv));
2743     }
2744     else {
2745         I32 markix = TOPMARK;
2746
2747         PUTBACK;
2748
2749         if (!hasargs) {
2750             /* Need to copy @_ to stack. Alternative may be to
2751              * switch stack to @_, and copy return values
2752              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2753             AV * const av = GvAV(PL_defgv);
2754             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2755
2756             if (items) {
2757                 /* Mark is at the end of the stack. */
2758                 EXTEND(SP, items);
2759                 Copy(AvARRAY(av), SP + 1, items, SV*);
2760                 SP += items;
2761                 PUTBACK ;               
2762             }
2763         }
2764         /* We assume first XSUB in &DB::sub is the called one. */
2765         if (PL_curcopdb) {
2766             SAVEVPTR(PL_curcop);
2767             PL_curcop = PL_curcopdb;
2768             PL_curcopdb = NULL;
2769         }
2770         /* Do we need to open block here? XXXX */
2771
2772         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2773         assert(CvXSUB(cv));
2774         CvXSUB(cv)(aTHX_ cv);
2775
2776         /* Enforce some sanity in scalar context. */
2777         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2778             if (markix > PL_stack_sp - PL_stack_base)
2779                 *(PL_stack_base + markix) = &PL_sv_undef;
2780             else
2781                 *(PL_stack_base + markix) = *PL_stack_sp;
2782             PL_stack_sp = PL_stack_base + markix;
2783         }
2784         LEAVE;
2785         return NORMAL;
2786     }
2787 }
2788
2789 void
2790 Perl_sub_crush_depth(pTHX_ CV *cv)
2791 {
2792     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2793
2794     if (CvANON(cv))
2795         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2796     else {
2797         SV* const tmpstr = sv_newmortal();
2798         gv_efullname3(tmpstr, CvGV(cv), NULL);
2799         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2800                     SVfARG(tmpstr));
2801     }
2802 }
2803
2804 PP(pp_aelem)
2805 {
2806     dVAR; dSP;
2807     SV** svp;
2808     SV* const elemsv = POPs;
2809     IV elem = SvIV(elemsv);
2810     AV *const av = MUTABLE_AV(POPs);
2811     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2812     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2813     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2814     bool preeminent = TRUE;
2815     SV *sv;
2816
2817     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2818         Perl_warner(aTHX_ packWARN(WARN_MISC),
2819                     "Use of reference \"%"SVf"\" as array index",
2820                     SVfARG(elemsv));
2821     if (SvTYPE(av) != SVt_PVAV)
2822         RETPUSHUNDEF;
2823
2824     if (localizing) {
2825         MAGIC *mg;
2826         HV *stash;
2827
2828         /* If we can determine whether the element exist,
2829          * Try to preserve the existenceness of a tied array
2830          * element by using EXISTS and DELETE if possible.
2831          * Fallback to FETCH and STORE otherwise. */
2832         if (SvCANEXISTDELETE(av))
2833             preeminent = av_exists(av, elem);
2834     }
2835
2836     svp = av_fetch(av, elem, lval && !defer);
2837     if (lval) {
2838 #ifdef PERL_MALLOC_WRAP
2839          if (SvUOK(elemsv)) {
2840               const UV uv = SvUV(elemsv);
2841               elem = uv > IV_MAX ? IV_MAX : uv;
2842          }
2843          else if (SvNOK(elemsv))
2844               elem = (IV)SvNV(elemsv);
2845          if (elem > 0) {
2846               static const char oom_array_extend[] =
2847                 "Out of memory during array extend"; /* Duplicated in av.c */
2848               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2849          }
2850 #endif
2851         if (!svp || *svp == &PL_sv_undef) {
2852             SV* lv;
2853             if (!defer)
2854                 DIE(aTHX_ PL_no_aelem, elem);
2855             lv = sv_newmortal();
2856             sv_upgrade(lv, SVt_PVLV);
2857             LvTYPE(lv) = 'y';
2858             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2859             LvTARG(lv) = SvREFCNT_inc_simple(av);
2860             LvTARGOFF(lv) = elem;
2861             LvTARGLEN(lv) = 1;
2862             PUSHs(lv);
2863             RETURN;
2864         }
2865         if (localizing) {
2866             if (preeminent)
2867                 save_aelem(av, elem, svp);
2868             else
2869                 SAVEADELETE(av, elem);
2870         }
2871         else if (PL_op->op_private & OPpDEREF) {
2872             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2873             RETURN;
2874         }
2875     }
2876     sv = (svp ? *svp : &PL_sv_undef);
2877     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2878         mg_get(sv);
2879     PUSHs(sv);
2880     RETURN;
2881 }
2882
2883 SV*
2884 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2885 {
2886     PERL_ARGS_ASSERT_VIVIFY_REF;
2887
2888     SvGETMAGIC(sv);
2889     if (!SvOK(sv)) {
2890         if (SvREADONLY(sv))
2891             Perl_croak_no_modify(aTHX);
2892         prepare_SV_for_RV(sv);
2893         switch (to_what) {
2894         case OPpDEREF_SV:
2895             SvRV_set(sv, newSV(0));
2896             break;
2897         case OPpDEREF_AV:
2898             SvRV_set(sv, MUTABLE_SV(newAV()));
2899             break;
2900         case OPpDEREF_HV:
2901             SvRV_set(sv, MUTABLE_SV(newHV()));
2902             break;
2903         }
2904         SvROK_on(sv);
2905         SvSETMAGIC(sv);
2906         SvGETMAGIC(sv);
2907     }
2908     if (SvGMAGICAL(sv)) {
2909         /* copy the sv without magic to prevent magic from being
2910            executed twice */
2911         SV* msv = sv_newmortal();
2912         sv_setsv_nomg(msv, sv);
2913         return msv;
2914     }
2915     return sv;
2916 }
2917
2918 PP(pp_method)
2919 {
2920     dVAR; dSP;
2921     SV* const sv = TOPs;
2922
2923     if (SvROK(sv)) {
2924         SV* const rsv = SvRV(sv);
2925         if (SvTYPE(rsv) == SVt_PVCV) {
2926             SETs(rsv);
2927             RETURN;
2928         }
2929     }
2930
2931     SETs(method_common(sv, NULL));
2932     RETURN;
2933 }
2934
2935 PP(pp_method_named)
2936 {
2937     dVAR; dSP;
2938     SV* const sv = cSVOP_sv;
2939     U32 hash = SvSHARED_HASH(sv);
2940
2941     XPUSHs(method_common(sv, &hash));
2942     RETURN;
2943 }
2944
2945 STATIC SV *
2946 S_method_common(pTHX_ SV* meth, U32* hashp)
2947 {
2948     dVAR;
2949     SV* ob;
2950     GV* gv;
2951     HV* stash;
2952     SV *packsv = NULL;
2953     SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2954         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2955                             "package or object reference", SVfARG(meth)),
2956            (SV *)NULL)
2957         : *(PL_stack_base + TOPMARK + 1);
2958
2959     PERL_ARGS_ASSERT_METHOD_COMMON;
2960
2961     if (!sv)
2962         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2963                    SVfARG(meth));
2964
2965     SvGETMAGIC(sv);
2966     if (SvROK(sv))
2967         ob = MUTABLE_SV(SvRV(sv));
2968     else {
2969         GV* iogv;
2970         STRLEN packlen;
2971         const char * packname = NULL;
2972         bool packname_is_utf8 = FALSE;
2973
2974         /* this isn't a reference */
2975         if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2976           const HE* const he =
2977             (const HE *)hv_common_key_len(
2978               PL_stashcache, packname,
2979               packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2980             );
2981           
2982           if (he) { 
2983             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2984             goto fetch;
2985           }
2986         }
2987
2988         if (!SvOK(sv) ||
2989             !(packname) ||
2990             !(iogv = gv_fetchpvn_flags(
2991                 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2992              )) ||
2993             !(ob=MUTABLE_SV(GvIO(iogv))))
2994         {
2995             /* this isn't the name of a filehandle either */
2996             if (!packname ||
2997                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2998                     ? !isIDFIRST_utf8((U8*)packname)
2999                     : !isIDFIRST_L1((U8)*packname)
3000                 ))
3001             {
3002                 /* diag_listed_as: Can't call method "%s" without a package or object reference */
3003                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3004                            SVfARG(meth),
3005                            SvOK(sv) ? "without a package or object reference"
3006                                     : "on an undefined value");
3007             }
3008             /* assume it's a package name */
3009             stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3010             if (!stash)
3011                 packsv = sv;
3012             else {
3013                 SV* const ref = newSViv(PTR2IV(stash));
3014                 (void)hv_store(PL_stashcache, packname,
3015                                 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3016             }
3017             goto fetch;
3018         }
3019         /* it _is_ a filehandle name -- replace with a reference */
3020         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3021     }
3022
3023     /* if we got here, ob should be a reference or a glob */
3024     if (!ob || !(SvOBJECT(ob)
3025                  || (SvTYPE(ob) == SVt_PVGV 
3026                      && isGV_with_GP(ob)
3027                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3028                      && SvOBJECT(ob))))
3029     {
3030         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3031                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3032                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3033                                         : meth));
3034     }
3035
3036     stash = SvSTASH(ob);
3037
3038   fetch:
3039     /* NOTE: stash may be null, hope hv_fetch_ent and
3040        gv_fetchmethod can cope (it seems they can) */
3041
3042     /* shortcut for simple names */
3043     if (hashp) {
3044         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3045         if (he) {
3046             gv = MUTABLE_GV(HeVAL(he));
3047             if (isGV(gv) && GvCV(gv) &&
3048                 (!GvCVGEN(gv) || GvCVGEN(gv)
3049                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3050                 return MUTABLE_SV(GvCV(gv));
3051         }
3052     }
3053
3054     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3055                                      meth, GV_AUTOLOAD | GV_CROAK);
3056
3057     assert(gv);
3058
3059     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3060 }
3061
3062 /*
3063  * Local variables:
3064  * c-indentation-style: bsd
3065  * c-basic-offset: 4
3066  * indent-tabs-mode: nil
3067  * End:
3068  *
3069  * ex: set ts=8 sts=4 sw=4 et:
3070  */