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