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