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