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