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