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