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