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