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