[perl #124153] Fix require(v5.6)
[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, pp_grepstart and
80    amagic_call. */
81 PP(pp_pushmark)
82 {
83     PUSHMARK(PL_stack_sp);
84     return NORMAL;
85 }
86
87 PP(pp_stringify)
88 {
89     dSP; dTARGET;
90     SV * const sv = TOPs;
91     SETs(TARG);
92     sv_copypv(TARG, sv);
93     SvSETMAGIC(TARG);
94     /* no PUTBACK, SETs doesn't inc/dec SP */
95     return NORMAL;
96 }
97
98 PP(pp_gv)
99 {
100     dSP;
101     XPUSHs(MUTABLE_SV(cGVOP_gv));
102     if (isGV(cGVOP_gv)
103      && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
104         PL_sawalias = TRUE;
105     RETURN;
106 }
107
108
109 /* also used for: pp_andassign() */
110
111 PP(pp_and)
112 {
113     PERL_ASYNC_CHECK();
114     {
115         /* SP is not used to remove a variable that is saved across the
116           sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
117           register or load/store vs direct mem ops macro is introduced, this
118           should be a define block between direct PL_stack_sp and dSP operations,
119           presently, using PL_stack_sp is bias towards CISC cpus */
120         SV * const sv = *PL_stack_sp;
121         if (!SvTRUE_NN(sv))
122             return NORMAL;
123         else {
124             if (PL_op->op_type == OP_AND)
125                 --PL_stack_sp;
126             return cLOGOP->op_other;
127         }
128     }
129 }
130
131 PP(pp_sassign)
132 {
133     dSP;
134     /* sassign keeps its args in the optree traditionally backwards.
135        So we pop them differently.
136     */
137     SV *left = POPs; SV *right = TOPs;
138
139     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
140         SV * const temp = left;
141         left = right; right = temp;
142     }
143     if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
144         TAINT_NOT;
145     if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
146         /* *foo =\&bar */
147         SV * const cv = SvRV(right);
148         const U32 cv_type = SvTYPE(cv);
149         const bool is_gv = isGV_with_GP(left);
150         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
151
152         if (!got_coderef) {
153             assert(SvROK(cv));
154         }
155
156         /* Can do the optimisation if left (LVALUE) is not a typeglob,
157            right (RVALUE) is a reference to something, and we're in void
158            context. */
159         if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
160             /* Is the target symbol table currently empty?  */
161             GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
162             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
163                 /* Good. Create a new proxy constant subroutine in the target.
164                    The gv becomes a(nother) reference to the constant.  */
165                 SV *const value = SvRV(cv);
166
167                 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
168                 SvPCS_IMPORTED_on(gv);
169                 SvRV_set(gv, value);
170                 SvREFCNT_inc_simple_void(value);
171                 SETs(left);
172                 RETURN;
173             }
174         }
175
176         /* Need to fix things up.  */
177         if (!is_gv) {
178             /* Need to fix GV.  */
179             left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
180         }
181
182         if (!got_coderef) {
183             /* We've been returned a constant rather than a full subroutine,
184                but they expect a subroutine reference to apply.  */
185             if (SvROK(cv)) {
186                 ENTER_with_name("sassign_coderef");
187                 SvREFCNT_inc_void(SvRV(cv));
188                 /* newCONSTSUB takes a reference count on the passed in SV
189                    from us.  We set the name to NULL, otherwise we get into
190                    all sorts of fun as the reference to our new sub is
191                    donated to the GV that we're about to assign to.
192                 */
193                 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
194                                                       SvRV(cv))));
195                 SvREFCNT_dec_NN(cv);
196                 LEAVE_with_name("sassign_coderef");
197             } else {
198                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
199                    is that
200                    First:   ops for \&{"BONK"}; return us the constant in the
201                             symbol table
202                    Second:  ops for *{"BONK"} cause that symbol table entry
203                             (and our reference to it) to be upgraded from RV
204                             to typeblob)
205                    Thirdly: We get here. cv is actually PVGV now, and its
206                             GvCV() is actually the subroutine we're looking for
207
208                    So change the reference so that it points to the subroutine
209                    of that typeglob, as that's what they were after all along.
210                 */
211                 GV *const upgraded = MUTABLE_GV(cv);
212                 CV *const source = GvCV(upgraded);
213
214                 assert(source);
215                 assert(CvFLAGS(source) & CVf_CONST);
216
217                 SvREFCNT_inc_void(source);
218                 SvREFCNT_dec_NN(upgraded);
219                 SvRV_set(right, MUTABLE_SV(source));
220             }
221         }
222
223     }
224     if (
225       UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
226       (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
227     )
228         Perl_warner(aTHX_
229             packWARN(WARN_MISC), "Useless assignment to a temporary"
230         );
231     SvSetMagicSV(left, right);
232     SETs(left);
233     RETURN;
234 }
235
236 PP(pp_cond_expr)
237 {
238     dSP;
239     PERL_ASYNC_CHECK();
240     if (SvTRUEx(POPs))
241         RETURNOP(cLOGOP->op_other);
242     else
243         RETURNOP(cLOGOP->op_next);
244 }
245
246 PP(pp_unstack)
247 {
248     PERL_ASYNC_CHECK();
249     TAINT_NOT;          /* Each statement is presumed innocent */
250     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
251     FREETMPS;
252     if (!(PL_op->op_flags & OPf_SPECIAL)) {
253         I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
254         LEAVE_SCOPE(oldsave);
255     }
256     return NORMAL;
257 }
258
259 PP(pp_concat)
260 {
261   dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
262   {
263     dPOPTOPssrl;
264     bool lbyte;
265     STRLEN rlen;
266     const char *rpv = NULL;
267     bool rbyte = FALSE;
268     bool rcopied = FALSE;
269
270     if (TARG == right && right != left) { /* $r = $l.$r */
271         rpv = SvPV_nomg_const(right, rlen);
272         rbyte = !DO_UTF8(right);
273         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
274         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
275         rcopied = TRUE;
276     }
277
278     if (TARG != left) { /* not $l .= $r */
279         STRLEN llen;
280         const char* const lpv = SvPV_nomg_const(left, llen);
281         lbyte = !DO_UTF8(left);
282         sv_setpvn(TARG, lpv, llen);
283         if (!lbyte)
284             SvUTF8_on(TARG);
285         else
286             SvUTF8_off(TARG);
287     }
288     else { /* $l .= $r   and   left == TARG */
289         if (!SvOK(left)) {
290             if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
291                 report_uninit(right);
292             sv_setpvs(left, "");
293         }
294         else {
295             SvPV_force_nomg_nolen(left);
296         }
297         lbyte = !DO_UTF8(left);
298         if (IN_BYTES)
299             SvUTF8_off(left);
300     }
301
302     if (!rcopied) {
303         rpv = SvPV_nomg_const(right, rlen);
304         rbyte = !DO_UTF8(right);
305     }
306     if (lbyte != rbyte) {
307         if (lbyte)
308             sv_utf8_upgrade_nomg(TARG);
309         else {
310             if (!rcopied)
311                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
312             sv_utf8_upgrade_nomg(right);
313             rpv = SvPV_nomg_const(right, rlen);
314         }
315     }
316     sv_catpvn_nomg(TARG, rpv, rlen);
317
318     SETTARG;
319     RETURN;
320   }
321 }
322
323 /* push the elements of av onto the stack.
324  * XXX Note that padav has similar code but without the mg_get().
325  * I suspect that the mg_get is no longer needed, but while padav
326  * differs, it can't share this function */
327
328 STATIC void
329 S_pushav(pTHX_ AV* const av)
330 {
331     dSP;
332     const SSize_t maxarg = AvFILL(av) + 1;
333     EXTEND(SP, maxarg);
334     if (UNLIKELY(SvRMAGICAL(av))) {
335         PADOFFSET i;
336         for (i=0; i < (PADOFFSET)maxarg; i++) {
337             SV ** const svp = av_fetch(av, i, FALSE);
338             /* See note in pp_helem, and bug id #27839 */
339             SP[i+1] = svp
340                 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
341                 : &PL_sv_undef;
342         }
343     }
344     else {
345         PADOFFSET i;
346         for (i=0; i < (PADOFFSET)maxarg; i++) {
347             SV * const sv = AvARRAY(av)[i];
348             SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
349         }
350     }
351     SP += maxarg;
352     PUTBACK;
353 }
354
355
356 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
357
358 PP(pp_padrange)
359 {
360     dSP;
361     PADOFFSET base = PL_op->op_targ;
362     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
363     int i;
364     if (PL_op->op_flags & OPf_SPECIAL) {
365         /* fake the RHS of my ($x,$y,..) = @_ */
366         PUSHMARK(SP);
367         S_pushav(aTHX_ GvAVn(PL_defgv));
368         SPAGAIN;
369     }
370
371     /* note, this is only skipped for compile-time-known void cxt */
372     if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
373         EXTEND(SP, count);
374         PUSHMARK(SP);
375         for (i = 0; i <count; i++)
376             *++SP = PAD_SV(base+i);
377     }
378     if (PL_op->op_private & OPpLVAL_INTRO) {
379         SV **svp = &(PAD_SVl(base));
380         const UV payload = (UV)(
381                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
382                     | (count << SAVE_TIGHT_SHIFT)
383                     | SAVEt_CLEARPADRANGE);
384         STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
385         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
386         {
387             dSS_ADD;
388             SS_ADD_UV(payload);
389             SS_ADD_END(1);
390         }
391
392         for (i = 0; i <count; i++)
393             SvPADSTALE_off(*svp++); /* mark lexical as active */
394     }
395     RETURN;
396 }
397
398
399 PP(pp_padsv)
400 {
401     dSP;
402     EXTEND(SP, 1);
403     {
404         OP * const op = PL_op;
405         /* access PL_curpad once */
406         SV ** const padentry = &(PAD_SVl(op->op_targ));
407         {
408             dTARG;
409             TARG = *padentry;
410             PUSHs(TARG);
411             PUTBACK; /* no pop/push after this, TOPs ok */
412         }
413         if (op->op_flags & OPf_MOD) {
414             if (op->op_private & OPpLVAL_INTRO)
415                 if (!(op->op_private & OPpPAD_STATE))
416                     save_clearsv(padentry);
417             if (op->op_private & OPpDEREF) {
418                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
419                    than TARG reduces the scope of TARG, so it does not
420                    span the call to save_clearsv, resulting in smaller
421                    machine code. */
422                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
423             }
424         }
425         return op->op_next;
426     }
427 }
428
429 PP(pp_readline)
430 {
431     dSP;
432     if (TOPs) {
433         SvGETMAGIC(TOPs);
434         tryAMAGICunTARGETlist(iter_amg, 0);
435         PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
436     }
437     else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
438     if (!isGV_with_GP(PL_last_in_gv)) {
439         if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
440             PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
441         else {
442             dSP;
443             XPUSHs(MUTABLE_SV(PL_last_in_gv));
444             PUTBACK;
445             Perl_pp_rv2gv(aTHX);
446             PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
447             if (PL_last_in_gv == (GV *)&PL_sv_undef)
448                 PL_last_in_gv = NULL;
449             else
450                 assert(isGV_with_GP(PL_last_in_gv));
451         }
452     }
453     return do_readline();
454 }
455
456 PP(pp_eq)
457 {
458     dSP;
459     SV *left, *right;
460
461     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
462     right = POPs;
463     left  = TOPs;
464     SETs(boolSV(
465         (SvIOK_notUV(left) && SvIOK_notUV(right))
466         ? (SvIVX(left) == SvIVX(right))
467         : ( do_ncmp(left, right) == 0)
468     ));
469     RETURN;
470 }
471
472
473 /* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
474
475 PP(pp_preinc)
476 {
477     dSP;
478     const bool inc =
479         PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
480     if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
481         Perl_croak_no_modify();
482     if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
483         && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
484     {
485         SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
486         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
487     }
488     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
489         if (inc) sv_inc(TOPs);
490         else sv_dec(TOPs);
491     SvSETMAGIC(TOPs);
492     return NORMAL;
493 }
494
495
496 /* also used for: pp_orassign() */
497
498 PP(pp_or)
499 {
500     dSP;
501     PERL_ASYNC_CHECK();
502     if (SvTRUE(TOPs))
503         RETURN;
504     else {
505         if (PL_op->op_type == OP_OR)
506             --SP;
507         RETURNOP(cLOGOP->op_other);
508     }
509 }
510
511
512 /* also used for: pp_dor() pp_dorassign() */
513
514 PP(pp_defined)
515 {
516     dSP;
517     SV* sv;
518     bool defined;
519     const int op_type = PL_op->op_type;
520     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
521
522     if (is_dor) {
523         PERL_ASYNC_CHECK();
524         sv = TOPs;
525         if (UNLIKELY(!sv || !SvANY(sv))) {
526             if (op_type == OP_DOR)
527                 --SP;
528             RETURNOP(cLOGOP->op_other);
529         }
530     }
531     else {
532         /* OP_DEFINED */
533         sv = POPs;
534         if (UNLIKELY(!sv || !SvANY(sv)))
535             RETPUSHNO;
536     }
537
538     defined = FALSE;
539     switch (SvTYPE(sv)) {
540     case SVt_PVAV:
541         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
542             defined = TRUE;
543         break;
544     case SVt_PVHV:
545         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
546             defined = TRUE;
547         break;
548     case SVt_PVCV:
549         if (CvROOT(sv) || CvXSUB(sv))
550             defined = TRUE;
551         break;
552     default:
553         SvGETMAGIC(sv);
554         if (SvOK(sv))
555             defined = TRUE;
556         break;
557     }
558
559     if (is_dor) {
560         if(defined) 
561             RETURN; 
562         if(op_type == OP_DOR)
563             --SP;
564         RETURNOP(cLOGOP->op_other);
565     }
566     /* assuming OP_DEFINED */
567     if(defined) 
568         RETPUSHYES;
569     RETPUSHNO;
570 }
571
572 PP(pp_add)
573 {
574     dSP; dATARGET; bool useleft; SV *svl, *svr;
575     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
576     svr = TOPs;
577     svl = TOPm1s;
578
579     useleft = USE_LEFT(svl);
580 #ifdef PERL_PRESERVE_IVUV
581     /* We must see if we can perform the addition with integers if possible,
582        as the integer code detects overflow while the NV code doesn't.
583        If either argument hasn't had a numeric conversion yet attempt to get
584        the IV. It's important to do this now, rather than just assuming that
585        it's not IOK as a PV of "9223372036854775806" may not take well to NV
586        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
587        integer in case the second argument is IV=9223372036854775806
588        We can (now) rely on sv_2iv to do the right thing, only setting the
589        public IOK flag if the value in the NV (or PV) slot is truly integer.
590
591        A side effect is that this also aggressively prefers integer maths over
592        fp maths for integer values.
593
594        How to detect overflow?
595
596        C 99 section 6.2.6.1 says
597
598        The range of nonnegative values of a signed integer type is a subrange
599        of the corresponding unsigned integer type, and the representation of
600        the same value in each type is the same. A computation involving
601        unsigned operands can never overflow, because a result that cannot be
602        represented by the resulting unsigned integer type is reduced modulo
603        the number that is one greater than the largest value that can be
604        represented by the resulting type.
605
606        (the 9th paragraph)
607
608        which I read as "unsigned ints wrap."
609
610        signed integer overflow seems to be classed as "exception condition"
611
612        If an exceptional condition occurs during the evaluation of an
613        expression (that is, if the result is not mathematically defined or not
614        in the range of representable values for its type), the behavior is
615        undefined.
616
617        (6.5, the 5th paragraph)
618
619        I had assumed that on 2s complement machines signed arithmetic would
620        wrap, hence coded pp_add and pp_subtract on the assumption that
621        everything perl builds on would be happy.  After much wailing and
622        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
623        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
624        unsigned code below is actually shorter than the old code. :-)
625     */
626
627     if (SvIV_please_nomg(svr)) {
628         /* Unless the left argument is integer in range we are going to have to
629            use NV maths. Hence only attempt to coerce the right argument if
630            we know the left is integer.  */
631         UV auv = 0;
632         bool auvok = FALSE;
633         bool a_valid = 0;
634
635         if (!useleft) {
636             auv = 0;
637             a_valid = auvok = 1;
638             /* left operand is undef, treat as zero. + 0 is identity,
639                Could SETi or SETu right now, but space optimise by not adding
640                lots of code to speed up what is probably a rarish case.  */
641         } else {
642             /* Left operand is defined, so is it IV? */
643             if (SvIV_please_nomg(svl)) {
644                 if ((auvok = SvUOK(svl)))
645                     auv = SvUVX(svl);
646                 else {
647                     const IV aiv = SvIVX(svl);
648                     if (aiv >= 0) {
649                         auv = aiv;
650                         auvok = 1;      /* Now acting as a sign flag.  */
651                     } else {
652                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
653                     }
654                 }
655                 a_valid = 1;
656             }
657         }
658         if (a_valid) {
659             bool result_good = 0;
660             UV result;
661             UV buv;
662             bool buvok = SvUOK(svr);
663         
664             if (buvok)
665                 buv = SvUVX(svr);
666             else {
667                 const IV biv = SvIVX(svr);
668                 if (biv >= 0) {
669                     buv = biv;
670                     buvok = 1;
671                 } else
672                     buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
673             }
674             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
675                else "IV" now, independent of how it came in.
676                if a, b represents positive, A, B negative, a maps to -A etc
677                a + b =>  (a + b)
678                A + b => -(a - b)
679                a + B =>  (a - b)
680                A + B => -(a + b)
681                all UV maths. negate result if A negative.
682                add if signs same, subtract if signs differ. */
683
684             if (auvok ^ buvok) {
685                 /* Signs differ.  */
686                 if (auv >= buv) {
687                     result = auv - buv;
688                     /* Must get smaller */
689                     if (result <= auv)
690                         result_good = 1;
691                 } else {
692                     result = buv - auv;
693                     if (result <= buv) {
694                         /* result really should be -(auv-buv). as its negation
695                            of true value, need to swap our result flag  */
696                         auvok = !auvok;
697                         result_good = 1;
698                     }
699                 }
700             } else {
701                 /* Signs same */
702                 result = auv + buv;
703                 if (result >= auv)
704                     result_good = 1;
705             }
706             if (result_good) {
707                 SP--;
708                 if (auvok)
709                     SETu( result );
710                 else {
711                     /* Negate result */
712                     if (result <= (UV)IV_MIN)
713                         SETi(result == (UV)IV_MIN
714                                 ? IV_MIN : -(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  */
947         if (gimme == G_ARRAY) {
948             SP--;
949             PUTBACK;
950             S_pushav(aTHX_ av);
951             SPAGAIN;
952         }
953         else if (gimme == G_SCALAR) {
954             dTARGET;
955             const SSize_t maxarg = AvFILL(av) + 1;
956             SETi(maxarg);
957         }
958     } else {
959         /* The guts of pp_rv2hv  */
960         if (gimme == G_ARRAY) { /* array wanted */
961             *PL_stack_sp = sv;
962             return Perl_do_kv(aTHX);
963         }
964         else if ((PL_op->op_private & OPpTRUEBOOL
965               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
966                  && block_gimme() == G_VOID  ))
967               && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
968             SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
969         else if (gimme == G_SCALAR) {
970             dTARG;
971             TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
972             SETTARG;
973         }
974     }
975     RETURN;
976
977  croak_cant_return:
978     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
979                is_pp_rv2av ? "array" : "hash");
980     RETURN;
981 }
982
983 STATIC void
984 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
985 {
986     PERL_ARGS_ASSERT_DO_ODDBALL;
987
988     if (*oddkey) {
989         if (ckWARN(WARN_MISC)) {
990             const char *err;
991             if (oddkey == firstkey &&
992                 SvROK(*oddkey) &&
993                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
994                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
995             {
996                 err = "Reference found where even-sized list expected";
997             }
998             else
999                 err = "Odd number of elements in hash assignment";
1000             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1001         }
1002
1003     }
1004 }
1005
1006 PP(pp_aassign)
1007 {
1008     dVAR; dSP;
1009     SV **lastlelem = PL_stack_sp;
1010     SV **lastrelem = PL_stack_base + POPMARK;
1011     SV **firstrelem = PL_stack_base + POPMARK + 1;
1012     SV **firstlelem = lastrelem + 1;
1013
1014     SV **relem;
1015     SV **lelem;
1016
1017     SV *sv;
1018     AV *ary;
1019
1020     I32 gimme;
1021     HV *hash;
1022     SSize_t i;
1023     int magic;
1024     U32 lval = 0;
1025
1026     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1027     gimme = GIMME_V;
1028     if (gimme == G_ARRAY)
1029         lval = PL_op->op_flags & OPf_MOD || LVRET;
1030
1031     /* If there's a common identifier on both sides we have to take
1032      * special care that assigning the identifier on the left doesn't
1033      * clobber a value on the right that's used later in the list.
1034      * Don't bother if LHS is just an empty hash or array.
1035      */
1036
1037     if (    (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
1038         &&  (
1039                firstlelem != lastlelem
1040             || ! ((sv = *firstlelem))
1041             || SvMAGICAL(sv)
1042             || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1043             || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1044             || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1045             )
1046     ) {
1047         EXTEND_MORTAL(lastrelem - firstrelem + 1);
1048         for (relem = firstrelem; relem <= lastrelem; relem++) {
1049             if (LIKELY((sv = *relem))) {
1050                 TAINT_NOT;      /* Each item is independent */
1051
1052                 /* Dear TODO test in t/op/sort.t, I love you.
1053                    (It's relying on a panic, not a "semi-panic" from newSVsv()
1054                    and then an assertion failure below.)  */
1055                 if (UNLIKELY(SvIS_FREED(sv))) {
1056                     Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1057                                (void*)sv);
1058                 }
1059                 /* Not newSVsv(), as it does not allow copy-on-write,
1060                    resulting in wasteful copies.  We need a second copy of
1061                    a temp here, hence the SV_NOSTEAL.  */
1062                 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1063                                                |SV_NOSTEAL);
1064             }
1065         }
1066     }
1067
1068     relem = firstrelem;
1069     lelem = firstlelem;
1070     ary = NULL;
1071     hash = NULL;
1072
1073     while (LIKELY(lelem <= lastlelem)) {
1074         bool alias = FALSE;
1075         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1076         sv = *lelem++;
1077         if (UNLIKELY(!sv)) {
1078             alias = TRUE;
1079             sv = *lelem++;
1080             ASSUME(SvTYPE(sv) == SVt_PVAV);
1081         }
1082         switch (SvTYPE(sv)) {
1083         case SVt_PVAV:
1084             ary = MUTABLE_AV(sv);
1085             magic = SvMAGICAL(ary) != 0;
1086             ENTER;
1087             SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1088             av_clear(ary);
1089             av_extend(ary, lastrelem - relem);
1090             i = 0;
1091             while (relem <= lastrelem) {        /* gobble up all the rest */
1092                 SV **didstore;
1093                 if (LIKELY(*relem))
1094                     SvGETMAGIC(*relem); /* before newSV, in case it dies */
1095                 if (LIKELY(!alias)) {
1096                     sv = newSV(0);
1097                     sv_setsv_nomg(sv, *relem);
1098                     *relem = sv;
1099                 }
1100                 else {
1101                     if (!SvROK(*relem))
1102                         DIE(aTHX_ "Assigned value is not a reference");
1103                     if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1104                    /* diag_listed_as: Assigned value is not %s reference */
1105                         DIE(aTHX_
1106                            "Assigned value is not a SCALAR reference");
1107                     if (lval)
1108                         *relem = sv_mortalcopy(*relem);
1109                     /* XXX else check for weak refs?  */
1110                     sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1111                 }
1112                 relem++;
1113                 didstore = av_store(ary,i++,sv);
1114                 if (magic) {
1115                     if (!didstore)
1116                         sv_2mortal(sv);
1117                     if (SvSMAGICAL(sv))
1118                         mg_set(sv);
1119                 }
1120                 TAINT_NOT;
1121             }
1122             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1123                 SvSETMAGIC(MUTABLE_SV(ary));
1124             LEAVE;
1125             break;
1126         case SVt_PVHV: {                                /* normal hash */
1127                 SV *tmpstr;
1128                 int odd;
1129                 int duplicates = 0;
1130                 SV** topelem = relem;
1131                 SV **firsthashrelem = relem;
1132
1133                 hash = MUTABLE_HV(sv);
1134                 magic = SvMAGICAL(hash) != 0;
1135
1136                 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1137                 if (UNLIKELY(odd)) {
1138                     do_oddball(lastrelem, firsthashrelem);
1139                     /* we have firstlelem to reuse, it's not needed anymore
1140                      */
1141                     *(lastrelem+1) = &PL_sv_undef;
1142                 }
1143
1144                 ENTER;
1145                 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1146                 hv_clear(hash);
1147                 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1148                     HE *didstore;
1149                     assert(*relem);
1150                     /* Copy the key if aassign is called in lvalue context,
1151                        to avoid having the next op modify our rhs.  Copy
1152                        it also if it is gmagical, lest it make the
1153                        hv_store_ent call below croak, leaking the value. */
1154                     sv = lval || SvGMAGICAL(*relem)
1155                          ? sv_mortalcopy(*relem)
1156                          : *relem;
1157                     relem++;
1158                     assert(*relem);
1159                     SvGETMAGIC(*relem);
1160                     tmpstr = newSV(0);
1161                     sv_setsv_nomg(tmpstr,*relem++);     /* value */
1162                     if (gimme == G_ARRAY) {
1163                         if (hv_exists_ent(hash, sv, 0))
1164                             /* key overwrites an existing entry */
1165                             duplicates += 2;
1166                         else {
1167                             /* copy element back: possibly to an earlier
1168                              * stack location if we encountered dups earlier,
1169                              * possibly to a later stack location if odd */
1170                             *topelem++ = sv;
1171                             *topelem++ = tmpstr;
1172                         }
1173                     }
1174                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1175                     if (magic) {
1176                         if (!didstore) sv_2mortal(tmpstr);
1177                         SvSETMAGIC(tmpstr);
1178                     }
1179                     TAINT_NOT;
1180                 }
1181                 LEAVE;
1182                 if (duplicates && gimme == G_ARRAY) {
1183                     /* at this point we have removed the duplicate key/value
1184                      * pairs from the stack, but the remaining values may be
1185                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1186                      * the (a 2), but the stack now probably contains
1187                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1188                      * obliterates the earlier key. So refresh all values. */
1189                     lastrelem -= duplicates;
1190                     relem = firsthashrelem;
1191                     while (relem < lastrelem+odd) {
1192                         HE *he;
1193                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1194                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1195                     }
1196                 }
1197                 if (odd && gimme == G_ARRAY) lastrelem++;
1198             }
1199             break;
1200         default:
1201             if (SvIMMORTAL(sv)) {
1202                 if (relem <= lastrelem)
1203                     relem++;
1204                 break;
1205             }
1206             if (relem <= lastrelem) {
1207                 if (UNLIKELY(
1208                   SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1209                   (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1210                 ))
1211                     Perl_warner(aTHX_
1212                        packWARN(WARN_MISC),
1213                       "Useless assignment to a temporary"
1214                     );
1215                 sv_setsv(sv, *relem);
1216                 *(relem++) = sv;
1217             }
1218             else
1219                 sv_setsv(sv, &PL_sv_undef);
1220             SvSETMAGIC(sv);
1221             break;
1222         }
1223     }
1224     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1225         /* Will be used to set PL_tainting below */
1226         Uid_t tmp_uid  = PerlProc_getuid();
1227         Uid_t tmp_euid = PerlProc_geteuid();
1228         Gid_t tmp_gid  = PerlProc_getgid();
1229         Gid_t tmp_egid = PerlProc_getegid();
1230
1231         /* XXX $> et al currently silently ignore failures */
1232         if (PL_delaymagic & DM_UID) {
1233 #ifdef HAS_SETRESUID
1234             PERL_UNUSED_RESULT(
1235                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1236                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1237                          (Uid_t)-1));
1238 #else
1239 #  ifdef HAS_SETREUID
1240             PERL_UNUSED_RESULT(
1241                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1242                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1243 #  else
1244 #    ifdef HAS_SETRUID
1245             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1246                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1247                 PL_delaymagic &= ~DM_RUID;
1248             }
1249 #    endif /* HAS_SETRUID */
1250 #    ifdef HAS_SETEUID
1251             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1252                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1253                 PL_delaymagic &= ~DM_EUID;
1254             }
1255 #    endif /* HAS_SETEUID */
1256             if (PL_delaymagic & DM_UID) {
1257                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1258                     DIE(aTHX_ "No setreuid available");
1259                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1260             }
1261 #  endif /* HAS_SETREUID */
1262 #endif /* HAS_SETRESUID */
1263
1264             tmp_uid  = PerlProc_getuid();
1265             tmp_euid = PerlProc_geteuid();
1266         }
1267         /* XXX $> et al currently silently ignore failures */
1268         if (PL_delaymagic & DM_GID) {
1269 #ifdef HAS_SETRESGID
1270             PERL_UNUSED_RESULT(
1271                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1272                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1273                           (Gid_t)-1));
1274 #else
1275 #  ifdef HAS_SETREGID
1276             PERL_UNUSED_RESULT(
1277                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1278                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1279 #  else
1280 #    ifdef HAS_SETRGID
1281             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1282                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1283                 PL_delaymagic &= ~DM_RGID;
1284             }
1285 #    endif /* HAS_SETRGID */
1286 #    ifdef HAS_SETEGID
1287             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1288                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1289                 PL_delaymagic &= ~DM_EGID;
1290             }
1291 #    endif /* HAS_SETEGID */
1292             if (PL_delaymagic & DM_GID) {
1293                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1294                     DIE(aTHX_ "No setregid available");
1295                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1296             }
1297 #  endif /* HAS_SETREGID */
1298 #endif /* HAS_SETRESGID */
1299
1300             tmp_gid  = PerlProc_getgid();
1301             tmp_egid = PerlProc_getegid();
1302         }
1303         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1304 #ifdef NO_TAINT_SUPPORT
1305         PERL_UNUSED_VAR(tmp_uid);
1306         PERL_UNUSED_VAR(tmp_euid);
1307         PERL_UNUSED_VAR(tmp_gid);
1308         PERL_UNUSED_VAR(tmp_egid);
1309 #endif
1310     }
1311     PL_delaymagic = 0;
1312
1313     if (gimme == G_VOID)
1314         SP = firstrelem - 1;
1315     else if (gimme == G_SCALAR) {
1316         dTARGET;
1317         SP = firstrelem;
1318         SETi(lastrelem - firstrelem + 1);
1319     }
1320     else {
1321         if (ary || hash)
1322             /* note that in this case *firstlelem may have been overwritten
1323                by sv_undef in the odd hash case */
1324             SP = lastrelem;
1325         else {
1326             SP = firstrelem + (lastlelem - firstlelem);
1327             lelem = firstlelem + (relem - firstrelem);
1328             while (relem <= SP)
1329                 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1330         }
1331     }
1332
1333     RETURN;
1334 }
1335
1336 PP(pp_qr)
1337 {
1338     dSP;
1339     PMOP * const pm = cPMOP;
1340     REGEXP * rx = PM_GETRE(pm);
1341     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1342     SV * const rv = sv_newmortal();
1343     CV **cvp;
1344     CV *cv;
1345
1346     SvUPGRADE(rv, SVt_IV);
1347     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1348        loathe to use it here, but it seems to be the right fix. Or close.
1349        The key part appears to be that it's essential for pp_qr to return a new
1350        object (SV), which implies that there needs to be an effective way to
1351        generate a new SV from the existing SV that is pre-compiled in the
1352        optree.  */
1353     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1354     SvROK_on(rv);
1355
1356     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1357     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1358         *cvp = cv_clone(cv);
1359         SvREFCNT_dec_NN(cv);
1360     }
1361
1362     if (pkg) {
1363         HV *const stash = gv_stashsv(pkg, GV_ADD);
1364         SvREFCNT_dec_NN(pkg);
1365         (void)sv_bless(rv, stash);
1366     }
1367
1368     if (UNLIKELY(RX_ISTAINTED(rx))) {
1369         SvTAINTED_on(rv);
1370         SvTAINTED_on(SvRV(rv));
1371     }
1372     XPUSHs(rv);
1373     RETURN;
1374 }
1375
1376 PP(pp_match)
1377 {
1378     dSP; dTARG;
1379     PMOP *pm = cPMOP;
1380     PMOP *dynpm = pm;
1381     const char *s;
1382     const char *strend;
1383     SSize_t curpos = 0; /* initial pos() or current $+[0] */
1384     I32 global;
1385     U8 r_flags = 0;
1386     const char *truebase;                       /* Start of string  */
1387     REGEXP *rx = PM_GETRE(pm);
1388     bool rxtainted;
1389     const I32 gimme = GIMME_V;
1390     STRLEN len;
1391     const I32 oldsave = PL_savestack_ix;
1392     I32 had_zerolen = 0;
1393     MAGIC *mg = NULL;
1394
1395     if (PL_op->op_flags & OPf_STACKED)
1396         TARG = POPs;
1397     else if (ARGTARG)
1398         GETTARGET;
1399     else {
1400         TARG = DEFSV;
1401         EXTEND(SP,1);
1402     }
1403
1404     PUTBACK;                            /* EVAL blocks need stack_sp. */
1405     /* Skip get-magic if this is a qr// clone, because regcomp has
1406        already done it. */
1407     truebase = ReANY(rx)->mother_re
1408          ? SvPV_nomg_const(TARG, len)
1409          : SvPV_const(TARG, len);
1410     if (!truebase)
1411         DIE(aTHX_ "panic: pp_match");
1412     strend = truebase + len;
1413     rxtainted = (RX_ISTAINTED(rx) ||
1414                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1415     TAINT_NOT;
1416
1417     /* We need to know this in case we fail out early - pos() must be reset */
1418     global = dynpm->op_pmflags & PMf_GLOBAL;
1419
1420     /* PMdf_USED is set after a ?? matches once */
1421     if (
1422 #ifdef USE_ITHREADS
1423         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1424 #else
1425         pm->op_pmflags & PMf_USED
1426 #endif
1427     ) {
1428         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1429         goto nope;
1430     }
1431
1432     /* empty pattern special-cased to use last successful pattern if
1433        possible, except for qr// */
1434     if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1435      && PL_curpm) {
1436         pm = PL_curpm;
1437         rx = PM_GETRE(pm);
1438     }
1439
1440     if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1441         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1442                                               UVuf" < %"IVdf")\n",
1443                                               (UV)len, (IV)RX_MINLEN(rx)));
1444         goto nope;
1445     }
1446
1447     /* get pos() if //g */
1448     if (global) {
1449         mg = mg_find_mglob(TARG);
1450         if (mg && mg->mg_len >= 0) {
1451             curpos = MgBYTEPOS(mg, TARG, truebase, len);
1452             /* last time pos() was set, it was zero-length match */
1453             if (mg->mg_flags & MGf_MINMATCH)
1454                 had_zerolen = 1;
1455         }
1456     }
1457
1458 #ifdef PERL_SAWAMPERSAND
1459     if (       RX_NPARENS(rx)
1460             || PL_sawampersand
1461             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1462             || (dynpm->op_pmflags & PMf_KEEPCOPY)
1463     )
1464 #endif
1465     {
1466         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1467         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1468          * only on the first iteration. Therefore we need to copy $' as well
1469          * as $&, to make the rest of the string available for captures in
1470          * subsequent iterations */
1471         if (! (global && gimme == G_ARRAY))
1472             r_flags |= REXEC_COPY_SKIP_POST;
1473     };
1474 #ifdef PERL_SAWAMPERSAND
1475     if (dynpm->op_pmflags & PMf_KEEPCOPY)
1476         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1477         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1478 #endif
1479
1480     s = truebase;
1481
1482   play_it_again:
1483     if (global)
1484         s = truebase + curpos;
1485
1486     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1487                      had_zerolen, TARG, NULL, r_flags))
1488         goto nope;
1489
1490     PL_curpm = pm;
1491     if (dynpm->op_pmflags & PMf_ONCE)
1492 #ifdef USE_ITHREADS
1493         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1494 #else
1495         dynpm->op_pmflags |= PMf_USED;
1496 #endif
1497
1498     if (rxtainted)
1499         RX_MATCH_TAINTED_on(rx);
1500     TAINT_IF(RX_MATCH_TAINTED(rx));
1501
1502     /* update pos */
1503
1504     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1505         if (!mg)
1506             mg = sv_magicext_mglob(TARG);
1507         MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1508         if (RX_ZERO_LEN(rx))
1509             mg->mg_flags |= MGf_MINMATCH;
1510         else
1511             mg->mg_flags &= ~MGf_MINMATCH;
1512     }
1513
1514     if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1515         LEAVE_SCOPE(oldsave);
1516         RETPUSHYES;
1517     }
1518
1519     /* push captures on stack */
1520
1521     {
1522         const I32 nparens = RX_NPARENS(rx);
1523         I32 i = (global && !nparens) ? 1 : 0;
1524
1525         SPAGAIN;                        /* EVAL blocks could move the stack. */
1526         EXTEND(SP, nparens + i);
1527         EXTEND_MORTAL(nparens + i);
1528         for (i = !i; i <= nparens; i++) {
1529             PUSHs(sv_newmortal());
1530             if (LIKELY((RX_OFFS(rx)[i].start != -1)
1531                      && RX_OFFS(rx)[i].end   != -1 ))
1532             {
1533                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1534                 const char * const s = RX_OFFS(rx)[i].start + truebase;
1535                 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1536                         || len < 0 || len > strend - s))
1537                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1538                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1539                         (long) i, (long) RX_OFFS(rx)[i].start,
1540                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1541                 sv_setpvn(*SP, s, len);
1542                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1543                     SvUTF8_on(*SP);
1544             }
1545         }
1546         if (global) {
1547             curpos = (UV)RX_OFFS(rx)[0].end;
1548             had_zerolen = RX_ZERO_LEN(rx);
1549             PUTBACK;                    /* EVAL blocks may use stack */
1550             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1551             goto play_it_again;
1552         }
1553         LEAVE_SCOPE(oldsave);
1554         RETURN;
1555     }
1556     NOT_REACHED; /* NOTREACHED */
1557
1558   nope:
1559     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1560         if (!mg)
1561             mg = mg_find_mglob(TARG);
1562         if (mg)
1563             mg->mg_len = -1;
1564     }
1565     LEAVE_SCOPE(oldsave);
1566     if (gimme == G_ARRAY)
1567         RETURN;
1568     RETPUSHNO;
1569 }
1570
1571 OP *
1572 Perl_do_readline(pTHX)
1573 {
1574     dSP; dTARGETSTACKED;
1575     SV *sv;
1576     STRLEN tmplen = 0;
1577     STRLEN offset;
1578     PerlIO *fp;
1579     IO * const io = GvIO(PL_last_in_gv);
1580     const I32 type = PL_op->op_type;
1581     const I32 gimme = GIMME_V;
1582
1583     if (io) {
1584         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1585         if (mg) {
1586             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1587             if (gimme == G_SCALAR) {
1588                 SPAGAIN;
1589                 SvSetSV_nosteal(TARG, TOPs);
1590                 SETTARG;
1591             }
1592             return NORMAL;
1593         }
1594     }
1595     fp = NULL;
1596     if (io) {
1597         fp = IoIFP(io);
1598         if (!fp) {
1599             if (IoFLAGS(io) & IOf_ARGV) {
1600                 if (IoFLAGS(io) & IOf_START) {
1601                     IoLINES(io) = 0;
1602                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1603                         IoFLAGS(io) &= ~IOf_START;
1604                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1605                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1606                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1607                         SvSETMAGIC(GvSV(PL_last_in_gv));
1608                         fp = IoIFP(io);
1609                         goto have_fp;
1610                     }
1611                 }
1612                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1613                 if (!fp) { /* Note: fp != IoIFP(io) */
1614                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1615                 }
1616             }
1617             else if (type == OP_GLOB)
1618                 fp = Perl_start_glob(aTHX_ POPs, io);
1619         }
1620         else if (type == OP_GLOB)
1621             SP--;
1622         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1623             report_wrongway_fh(PL_last_in_gv, '>');
1624         }
1625     }
1626     if (!fp) {
1627         if ((!io || !(IoFLAGS(io) & IOf_START))
1628             && ckWARN(WARN_CLOSED)
1629             && type != OP_GLOB)
1630         {
1631             report_evil_fh(PL_last_in_gv);
1632         }
1633         if (gimme == G_SCALAR) {
1634             /* undef TARG, and push that undefined value */
1635             if (type != OP_RCATLINE) {
1636                 sv_setsv(TARG,NULL);
1637             }
1638             PUSHTARG;
1639         }
1640         RETURN;
1641     }
1642   have_fp:
1643     if (gimme == G_SCALAR) {
1644         sv = TARG;
1645         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1646             mg_get(sv);
1647         if (SvROK(sv)) {
1648             if (type == OP_RCATLINE)
1649                 SvPV_force_nomg_nolen(sv);
1650             else
1651                 sv_unref(sv);
1652         }
1653         else if (isGV_with_GP(sv)) {
1654             SvPV_force_nomg_nolen(sv);
1655         }
1656         SvUPGRADE(sv, SVt_PV);
1657         tmplen = SvLEN(sv);     /* remember if already alloced */
1658         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1659             /* try short-buffering it. Please update t/op/readline.t
1660              * if you change the growth length.
1661              */
1662             Sv_Grow(sv, 80);
1663         }
1664         offset = 0;
1665         if (type == OP_RCATLINE && SvOK(sv)) {
1666             if (!SvPOK(sv)) {
1667                 SvPV_force_nomg_nolen(sv);
1668             }
1669             offset = SvCUR(sv);
1670         }
1671     }
1672     else {
1673         sv = sv_2mortal(newSV(80));
1674         offset = 0;
1675     }
1676
1677     /* This should not be marked tainted if the fp is marked clean */
1678 #define MAYBE_TAINT_LINE(io, sv) \
1679     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1680         TAINT;                          \
1681         SvTAINTED_on(sv);               \
1682     }
1683
1684 /* delay EOF state for a snarfed empty file */
1685 #define SNARF_EOF(gimme,rs,io,sv) \
1686     (gimme != G_SCALAR || SvCUR(sv)                                     \
1687      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1688
1689     for (;;) {
1690         PUTBACK;
1691         if (!sv_gets(sv, fp, offset)
1692             && (type == OP_GLOB
1693                 || SNARF_EOF(gimme, PL_rs, io, sv)
1694                 || PerlIO_error(fp)))
1695         {
1696             PerlIO_clearerr(fp);
1697             if (IoFLAGS(io) & IOf_ARGV) {
1698                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1699                 if (fp)
1700                     continue;
1701                 (void)do_close(PL_last_in_gv, FALSE);
1702             }
1703             else if (type == OP_GLOB) {
1704                 if (!do_close(PL_last_in_gv, FALSE)) {
1705                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1706                                    "glob failed (child exited with status %d%s)",
1707                                    (int)(STATUS_CURRENT >> 8),
1708                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1709                 }
1710             }
1711             if (gimme == G_SCALAR) {
1712                 if (type != OP_RCATLINE) {
1713                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1714                     SvOK_off(TARG);
1715                 }
1716                 SPAGAIN;
1717                 PUSHTARG;
1718             }
1719             MAYBE_TAINT_LINE(io, sv);
1720             RETURN;
1721         }
1722         MAYBE_TAINT_LINE(io, sv);
1723         IoLINES(io)++;
1724         IoFLAGS(io) |= IOf_NOLINE;
1725         SvSETMAGIC(sv);
1726         SPAGAIN;
1727         XPUSHs(sv);
1728         if (type == OP_GLOB) {
1729             const char *t1;
1730
1731             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1732                 char * const tmps = SvEND(sv) - 1;
1733                 if (*tmps == *SvPVX_const(PL_rs)) {
1734                     *tmps = '\0';
1735                     SvCUR_set(sv, SvCUR(sv) - 1);
1736                 }
1737             }
1738             for (t1 = SvPVX_const(sv); *t1; t1++)
1739 #ifdef __VMS
1740                 if (strchr("*%?", *t1))
1741 #else
1742                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1743 #endif
1744                         break;
1745             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1746                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1747                 continue;
1748             }
1749         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1750              if (ckWARN(WARN_UTF8)) {
1751                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1752                 const STRLEN len = SvCUR(sv) - offset;
1753                 const U8 *f;
1754
1755                 if (!is_utf8_string_loc(s, len, &f))
1756                     /* Emulate :encoding(utf8) warning in the same case. */
1757                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1758                                 "utf8 \"\\x%02X\" does not map to Unicode",
1759                                 f < (U8*)SvEND(sv) ? *f : 0);
1760              }
1761         }
1762         if (gimme == G_ARRAY) {
1763             if (SvLEN(sv) - SvCUR(sv) > 20) {
1764                 SvPV_shrink_to_cur(sv);
1765             }
1766             sv = sv_2mortal(newSV(80));
1767             continue;
1768         }
1769         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1770             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1771             const STRLEN new_len
1772                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1773             SvPV_renew(sv, new_len);
1774         }
1775         RETURN;
1776     }
1777 }
1778
1779 PP(pp_helem)
1780 {
1781     dSP;
1782     HE* he;
1783     SV **svp;
1784     SV * const keysv = POPs;
1785     HV * const hv = MUTABLE_HV(POPs);
1786     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1787     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1788     SV *sv;
1789     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1790     bool preeminent = TRUE;
1791
1792     assert(SvTYPE(hv) == SVt_PVHV);
1793
1794     if (localizing) {
1795         MAGIC *mg;
1796         HV *stash;
1797
1798         /* If we can determine whether the element exist,
1799          * Try to preserve the existenceness of a tied hash
1800          * element by using EXISTS and DELETE if possible.
1801          * Fallback to FETCH and STORE otherwise. */
1802         if (SvCANEXISTDELETE(hv))
1803             preeminent = hv_exists_ent(hv, keysv, 0);
1804     }
1805
1806     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1807     svp = he ? &HeVAL(he) : NULL;
1808     if (lval) {
1809         if (!svp || !*svp || *svp == &PL_sv_undef) {
1810             SV* lv;
1811             SV* key2;
1812             if (!defer) {
1813                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1814             }
1815             lv = sv_newmortal();
1816             sv_upgrade(lv, SVt_PVLV);
1817             LvTYPE(lv) = 'y';
1818             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1819             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
1820             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1821             LvTARGLEN(lv) = 1;
1822             PUSHs(lv);
1823             RETURN;
1824         }
1825         if (localizing) {
1826             if (HvNAME_get(hv) && isGV(*svp))
1827                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1828             else if (preeminent)
1829                 save_helem_flags(hv, keysv, svp,
1830                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1831             else
1832                 SAVEHDELETE(hv, keysv);
1833         }
1834         else if (PL_op->op_private & OPpDEREF) {
1835             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1836             RETURN;
1837         }
1838     }
1839     sv = (svp && *svp ? *svp : &PL_sv_undef);
1840     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1841      * was to make C<local $tied{foo} = $tied{foo}> possible.
1842      * However, it seems no longer to be needed for that purpose, and
1843      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1844      * would loop endlessly since the pos magic is getting set on the
1845      * mortal copy and lost. However, the copy has the effect of
1846      * triggering the get magic, and losing it altogether made things like
1847      * c<$tied{foo};> in void context no longer do get magic, which some
1848      * code relied on. Also, delayed triggering of magic on @+ and friends
1849      * meant the original regex may be out of scope by now. So as a
1850      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1851      * being called too many times). */
1852     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1853         mg_get(sv);
1854     PUSHs(sv);
1855     RETURN;
1856 }
1857
1858
1859 /* a stripped-down version of Perl_softref2xv() for use by
1860  * pp_multideref(), which doesn't use PL_op->op_flags */
1861
1862 GV *
1863 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
1864                 const svtype type)
1865 {
1866     if (PL_op->op_private & HINT_STRICT_REFS) {
1867         if (SvOK(sv))
1868             Perl_die(aTHX_ PL_no_symref_sv, sv,
1869                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
1870         else
1871             Perl_die(aTHX_ PL_no_usym, what);
1872     }
1873     if (!SvOK(sv))
1874         Perl_die(aTHX_ PL_no_usym, what);
1875     return gv_fetchsv_nomg(sv, GV_ADD, type);
1876 }
1877
1878
1879 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
1880  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
1881  *
1882  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
1883  * Each of these either contains a set of actions, or an argument, such as
1884  * an IV to use as an array index, or a lexical var to retrieve.
1885  * Several actions re stored per UV; we keep shifting new actions off the
1886  * one UV, and only reload when it becomes zero.
1887  */
1888
1889 PP(pp_multideref)
1890 {
1891     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
1892     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
1893     UV actions = items->uv;
1894
1895     assert(actions);
1896     /* this tells find_uninit_var() where we're up to */
1897     PL_multideref_pc = items;
1898
1899     while (1) {
1900         /* there are three main classes of action; the first retrieve
1901          * the initial AV or HV from a variable or the stack; the second
1902          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
1903          * the third an unrolled (/DREFHV, rv2hv, helem).
1904          */
1905         switch (actions & MDEREF_ACTION_MASK) {
1906
1907         case MDEREF_reload:
1908             actions = (++items)->uv;
1909             continue;
1910
1911         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
1912             sv = PAD_SVl((++items)->pad_offset);
1913             goto do_AV_aelem;
1914
1915         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
1916             sv = UNOP_AUX_item_sv(++items);
1917             assert(isGV_with_GP(sv));
1918             sv = (SV*)GvAVn((GV*)sv);
1919             goto do_AV_aelem;
1920
1921         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
1922             {
1923                 dSP;
1924                 sv = POPs;
1925                 PUTBACK;
1926                 goto do_AV_rv2av_aelem;
1927             }
1928
1929         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
1930             sv = UNOP_AUX_item_sv(++items);
1931             assert(isGV_with_GP(sv));
1932             sv = GvSVn((GV*)sv);
1933             goto do_AV_vivify_rv2av_aelem;
1934
1935         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
1936             sv = PAD_SVl((++items)->pad_offset);
1937             /* FALLTHROUGH */
1938
1939         do_AV_vivify_rv2av_aelem:
1940         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
1941             /* this is the OPpDEREF action normally found at the end of
1942              * ops like aelem, helem, rv2sv */
1943             sv = vivify_ref(sv, OPpDEREF_AV);
1944             /* FALLTHROUGH */
1945
1946         do_AV_rv2av_aelem:
1947             /* this is basically a copy of pp_rv2av when it just has the
1948              * sKR/1 flags */
1949             SvGETMAGIC(sv);
1950             if (LIKELY(SvROK(sv))) {
1951                 if (UNLIKELY(SvAMAGIC(sv))) {
1952                     sv = amagic_deref_call(sv, to_av_amg);
1953                 }
1954                 sv = SvRV(sv);
1955                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
1956                     DIE(aTHX_ "Not an ARRAY reference");
1957             }
1958             else if (SvTYPE(sv) != SVt_PVAV) {
1959                 if (!isGV_with_GP(sv))
1960                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
1961                 sv = MUTABLE_SV(GvAVn((GV*)sv));
1962             }
1963             /* FALLTHROUGH */
1964
1965         do_AV_aelem:
1966             {
1967                 /* retrieve the key; this may be either a lexical or package
1968                  * var (whose index/ptr is stored as an item) or a signed
1969                  * integer constant stored as an item.
1970                  */
1971                 SV *elemsv;
1972                 IV elem = 0; /* to shut up stupid compiler warnings */
1973
1974
1975                 assert(SvTYPE(sv) == SVt_PVAV);
1976
1977                 switch (actions & MDEREF_INDEX_MASK) {
1978                 case MDEREF_INDEX_none:
1979                     goto finish;
1980                 case MDEREF_INDEX_const:
1981                     elem  = (++items)->iv;
1982                     break;
1983                 case MDEREF_INDEX_padsv:
1984                     elemsv = PAD_SVl((++items)->pad_offset);
1985                     goto check_elem;
1986                 case MDEREF_INDEX_gvsv:
1987                     elemsv = UNOP_AUX_item_sv(++items);
1988                     assert(isGV_with_GP(elemsv));
1989                     elemsv = GvSVn((GV*)elemsv);
1990                 check_elem:
1991                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
1992                                             && ckWARN(WARN_MISC)))
1993                         Perl_warner(aTHX_ packWARN(WARN_MISC),
1994                                 "Use of reference \"%"SVf"\" as array index",
1995                                 SVfARG(elemsv));
1996                     /* the only time that S_find_uninit_var() needs this
1997                      * is to determine which index value triggered the
1998                      * undef warning. So just update it here. Note that
1999                      * since we don't save and restore this var (e.g. for
2000                      * tie or overload execution), its value will be
2001                      * meaningless apart from just here */
2002                     PL_multideref_pc = items;
2003                     elem = SvIV(elemsv);
2004                     break;
2005                 }
2006
2007
2008                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2009
2010                 if (!(actions & MDEREF_FLAG_last)) {
2011                     SV** svp = av_fetch((AV*)sv, elem, 1);
2012                     if (!svp || ! (sv=*svp))
2013                         DIE(aTHX_ PL_no_aelem, elem);
2014                     break;
2015                 }
2016
2017                 if (PL_op->op_private &
2018                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2019                 {
2020                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2021                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2022                     }
2023                     else {
2024                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2025                         sv = av_delete((AV*)sv, elem, discard);
2026                         if (discard)
2027                             return NORMAL;
2028                         if (!sv)
2029                             sv = &PL_sv_undef;
2030                     }
2031                 }
2032                 else {
2033                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2034                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2035                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2036                     bool preeminent = TRUE;
2037                     AV *const av = (AV*)sv;
2038                     SV** svp;
2039
2040                     if (UNLIKELY(localizing)) {
2041                         MAGIC *mg;
2042                         HV *stash;
2043
2044                         /* If we can determine whether the element exist,
2045                          * Try to preserve the existenceness of a tied array
2046                          * element by using EXISTS and DELETE if possible.
2047                          * Fallback to FETCH and STORE otherwise. */
2048                         if (SvCANEXISTDELETE(av))
2049                             preeminent = av_exists(av, elem);
2050                     }
2051
2052                     svp = av_fetch(av, elem, lval && !defer);
2053
2054                     if (lval) {
2055                         if (!svp || !(sv = *svp)) {
2056                             IV len;
2057                             if (!defer)
2058                                 DIE(aTHX_ PL_no_aelem, elem);
2059                             len = av_tindex(av);
2060                             sv = sv_2mortal(newSVavdefelem(av,
2061                             /* Resolve a negative index now, unless it points
2062                              * before the beginning of the array, in which
2063                              * case record it for error reporting in
2064                              * magic_setdefelem. */
2065                                 elem < 0 && len + elem >= 0
2066                                     ? len + elem : elem, 1));
2067                         }
2068                         else {
2069                             if (UNLIKELY(localizing)) {
2070                                 if (preeminent) {
2071                                     save_aelem(av, elem, svp);
2072                                     sv = *svp; /* may have changed */
2073                                 }
2074                                 else
2075                                     SAVEADELETE(av, elem);
2076                             }
2077                         }
2078                     }
2079                     else {
2080                         sv = (svp ? *svp : &PL_sv_undef);
2081                         /* see note in pp_helem() */
2082                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2083                             mg_get(sv);
2084                     }
2085                 }
2086
2087             }
2088           finish:
2089             {
2090                 dSP;
2091                 XPUSHs(sv);
2092                 RETURN;
2093             }
2094             /* NOTREACHED */
2095
2096
2097
2098
2099         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
2100             sv = PAD_SVl((++items)->pad_offset);
2101             goto do_HV_helem;
2102
2103         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
2104             sv = UNOP_AUX_item_sv(++items);
2105             assert(isGV_with_GP(sv));
2106             sv = (SV*)GvHVn((GV*)sv);
2107             goto do_HV_helem;
2108
2109         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
2110             {
2111                 dSP;
2112                 sv = POPs;
2113                 PUTBACK;
2114                 goto do_HV_rv2hv_helem;
2115             }
2116
2117         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
2118             sv = UNOP_AUX_item_sv(++items);
2119             assert(isGV_with_GP(sv));
2120             sv = GvSVn((GV*)sv);
2121             goto do_HV_vivify_rv2hv_helem;
2122
2123         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
2124             sv = PAD_SVl((++items)->pad_offset);
2125             /* FALLTHROUGH */
2126
2127         do_HV_vivify_rv2hv_helem:
2128         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
2129             /* this is the OPpDEREF action normally found at the end of
2130              * ops like aelem, helem, rv2sv */
2131             sv = vivify_ref(sv, OPpDEREF_HV);
2132             /* FALLTHROUGH */
2133
2134         do_HV_rv2hv_helem:
2135             /* this is basically a copy of pp_rv2hv when it just has the
2136              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2137
2138             SvGETMAGIC(sv);
2139             if (LIKELY(SvROK(sv))) {
2140                 if (UNLIKELY(SvAMAGIC(sv))) {
2141                     sv = amagic_deref_call(sv, to_hv_amg);
2142                 }
2143                 sv = SvRV(sv);
2144                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2145                     DIE(aTHX_ "Not a HASH reference");
2146             }
2147             else if (SvTYPE(sv) != SVt_PVHV) {
2148                 if (!isGV_with_GP(sv))
2149                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2150                 sv = MUTABLE_SV(GvHVn((GV*)sv));
2151             }
2152             /* FALLTHROUGH */
2153
2154         do_HV_helem:
2155             {
2156                 /* retrieve the key; this may be either a lexical / package
2157                  * var or a string constant, whose index/ptr is stored as an
2158                  * item
2159                  */
2160                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2161
2162                 assert(SvTYPE(sv) == SVt_PVHV);
2163
2164                 switch (actions & MDEREF_INDEX_MASK) {
2165                 case MDEREF_INDEX_none:
2166                     goto finish;
2167
2168                 case MDEREF_INDEX_const:
2169                     keysv = UNOP_AUX_item_sv(++items);
2170                     break;
2171
2172                 case MDEREF_INDEX_padsv:
2173                     keysv = PAD_SVl((++items)->pad_offset);
2174                     break;
2175
2176                 case MDEREF_INDEX_gvsv:
2177                     keysv = UNOP_AUX_item_sv(++items);
2178                     keysv = GvSVn((GV*)keysv);
2179                     break;
2180                 }
2181
2182                 /* see comment above about setting this var */
2183                 PL_multideref_pc = items;
2184
2185
2186                 /* ensure that candidate CONSTs have been HEKified */
2187                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2188                        || SvTYPE(keysv) >= SVt_PVMG
2189                        || !SvOK(keysv)
2190                        || SvROK(keysv)
2191                        || SvIsCOW_shared_hash(keysv));
2192
2193                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2194
2195                 if (!(actions & MDEREF_FLAG_last)) {
2196                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2197                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2198                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2199                     break;
2200                 }
2201
2202                 if (PL_op->op_private &
2203                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2204                 {
2205                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2206                         sv = hv_exists_ent((HV*)sv, keysv, 0)
2207                                                 ? &PL_sv_yes : &PL_sv_no;
2208                     }
2209                     else {
2210                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2211                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2212                         if (discard)
2213                             return NORMAL;
2214                         if (!sv)
2215                             sv = &PL_sv_undef;
2216                     }
2217                 }
2218                 else {
2219                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2220                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2221                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2222                     bool preeminent = TRUE;
2223                     SV **svp;
2224                     HV * const hv = (HV*)sv;
2225                     HE* he;
2226
2227                     if (UNLIKELY(localizing)) {
2228                         MAGIC *mg;
2229                         HV *stash;
2230
2231                         /* If we can determine whether the element exist,
2232                          * Try to preserve the existenceness of a tied hash
2233                          * element by using EXISTS and DELETE if possible.
2234                          * Fallback to FETCH and STORE otherwise. */
2235                         if (SvCANEXISTDELETE(hv))
2236                             preeminent = hv_exists_ent(hv, keysv, 0);
2237                     }
2238
2239                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2240                     svp = he ? &HeVAL(he) : NULL;
2241
2242
2243                     if (lval) {
2244                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2245                             SV* lv;
2246                             SV* key2;
2247                             if (!defer)
2248                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2249                             lv = sv_newmortal();
2250                             sv_upgrade(lv, SVt_PVLV);
2251                             LvTYPE(lv) = 'y';
2252                             sv_magic(lv, key2 = newSVsv(keysv),
2253                                                 PERL_MAGIC_defelem, NULL, 0);
2254                             /* sv_magic() increments refcount */
2255                             SvREFCNT_dec_NN(key2);
2256                             LvTARG(lv) = SvREFCNT_inc_simple(hv);
2257                             LvTARGLEN(lv) = 1;
2258                             sv = lv;
2259                         }
2260                         else {
2261                             if (localizing) {
2262                                 if (HvNAME_get(hv) && isGV(sv))
2263                                     save_gp(MUTABLE_GV(sv),
2264                                         !(PL_op->op_flags & OPf_SPECIAL));
2265                                 else if (preeminent) {
2266                                     save_helem_flags(hv, keysv, svp,
2267                                          (PL_op->op_flags & OPf_SPECIAL)
2268                                             ? 0 : SAVEf_SETMAGIC);
2269                                     sv = *svp; /* may have changed */
2270                                 }
2271                                 else
2272                                     SAVEHDELETE(hv, keysv);
2273                             }
2274                         }
2275                     }
2276                     else {
2277                         sv = (svp && *svp ? *svp : &PL_sv_undef);
2278                         /* see note in pp_helem() */
2279                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2280                             mg_get(sv);
2281                     }
2282                 }
2283                 goto finish;
2284             }
2285
2286         } /* switch */
2287
2288         actions >>= MDEREF_SHIFT;
2289     } /* while */
2290     /* NOTREACHED */
2291 }
2292
2293
2294 PP(pp_iter)
2295 {
2296     dSP;
2297     PERL_CONTEXT *cx;
2298     SV *oldsv;
2299     SV **itersvp;
2300
2301     EXTEND(SP, 1);
2302     cx = &cxstack[cxstack_ix];
2303     itersvp = CxITERVAR(cx);
2304
2305     switch (CxTYPE(cx)) {
2306
2307     case CXt_LOOP_LAZYSV: /* string increment */
2308     {
2309         SV* cur = cx->blk_loop.state_u.lazysv.cur;
2310         SV *end = cx->blk_loop.state_u.lazysv.end;
2311         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2312            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
2313         STRLEN maxlen = 0;
2314         const char *max = SvPV_const(end, maxlen);
2315         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2316             RETPUSHNO;
2317
2318         oldsv = *itersvp;
2319         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2320             /* safe to reuse old SV */
2321             sv_setsv(oldsv, cur);
2322         }
2323         else
2324         {
2325             /* we need a fresh SV every time so that loop body sees a
2326              * completely new SV for closures/references to work as
2327              * they used to */
2328             *itersvp = newSVsv(cur);
2329             SvREFCNT_dec_NN(oldsv);
2330         }
2331         if (strEQ(SvPVX_const(cur), max))
2332             sv_setiv(cur, 0); /* terminate next time */
2333         else
2334             sv_inc(cur);
2335         break;
2336     }
2337
2338     case CXt_LOOP_LAZYIV: /* integer increment */
2339     {
2340         IV cur = cx->blk_loop.state_u.lazyiv.cur;
2341         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2342             RETPUSHNO;
2343
2344         oldsv = *itersvp;
2345         /* don't risk potential race */
2346         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2347             /* safe to reuse old SV */
2348             sv_setiv(oldsv, cur);
2349         }
2350         else
2351         {
2352             /* we need a fresh SV every time so that loop body sees a
2353              * completely new SV for closures/references to work as they
2354              * used to */
2355             *itersvp = newSViv(cur);
2356             SvREFCNT_dec_NN(oldsv);
2357         }
2358
2359         if (UNLIKELY(cur == IV_MAX)) {
2360             /* Handle end of range at IV_MAX */
2361             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2362         } else
2363             ++cx->blk_loop.state_u.lazyiv.cur;
2364         break;
2365     }
2366
2367     case CXt_LOOP_FOR: /* iterate array */
2368     {
2369
2370         AV *av = cx->blk_loop.state_u.ary.ary;
2371         SV *sv;
2372         bool av_is_stack = FALSE;
2373         IV ix;
2374
2375         if (!av) {
2376             av_is_stack = TRUE;
2377             av = PL_curstack;
2378         }
2379         if (PL_op->op_private & OPpITER_REVERSED) {
2380             ix = --cx->blk_loop.state_u.ary.ix;
2381             if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
2382                 RETPUSHNO;
2383         }
2384         else {
2385             ix = ++cx->blk_loop.state_u.ary.ix;
2386             if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
2387                 RETPUSHNO;
2388         }
2389
2390         if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
2391             SV * const * const svp = av_fetch(av, ix, FALSE);
2392             sv = svp ? *svp : NULL;
2393         }
2394         else {
2395             sv = AvARRAY(av)[ix];
2396         }
2397
2398         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2399             SvSetMagicSV(*itersvp, sv);
2400             break;
2401         }
2402
2403         if (LIKELY(sv)) {
2404             if (UNLIKELY(SvIS_FREED(sv))) {
2405                 *itersvp = NULL;
2406                 Perl_croak(aTHX_ "Use of freed value in iteration");
2407             }
2408             if (SvPADTMP(sv)) {
2409                 sv = newSVsv(sv);
2410             }
2411             else {
2412                 SvTEMP_off(sv);
2413                 SvREFCNT_inc_simple_void_NN(sv);
2414             }
2415         }
2416         else if (!av_is_stack) {
2417             sv = newSVavdefelem(av, ix, 0);
2418         }
2419         else
2420             sv = &PL_sv_undef;
2421
2422         oldsv = *itersvp;
2423         *itersvp = sv;
2424         SvREFCNT_dec(oldsv);
2425         break;
2426     }
2427
2428     default:
2429         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2430     }
2431     RETPUSHYES;
2432 }
2433
2434 /*
2435 A description of how taint works in pattern matching and substitution.
2436
2437 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2438 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2439
2440 While the pattern is being assembled/concatenated and then compiled,
2441 PL_tainted will get set (via TAINT_set) if any component of the pattern
2442 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
2443 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2444 TAINT_get).  It will also be set if any component of the pattern matches
2445 based on locale-dependent behavior.
2446
2447 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2448 the pattern is marked as tainted. This means that subsequent usage, such
2449 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2450 on the new pattern too.
2451
2452 RXf_TAINTED_SEEN is used post-execution by the get magic code
2453 of $1 et al to indicate whether the returned value should be tainted.
2454 It is the responsibility of the caller of the pattern (i.e. pp_match,
2455 pp_subst etc) to set this flag for any other circumstances where $1 needs
2456 to be tainted.
2457
2458 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2459
2460 There are three possible sources of taint
2461     * the source string
2462     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2463     * the replacement string (or expression under /e)
2464     
2465 There are four destinations of taint and they are affected by the sources
2466 according to the rules below:
2467
2468     * the return value (not including /r):
2469         tainted by the source string and pattern, but only for the
2470         number-of-iterations case; boolean returns aren't tainted;
2471     * the modified string (or modified copy under /r):
2472         tainted by the source string, pattern, and replacement strings;
2473     * $1 et al:
2474         tainted by the pattern, and under 'use re "taint"', by the source
2475         string too;
2476     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2477         should always be unset before executing subsequent code.
2478
2479 The overall action of pp_subst is:
2480
2481     * at the start, set bits in rxtainted indicating the taint status of
2482         the various sources.
2483
2484     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2485         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2486         pattern has subsequently become tainted via locale ops.
2487
2488     * If control is being passed to pp_substcont to execute a /e block,
2489         save rxtainted in the CXt_SUBST block, for future use by
2490         pp_substcont.
2491
2492     * Whenever control is being returned to perl code (either by falling
2493         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2494         use the flag bits in rxtainted to make all the appropriate types of
2495         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2496         et al will appear tainted.
2497
2498 pp_match is just a simpler version of the above.
2499
2500 */
2501
2502 PP(pp_subst)
2503 {
2504     dSP; dTARG;
2505     PMOP *pm = cPMOP;
2506     PMOP *rpm = pm;
2507     char *s;
2508     char *strend;
2509     const char *c;
2510     STRLEN clen;
2511     SSize_t iters = 0;
2512     SSize_t maxiters;
2513     bool once;
2514     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2515                         See "how taint works" above */
2516     char *orig;
2517     U8 r_flags;
2518     REGEXP *rx = PM_GETRE(pm);
2519     STRLEN len;
2520     int force_on_match = 0;
2521     const I32 oldsave = PL_savestack_ix;
2522     STRLEN slen;
2523     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2524 #ifdef PERL_ANY_COW
2525     bool is_cow;
2526 #endif
2527     SV *nsv = NULL;
2528     /* known replacement string? */
2529     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2530
2531     PERL_ASYNC_CHECK();
2532
2533     if (PL_op->op_flags & OPf_STACKED)
2534         TARG = POPs;
2535     else if (ARGTARG)
2536         GETTARGET;
2537     else {
2538         TARG = DEFSV;
2539         EXTEND(SP,1);
2540     }
2541
2542     SvGETMAGIC(TARG); /* must come before cow check */
2543 #ifdef PERL_ANY_COW
2544     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2545        because they make integers such as 256 "false".  */
2546     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2547 #else
2548     if (SvIsCOW(TARG))
2549         sv_force_normal_flags(TARG,0);
2550 #endif
2551     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2552         && (SvREADONLY(TARG)
2553             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2554                   || SvTYPE(TARG) > SVt_PVLV)
2555                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2556         Perl_croak_no_modify();
2557     PUTBACK;
2558
2559     orig = SvPV_nomg(TARG, len);
2560     /* note we don't (yet) force the var into being a string; if we fail
2561      * to match, we leave as-is; on successful match howeverm, we *will*
2562      * coerce into a string, then repeat the match */
2563     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2564         force_on_match = 1;
2565
2566     /* only replace once? */
2567     once = !(rpm->op_pmflags & PMf_GLOBAL);
2568
2569     /* See "how taint works" above */
2570     if (TAINTING_get) {
2571         rxtainted  = (
2572             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2573           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2574           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2575           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2576                 ? SUBST_TAINT_BOOLRET : 0));
2577         TAINT_NOT;
2578     }
2579
2580   force_it:
2581     if (!pm || !orig)
2582         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2583
2584     strend = orig + len;
2585     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2586     maxiters = 2 * slen + 10;   /* We can match twice at each
2587                                    position, once with zero-length,
2588                                    second time with non-zero. */
2589
2590     if (!RX_PRELEN(rx) && PL_curpm
2591      && !ReANY(rx)->mother_re) {
2592         pm = PL_curpm;
2593         rx = PM_GETRE(pm);
2594     }
2595
2596 #ifdef PERL_SAWAMPERSAND
2597     r_flags = (    RX_NPARENS(rx)
2598                 || PL_sawampersand
2599                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2600                 || (rpm->op_pmflags & PMf_KEEPCOPY)
2601               )
2602           ? REXEC_COPY_STR
2603           : 0;
2604 #else
2605     r_flags = REXEC_COPY_STR;
2606 #endif
2607
2608     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2609     {
2610         SPAGAIN;
2611         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2612         LEAVE_SCOPE(oldsave);
2613         RETURN;
2614     }
2615     PL_curpm = pm;
2616
2617     /* known replacement string? */
2618     if (dstr) {
2619         /* replacement needing upgrading? */
2620         if (DO_UTF8(TARG) && !doutf8) {
2621              nsv = sv_newmortal();
2622              SvSetSV(nsv, dstr);
2623              if (IN_ENCODING)
2624                   sv_recode_to_utf8(nsv, _get_encoding());
2625              else
2626                   sv_utf8_upgrade(nsv);
2627              c = SvPV_const(nsv, clen);
2628              doutf8 = TRUE;
2629         }
2630         else {
2631             c = SvPV_const(dstr, clen);
2632             doutf8 = DO_UTF8(dstr);
2633         }
2634
2635         if (SvTAINTED(dstr))
2636             rxtainted |= SUBST_TAINT_REPL;
2637     }
2638     else {
2639         c = NULL;
2640         doutf8 = FALSE;
2641     }
2642     
2643     /* can do inplace substitution? */
2644     if (c
2645 #ifdef PERL_ANY_COW
2646         && !is_cow
2647 #endif
2648         && (I32)clen <= RX_MINLENRET(rx)
2649         && (  once
2650            || !(r_flags & REXEC_COPY_STR)
2651            || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2652            )
2653         && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2654         && (!doutf8 || SvUTF8(TARG))
2655         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2656     {
2657
2658 #ifdef PERL_ANY_COW
2659         if (SvIsCOW(TARG)) {
2660           if (!force_on_match)
2661             goto have_a_cow;
2662           assert(SvVOK(TARG));
2663         }
2664 #endif
2665         if (force_on_match) {
2666             /* redo the first match, this time with the orig var
2667              * forced into being a string */
2668             force_on_match = 0;
2669             orig = SvPV_force_nomg(TARG, len);
2670             goto force_it;
2671         }
2672
2673         if (once) {
2674             char *d, *m;
2675             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2676                 rxtainted |= SUBST_TAINT_PAT;
2677             m = orig + RX_OFFS(rx)[0].start;
2678             d = orig + RX_OFFS(rx)[0].end;
2679             s = orig;
2680             if (m - s > strend - d) {  /* faster to shorten from end */
2681                 I32 i;
2682                 if (clen) {
2683                     Copy(c, m, clen, char);
2684                     m += clen;
2685                 }
2686                 i = strend - d;
2687                 if (i > 0) {
2688                     Move(d, m, i, char);
2689                     m += i;
2690                 }
2691                 *m = '\0';
2692                 SvCUR_set(TARG, m - s);
2693             }
2694             else {      /* faster from front */
2695                 I32 i = m - s;
2696                 d -= clen;
2697                 if (i > 0)
2698                     Move(s, d - i, i, char);
2699                 sv_chop(TARG, d-i);
2700                 if (clen)
2701                     Copy(c, d, clen, char);
2702             }
2703             SPAGAIN;
2704             PUSHs(&PL_sv_yes);
2705         }
2706         else {
2707             char *d, *m;
2708             d = s = RX_OFFS(rx)[0].start + orig;
2709             do {
2710                 I32 i;
2711                 if (UNLIKELY(iters++ > maxiters))
2712                     DIE(aTHX_ "Substitution loop");
2713                 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2714                     rxtainted |= SUBST_TAINT_PAT;
2715                 m = RX_OFFS(rx)[0].start + orig;
2716                 if ((i = m - s)) {
2717                     if (s != d)
2718                         Move(s, d, i, char);
2719                     d += i;
2720                 }
2721                 if (clen) {
2722                     Copy(c, d, clen, char);
2723                     d += clen;
2724                 }
2725                 s = RX_OFFS(rx)[0].end + orig;
2726             } while (CALLREGEXEC(rx, s, strend, orig,
2727                                  s == m, /* don't match same null twice */
2728                                  TARG, NULL,
2729                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2730             if (s != d) {
2731                 I32 i = strend - s;
2732                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2733                 Move(s, d, i+1, char);          /* include the NUL */
2734             }
2735             SPAGAIN;
2736             mPUSHi(iters);
2737         }
2738     }
2739     else {
2740         bool first;
2741         char *m;
2742         SV *repl;
2743         if (force_on_match) {
2744             /* redo the first match, this time with the orig var
2745              * forced into being a string */
2746             force_on_match = 0;
2747             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2748                 /* I feel that it should be possible to avoid this mortal copy
2749                    given that the code below copies into a new destination.
2750                    However, I suspect it isn't worth the complexity of
2751                    unravelling the C<goto force_it> for the small number of
2752                    cases where it would be viable to drop into the copy code. */
2753                 TARG = sv_2mortal(newSVsv(TARG));
2754             }
2755             orig = SvPV_force_nomg(TARG, len);
2756             goto force_it;
2757         }
2758 #ifdef PERL_ANY_COW
2759       have_a_cow:
2760 #endif
2761         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2762             rxtainted |= SUBST_TAINT_PAT;
2763         repl = dstr;
2764         s = RX_OFFS(rx)[0].start + orig;
2765         dstr = newSVpvn_flags(orig, s-orig,
2766                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2767         if (!c) {
2768             PERL_CONTEXT *cx;
2769             SPAGAIN;
2770             m = orig;
2771             /* note that a whole bunch of local vars are saved here for
2772              * use by pp_substcont: here's a list of them in case you're
2773              * searching for places in this sub that uses a particular var:
2774              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2775              * s m strend rx once */
2776             PUSHSUBST(cx);
2777             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2778         }
2779         first = TRUE;
2780         do {
2781             if (UNLIKELY(iters++ > maxiters))
2782                 DIE(aTHX_ "Substitution loop");
2783             if (UNLIKELY(RX_MATCH_TAINTED(rx)))
2784                 rxtainted |= SUBST_TAINT_PAT;
2785             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2786                 char *old_s    = s;
2787                 char *old_orig = orig;
2788                 assert(RX_SUBOFFSET(rx) == 0);
2789
2790                 orig = RX_SUBBEG(rx);
2791                 s = orig + (old_s - old_orig);
2792                 strend = s + (strend - old_s);
2793             }
2794             m = RX_OFFS(rx)[0].start + orig;
2795             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2796             s = RX_OFFS(rx)[0].end + orig;
2797             if (first) {
2798                 /* replacement already stringified */
2799               if (clen)
2800                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2801               first = FALSE;
2802             }
2803             else {
2804                 if (IN_ENCODING) {
2805                     if (!nsv) nsv = sv_newmortal();
2806                     sv_copypv(nsv, repl);
2807                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
2808                     sv_catsv(dstr, nsv);
2809                 }
2810                 else sv_catsv(dstr, repl);
2811                 if (UNLIKELY(SvTAINTED(repl)))
2812                     rxtainted |= SUBST_TAINT_REPL;
2813             }
2814             if (once)
2815                 break;
2816         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2817                              TARG, NULL,
2818                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2819         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2820
2821         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2822             /* From here on down we're using the copy, and leaving the original
2823                untouched.  */
2824             TARG = dstr;
2825             SPAGAIN;
2826             PUSHs(dstr);
2827         } else {
2828 #ifdef PERL_ANY_COW
2829             /* The match may make the string COW. If so, brilliant, because
2830                that's just saved us one malloc, copy and free - the regexp has
2831                donated the old buffer, and we malloc an entirely new one, rather
2832                than the regexp malloc()ing a buffer and copying our original,
2833                only for us to throw it away here during the substitution.  */
2834             if (SvIsCOW(TARG)) {
2835                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2836             } else
2837 #endif
2838             {
2839                 SvPV_free(TARG);
2840             }
2841             SvPV_set(TARG, SvPVX(dstr));
2842             SvCUR_set(TARG, SvCUR(dstr));
2843             SvLEN_set(TARG, SvLEN(dstr));
2844             SvFLAGS(TARG) |= SvUTF8(dstr);
2845             SvPV_set(dstr, NULL);
2846
2847             SPAGAIN;
2848             mPUSHi(iters);
2849         }
2850     }
2851
2852     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2853         (void)SvPOK_only_UTF8(TARG);
2854     }
2855
2856     /* See "how taint works" above */
2857     if (TAINTING_get) {
2858         if ((rxtainted & SUBST_TAINT_PAT) ||
2859             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2860                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2861         )
2862             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2863
2864         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2865             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2866         )
2867             SvTAINTED_on(TOPs);  /* taint return value */
2868         else
2869             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2870
2871         /* needed for mg_set below */
2872         TAINT_set(
2873           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2874         );
2875         SvTAINT(TARG);
2876     }
2877     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2878     TAINT_NOT;
2879     LEAVE_SCOPE(oldsave);
2880     RETURN;
2881 }
2882
2883 PP(pp_grepwhile)
2884 {
2885     dSP;
2886
2887     if (SvTRUEx(POPs))
2888         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2889     ++*PL_markstack_ptr;
2890     FREETMPS;
2891     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2892
2893     /* All done yet? */
2894     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
2895         I32 items;
2896         const I32 gimme = GIMME_V;
2897
2898         LEAVE_with_name("grep");                                        /* exit outer scope */
2899         (void)POPMARK;                          /* pop src */
2900         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2901         (void)POPMARK;                          /* pop dst */
2902         SP = PL_stack_base + POPMARK;           /* pop original mark */
2903         if (gimme == G_SCALAR) {
2904             if (PL_op->op_private & OPpGREP_LEX) {
2905                 SV* const sv = sv_newmortal();
2906                 sv_setiv(sv, items);
2907                 PUSHs(sv);
2908             }
2909             else {
2910                 dTARGET;
2911                 XPUSHi(items);
2912             }
2913         }
2914         else if (gimme == G_ARRAY)
2915             SP += items;
2916         RETURN;
2917     }
2918     else {
2919         SV *src;
2920
2921         ENTER_with_name("grep_item");                                   /* enter inner scope */
2922         SAVEVPTR(PL_curpm);
2923
2924         src = PL_stack_base[*PL_markstack_ptr];
2925         if (SvPADTMP(src)) {
2926             src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2927             PL_tmps_floor++;
2928         }
2929         SvTEMP_off(src);
2930         if (PL_op->op_private & OPpGREP_LEX)
2931             PAD_SVl(PL_op->op_targ) = src;
2932         else
2933             DEFSV_set(src);
2934
2935         RETURNOP(cLOGOP->op_other);
2936     }
2937 }
2938
2939 PP(pp_leavesub)
2940 {
2941     dSP;
2942     SV **mark;
2943     SV **newsp;
2944     PMOP *newpm;
2945     I32 gimme;
2946     PERL_CONTEXT *cx;
2947     SV *sv;
2948
2949     if (CxMULTICALL(&cxstack[cxstack_ix]))
2950         return 0;
2951
2952     POPBLOCK(cx,newpm);
2953     cxstack_ix++; /* temporarily protect top context */
2954
2955     TAINT_NOT;
2956     if (gimme == G_SCALAR) {
2957         MARK = newsp + 1;
2958         if (LIKELY(MARK <= SP)) {
2959             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2960                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2961                      && !SvMAGICAL(TOPs)) {
2962                     *MARK = SvREFCNT_inc(TOPs);
2963                     FREETMPS;
2964                     sv_2mortal(*MARK);
2965                 }
2966                 else {
2967                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2968                     FREETMPS;
2969                     *MARK = sv_mortalcopy(sv);
2970                     SvREFCNT_dec_NN(sv);
2971                 }
2972             }
2973             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2974                      && !SvMAGICAL(TOPs)) {
2975                 *MARK = TOPs;
2976             }
2977             else
2978                 *MARK = sv_mortalcopy(TOPs);
2979         }
2980         else {
2981             MEXTEND(MARK, 0);
2982             *MARK = &PL_sv_undef;
2983         }
2984         SP = MARK;
2985     }
2986     else if (gimme == G_ARRAY) {
2987         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2988             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2989                  || SvMAGICAL(*MARK)) {
2990                 *MARK = sv_mortalcopy(*MARK);
2991                 TAINT_NOT;      /* Each item is independent */
2992             }
2993         }
2994     }
2995     PUTBACK;
2996
2997     LEAVE;
2998     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2999     cxstack_ix--;
3000     PL_curpm = newpm;   /* ... and pop $1 et al */
3001
3002     LEAVESUB(sv);
3003     return cx->blk_sub.retop;
3004 }
3005
3006 PP(pp_entersub)
3007 {
3008     dSP; dPOPss;
3009     GV *gv;
3010     CV *cv;
3011     PERL_CONTEXT *cx;
3012     I32 gimme;
3013     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
3014
3015     if (UNLIKELY(!sv))
3016         DIE(aTHX_ "Not a CODE reference");
3017     /* This is overwhelmingly the most common case:  */
3018     if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
3019         switch (SvTYPE(sv)) {
3020         case SVt_PVGV:
3021           we_have_a_glob:
3022             if (!(cv = GvCVu((const GV *)sv))) {
3023                 HV *stash;
3024                 cv = sv_2cv(sv, &stash, &gv, 0);
3025             }
3026             if (!cv) {
3027                 ENTER;
3028                 SAVETMPS;
3029                 goto try_autoload;
3030             }
3031             break;
3032         case SVt_PVLV:
3033             if(isGV_with_GP(sv)) goto we_have_a_glob;
3034             /* FALLTHROUGH */
3035         default:
3036             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
3037                 if (hasargs)
3038                     SP = PL_stack_base + POPMARK;
3039                 else
3040                     (void)POPMARK;
3041                 RETURN;
3042             }
3043             SvGETMAGIC(sv);
3044             if (SvROK(sv)) {
3045                 if (SvAMAGIC(sv)) {
3046                     sv = amagic_deref_call(sv, to_cv_amg);
3047                     /* Don't SPAGAIN here.  */
3048                 }
3049             }
3050             else {
3051                 const char *sym;
3052                 STRLEN len;
3053                 if (!SvOK(sv))
3054                     DIE(aTHX_ PL_no_usym, "a subroutine");
3055                 sym = SvPV_nomg_const(sv, len);
3056                 if (PL_op->op_private & HINT_STRICT_REFS)
3057                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3058                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3059                 break;
3060             }
3061             cv = MUTABLE_CV(SvRV(sv));
3062             if (SvTYPE(cv) == SVt_PVCV)
3063                 break;
3064             /* FALLTHROUGH */
3065         case SVt_PVHV:
3066         case SVt_PVAV:
3067             DIE(aTHX_ "Not a CODE reference");
3068             /* This is the second most common case:  */
3069         case SVt_PVCV:
3070             cv = MUTABLE_CV(sv);
3071             break;
3072         }
3073     }
3074
3075     ENTER;
3076
3077   retry:
3078     if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
3079         DIE(aTHX_ "Closure prototype called");
3080     if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
3081         GV* autogv;
3082         SV* sub_name;
3083
3084         /* anonymous or undef'd function leaves us no recourse */
3085         if (CvLEXICAL(cv) && CvHASGV(cv))
3086             DIE(aTHX_ "Undefined subroutine &%"SVf" called",
3087                        SVfARG(cv_name(cv, NULL, 0)));
3088         if (CvANON(cv) || !CvHASGV(cv)) {
3089             DIE(aTHX_ "Undefined subroutine called");
3090         }
3091
3092         /* autoloaded stub? */
3093         if (cv != GvCV(gv = CvGV(cv))) {
3094             cv = GvCV(gv);
3095         }
3096         /* should call AUTOLOAD now? */
3097         else {
3098           try_autoload:
3099             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3100                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
3101             {
3102                 cv = GvCV(autogv);
3103             }
3104             else {
3105                sorry:
3106                 sub_name = sv_newmortal();
3107                 gv_efullname3(sub_name, gv, NULL);
3108                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
3109             }
3110         }
3111         if (!cv)
3112             goto sorry;
3113         goto retry;
3114     }
3115
3116     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3117             && !CvNODEBUG(cv)))
3118     {
3119          Perl_get_db_sub(aTHX_ &sv, cv);
3120          if (CvISXSUB(cv))
3121              PL_curcopdb = PL_curcop;
3122          if (CvLVALUE(cv)) {
3123              /* check for lsub that handles lvalue subroutines */
3124              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
3125              /* if lsub not found then fall back to DB::sub */
3126              if (!cv) cv = GvCV(PL_DBsub);
3127          } else {
3128              cv = GvCV(PL_DBsub);
3129          }
3130
3131         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3132             DIE(aTHX_ "No DB::sub routine defined");
3133     }
3134
3135     gimme = GIMME_V;
3136
3137     if (!(CvISXSUB(cv))) {
3138         /* This path taken at least 75% of the time   */
3139         dMARK;
3140         PADLIST * const padlist = CvPADLIST(cv);
3141         I32 depth;
3142
3143         PUSHBLOCK(cx, CXt_SUB, MARK);
3144         PUSHSUB(cx);
3145         cx->blk_sub.retop = PL_op->op_next;
3146         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3147             PERL_STACK_OVERFLOW_CHECK();
3148             pad_push(padlist, depth);
3149         }
3150         SAVECOMPPAD();
3151         PAD_SET_CUR_NOSAVE(padlist, depth);
3152         if (LIKELY(hasargs)) {
3153             AV *const av = MUTABLE_AV(PAD_SVl(0));
3154             SSize_t items;
3155             AV **defavp;
3156
3157             if (UNLIKELY(AvREAL(av))) {
3158                 /* @_ is normally not REAL--this should only ever
3159                  * happen when DB::sub() calls things that modify @_ */
3160                 av_clear(av);
3161                 AvREAL_off(av);
3162                 AvREIFY_on(av);
3163             }
3164             defavp = &GvAV(PL_defgv);
3165             cx->blk_sub.savearray = *defavp;
3166             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
3167             CX_CURPAD_SAVE(cx->blk_sub);
3168             cx->blk_sub.argarray = av;
3169             items = SP - MARK;
3170
3171             if (UNLIKELY(items - 1 > AvMAX(av))) {
3172                 SV **ary = AvALLOC(av);
3173                 AvMAX(av) = items - 1;
3174                 Renew(ary, items, SV*);
3175                 AvALLOC(av) = ary;
3176                 AvARRAY(av) = ary;
3177             }
3178
3179             Copy(MARK+1,AvARRAY(av),items,SV*);
3180             AvFILLp(av) = items - 1;
3181         
3182             MARK = AvARRAY(av);
3183             while (items--) {
3184                 if (*MARK)
3185                 {
3186                     if (SvPADTMP(*MARK)) {
3187                         *MARK = sv_mortalcopy(*MARK);
3188                     }
3189                     SvTEMP_off(*MARK);
3190                 }
3191                 MARK++;
3192             }
3193         }
3194         SAVETMPS;
3195         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3196             !CvLVALUE(cv)))
3197             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3198         /* warning must come *after* we fully set up the context
3199          * stuff so that __WARN__ handlers can safely dounwind()
3200          * if they want to
3201          */
3202         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
3203                 && ckWARN(WARN_RECURSION)
3204                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
3205             sub_crush_depth(cv);
3206         RETURNOP(CvSTART(cv));
3207     }
3208     else {
3209         SSize_t markix = TOPMARK;
3210
3211         SAVETMPS;
3212         PUTBACK;
3213
3214         if (UNLIKELY(((PL_op->op_private
3215                & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3216              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3217             !CvLVALUE(cv)))
3218             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3219
3220         if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3221             /* Need to copy @_ to stack. Alternative may be to
3222              * switch stack to @_, and copy return values
3223              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3224             AV * const av = GvAV(PL_defgv);
3225             const SSize_t items = AvFILL(av) + 1;
3226
3227             if (items) {
3228                 SSize_t i = 0;
3229                 const bool m = cBOOL(SvRMAGICAL(av));
3230                 /* Mark is at the end of the stack. */
3231                 EXTEND(SP, items);
3232                 for (; i < items; ++i)
3233                 {
3234                     SV *sv;
3235                     if (m) {
3236                         SV ** const svp = av_fetch(av, i, 0);
3237                         sv = svp ? *svp : NULL;
3238                     }
3239                     else sv = AvARRAY(av)[i];
3240                     if (sv) SP[i+1] = sv;
3241                     else {
3242                         SP[i+1] = newSVavdefelem(av, i, 1);
3243                     }
3244                 }
3245                 SP += items;
3246                 PUTBACK ;               
3247             }
3248         }
3249         else {
3250             SV **mark = PL_stack_base + markix;
3251             SSize_t items = SP - mark;
3252             while (items--) {
3253                 mark++;
3254                 if (*mark && SvPADTMP(*mark)) {
3255                     *mark = sv_mortalcopy(*mark);
3256                 }
3257             }
3258         }
3259         /* We assume first XSUB in &DB::sub is the called one. */
3260         if (UNLIKELY(PL_curcopdb)) {
3261             SAVEVPTR(PL_curcop);
3262             PL_curcop = PL_curcopdb;
3263             PL_curcopdb = NULL;
3264         }
3265         /* Do we need to open block here? XXXX */
3266
3267         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3268         assert(CvXSUB(cv));
3269         CvXSUB(cv)(aTHX_ cv);
3270
3271         /* Enforce some sanity in scalar context. */
3272         if (gimme == G_SCALAR) {
3273             SV **svp = PL_stack_base + markix + 1;
3274             if (svp != PL_stack_sp) {
3275                 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3276                 PL_stack_sp = svp;
3277             }
3278         }
3279         LEAVE;
3280         return NORMAL;
3281     }
3282 }
3283
3284 void
3285 Perl_sub_crush_depth(pTHX_ CV *cv)
3286 {
3287     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3288
3289     if (CvANON(cv))
3290         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3291     else {
3292         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3293                     SVfARG(cv_name(cv,NULL,0)));
3294     }
3295 }
3296
3297 PP(pp_aelem)
3298 {
3299     dSP;
3300     SV** svp;
3301     SV* const elemsv = POPs;
3302     IV elem = SvIV(elemsv);
3303     AV *const av = MUTABLE_AV(POPs);
3304     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3305     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3306     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3307     bool preeminent = TRUE;
3308     SV *sv;
3309
3310     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
3311         Perl_warner(aTHX_ packWARN(WARN_MISC),
3312                     "Use of reference \"%"SVf"\" as array index",
3313                     SVfARG(elemsv));
3314     if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
3315         RETPUSHUNDEF;
3316
3317     if (UNLIKELY(localizing)) {
3318         MAGIC *mg;
3319         HV *stash;
3320
3321         /* If we can determine whether the element exist,
3322          * Try to preserve the existenceness of a tied array
3323          * element by using EXISTS and DELETE if possible.
3324          * Fallback to FETCH and STORE otherwise. */
3325         if (SvCANEXISTDELETE(av))
3326             preeminent = av_exists(av, elem);
3327     }
3328
3329     svp = av_fetch(av, elem, lval && !defer);
3330     if (lval) {
3331 #ifdef PERL_MALLOC_WRAP
3332          if (SvUOK(elemsv)) {
3333               const UV uv = SvUV(elemsv);
3334               elem = uv > IV_MAX ? IV_MAX : uv;
3335          }
3336          else if (SvNOK(elemsv))
3337               elem = (IV)SvNV(elemsv);
3338          if (elem > 0) {
3339               static const char oom_array_extend[] =
3340                 "Out of memory during array extend"; /* Duplicated in av.c */
3341               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3342          }
3343 #endif
3344         if (!svp || !*svp) {
3345             IV len;
3346             if (!defer)
3347                 DIE(aTHX_ PL_no_aelem, elem);
3348             len = av_tindex(av);
3349             mPUSHs(newSVavdefelem(av,
3350             /* Resolve a negative index now, unless it points before the
3351                beginning of the array, in which case record it for error
3352                reporting in magic_setdefelem. */
3353                 elem < 0 && len + elem >= 0 ? len + elem : elem,
3354                 1));
3355             RETURN;
3356         }
3357         if (UNLIKELY(localizing)) {
3358             if (preeminent)
3359                 save_aelem(av, elem, svp);
3360             else
3361                 SAVEADELETE(av, elem);
3362         }
3363         else if (PL_op->op_private & OPpDEREF) {
3364             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3365             RETURN;
3366         }
3367     }
3368     sv = (svp ? *svp : &PL_sv_undef);
3369     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3370         mg_get(sv);
3371     PUSHs(sv);
3372     RETURN;
3373 }
3374
3375 SV*
3376 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3377 {
3378     PERL_ARGS_ASSERT_VIVIFY_REF;
3379
3380     SvGETMAGIC(sv);
3381     if (!SvOK(sv)) {
3382         if (SvREADONLY(sv))
3383             Perl_croak_no_modify();
3384         prepare_SV_for_RV(sv);
3385         switch (to_what) {
3386         case OPpDEREF_SV:
3387             SvRV_set(sv, newSV(0));
3388             break;
3389         case OPpDEREF_AV:
3390             SvRV_set(sv, MUTABLE_SV(newAV()));
3391             break;
3392         case OPpDEREF_HV:
3393             SvRV_set(sv, MUTABLE_SV(newHV()));
3394             break;
3395         }
3396         SvROK_on(sv);
3397         SvSETMAGIC(sv);
3398         SvGETMAGIC(sv);
3399     }
3400     if (SvGMAGICAL(sv)) {
3401         /* copy the sv without magic to prevent magic from being
3402            executed twice */
3403         SV* msv = sv_newmortal();
3404         sv_setsv_nomg(msv, sv);
3405         return msv;
3406     }
3407     return sv;
3408 }
3409
3410 PERL_STATIC_INLINE HV *
3411 S_opmethod_stash(pTHX_ SV* meth)
3412 {
3413     SV* ob;
3414     HV* stash;
3415
3416     SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
3417         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3418                             "package or object reference", SVfARG(meth)),
3419            (SV *)NULL)
3420         : *(PL_stack_base + TOPMARK + 1);
3421
3422     PERL_ARGS_ASSERT_OPMETHOD_STASH;
3423
3424     if (UNLIKELY(!sv))
3425        undefined:
3426         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3427                    SVfARG(meth));
3428
3429     if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3430     else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3431         stash = gv_stashsv(sv, GV_CACHE_ONLY);
3432         if (stash) return stash;
3433     }
3434
3435     if (SvROK(sv))
3436         ob = MUTABLE_SV(SvRV(sv));
3437     else if (!SvOK(sv)) goto undefined;
3438     else if (isGV_with_GP(sv)) {
3439         if (!GvIO(sv))
3440             Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3441                              "without a package or object reference",
3442                               SVfARG(meth));
3443         ob = sv;
3444         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3445             assert(!LvTARGLEN(ob));
3446             ob = LvTARG(ob);
3447             assert(ob);
3448         }
3449         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3450     }
3451     else {
3452         /* this isn't a reference */
3453         GV* iogv;
3454         STRLEN packlen;
3455         const char * const packname = SvPV_nomg_const(sv, packlen);
3456         const U32 packname_utf8 = SvUTF8(sv);
3457         stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3458         if (stash) return stash;
3459
3460         if (!(iogv = gv_fetchpvn_flags(
3461                 packname, packlen, packname_utf8, SVt_PVIO
3462              )) ||
3463             !(ob=MUTABLE_SV(GvIO(iogv))))
3464         {
3465             /* this isn't the name of a filehandle either */
3466             if (!packlen)
3467             {
3468                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3469                                  "without a package or object reference",
3470                                   SVfARG(meth));
3471             }
3472             /* assume it's a package name */
3473             stash = gv_stashpvn(packname, packlen, packname_utf8);
3474             if (stash) return stash;
3475             else return MUTABLE_HV(sv);
3476         }
3477         /* it _is_ a filehandle name -- replace with a reference */
3478         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3479     }
3480
3481     /* if we got here, ob should be an object or a glob */
3482     if (!ob || !(SvOBJECT(ob)
3483                  || (isGV_with_GP(ob)
3484                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3485                      && SvOBJECT(ob))))
3486     {
3487         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3488                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3489                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3490                                         : meth));
3491     }
3492
3493     return SvSTASH(ob);
3494 }
3495
3496 PP(pp_method)
3497 {
3498     dSP;
3499     GV* gv;
3500     HV* stash;
3501     SV* const meth = TOPs;
3502
3503     if (SvROK(meth)) {
3504         SV* const rmeth = SvRV(meth);
3505         if (SvTYPE(rmeth) == SVt_PVCV) {
3506             SETs(rmeth);
3507             RETURN;
3508         }
3509     }
3510
3511     stash = opmethod_stash(meth);
3512
3513     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3514     assert(gv);
3515
3516     SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3517     RETURN;
3518 }
3519
3520 #define METHOD_CHECK_CACHE(stash,cache,meth)                            \
3521     const HE* const he = hv_fetch_ent(cache, meth, 0, 0);               \
3522     if (he) {                                                           \
3523         gv = MUTABLE_GV(HeVAL(he));                                     \
3524         if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv)        \
3525              == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))     \
3526         {                                                               \
3527             XPUSHs(MUTABLE_SV(GvCV(gv)));                               \
3528             RETURN;                                                     \
3529         }                                                               \
3530     }                                                                   \
3531
3532 PP(pp_method_named)
3533 {
3534     dSP;
3535     GV* gv;
3536     SV* const meth = cMETHOPx_meth(PL_op);
3537     HV* const stash = opmethod_stash(meth);
3538
3539     if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
3540         METHOD_CHECK_CACHE(stash, stash, meth);
3541     }
3542
3543     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3544     assert(gv);
3545
3546     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3547     RETURN;
3548 }
3549
3550 PP(pp_method_super)
3551 {
3552     dSP;
3553     GV* gv;
3554     HV* cache;
3555     SV* const meth = cMETHOPx_meth(PL_op);
3556     HV* const stash = CopSTASH(PL_curcop);
3557     /* Actually, SUPER doesn't need real object's (or class') stash at all,
3558      * as it uses CopSTASH. However, we must ensure that object(class) is
3559      * correct (this check is done by S_opmethod_stash) */
3560     opmethod_stash(meth);
3561
3562     if ((cache = HvMROMETA(stash)->super)) {
3563         METHOD_CHECK_CACHE(stash, cache, meth);
3564     }
3565
3566     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3567     assert(gv);
3568
3569     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3570     RETURN;
3571 }
3572
3573 PP(pp_method_redir)
3574 {
3575     dSP;
3576     GV* gv;
3577     SV* const meth = cMETHOPx_meth(PL_op);
3578     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3579     opmethod_stash(meth); /* not used but needed for error checks */
3580
3581     if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3582     else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3583
3584     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3585     assert(gv);
3586
3587     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3588     RETURN;
3589 }
3590
3591 PP(pp_method_redir_super)
3592 {
3593     dSP;
3594     GV* gv;
3595     HV* cache;
3596     SV* const meth = cMETHOPx_meth(PL_op);
3597     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3598     opmethod_stash(meth); /* not used but needed for error checks */
3599
3600     if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3601     else if ((cache = HvMROMETA(stash)->super)) {
3602          METHOD_CHECK_CACHE(stash, cache, meth);
3603     }
3604
3605     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3606     assert(gv);
3607
3608     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3609     RETURN;
3610 }
3611
3612 /*
3613  * ex: set ts=8 sts=4 sw=4 et:
3614  */