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