Update Filter::Util::Call to CPAN version 1.58
[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 + CX_CUR()->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) { /* {or,and,dor}assign */
134         SV * const temp = left;
135         left = right; right = temp;
136     }
137     assert(TAINTING_get || !TAINT_get);
138     if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
139         TAINT_NOT;
140     if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
141         /* *foo =\&bar */
142         SV * const cv = SvRV(right);
143         const U32 cv_type = SvTYPE(cv);
144         const bool is_gv = isGV_with_GP(left);
145         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
146
147         if (!got_coderef) {
148             assert(SvROK(cv));
149         }
150
151         /* Can do the optimisation if left (LVALUE) is not a typeglob,
152            right (RVALUE) is a reference to something, and we're in void
153            context. */
154         if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
155             /* Is the target symbol table currently empty?  */
156             GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
157             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
158                 /* Good. Create a new proxy constant subroutine in the target.
159                    The gv becomes a(nother) reference to the constant.  */
160                 SV *const value = SvRV(cv);
161
162                 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
163                 SvPCS_IMPORTED_on(gv);
164                 SvRV_set(gv, value);
165                 SvREFCNT_inc_simple_void(value);
166                 SETs(left);
167                 RETURN;
168             }
169         }
170
171         /* Need to fix things up.  */
172         if (!is_gv) {
173             /* Need to fix GV.  */
174             left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
175         }
176
177         if (!got_coderef) {
178             /* We've been returned a constant rather than a full subroutine,
179                but they expect a subroutine reference to apply.  */
180             if (SvROK(cv)) {
181                 ENTER_with_name("sassign_coderef");
182                 SvREFCNT_inc_void(SvRV(cv));
183                 /* newCONSTSUB takes a reference count on the passed in SV
184                    from us.  We set the name to NULL, otherwise we get into
185                    all sorts of fun as the reference to our new sub is
186                    donated to the GV that we're about to assign to.
187                 */
188                 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
189                                                       SvRV(cv))));
190                 SvREFCNT_dec_NN(cv);
191                 LEAVE_with_name("sassign_coderef");
192             } else {
193                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
194                    is that
195                    First:   ops for \&{"BONK"}; return us the constant in the
196                             symbol table
197                    Second:  ops for *{"BONK"} cause that symbol table entry
198                             (and our reference to it) to be upgraded from RV
199                             to typeblob)
200                    Thirdly: We get here. cv is actually PVGV now, and its
201                             GvCV() is actually the subroutine we're looking for
202
203                    So change the reference so that it points to the subroutine
204                    of that typeglob, as that's what they were after all along.
205                 */
206                 GV *const upgraded = MUTABLE_GV(cv);
207                 CV *const source = GvCV(upgraded);
208
209                 assert(source);
210                 assert(CvFLAGS(source) & CVf_CONST);
211
212                 SvREFCNT_inc_simple_void_NN(source);
213                 SvREFCNT_dec_NN(upgraded);
214                 SvRV_set(right, MUTABLE_SV(source));
215             }
216         }
217
218     }
219     if (
220       UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
221       (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
222     )
223         Perl_warner(aTHX_
224             packWARN(WARN_MISC), "Useless assignment to a temporary"
225         );
226     SvSetMagicSV(left, right);
227     SETs(left);
228     RETURN;
229 }
230
231 PP(pp_cond_expr)
232 {
233     dSP;
234     SV *sv;
235
236     PERL_ASYNC_CHECK();
237     sv = POPs;
238     RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
239 }
240
241 PP(pp_unstack)
242 {
243     PERL_CONTEXT *cx;
244     PERL_ASYNC_CHECK();
245     TAINT_NOT;          /* Each statement is presumed innocent */
246     cx  = CX_CUR();
247     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
248     FREETMPS;
249     if (!(PL_op->op_flags & OPf_SPECIAL)) {
250         assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
251         CX_LEAVE_SCOPE(cx);
252     }
253     return NORMAL;
254 }
255
256 PP(pp_concat)
257 {
258   dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
259   {
260     dPOPTOPssrl;
261     bool lbyte;
262     STRLEN rlen;
263     const char *rpv = NULL;
264     bool rbyte = FALSE;
265     bool rcopied = FALSE;
266
267     if (TARG == right && right != left) { /* $r = $l.$r */
268         rpv = SvPV_nomg_const(right, rlen);
269         rbyte = !DO_UTF8(right);
270         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
271         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
272         rcopied = TRUE;
273     }
274
275     if (TARG != left) { /* not $l .= $r */
276         STRLEN llen;
277         const char* const lpv = SvPV_nomg_const(left, llen);
278         lbyte = !DO_UTF8(left);
279         sv_setpvn(TARG, lpv, llen);
280         if (!lbyte)
281             SvUTF8_on(TARG);
282         else
283             SvUTF8_off(TARG);
284     }
285     else { /* $l .= $r   and   left == TARG */
286         if (!SvOK(left)) {
287             if ((left == right                          /* $l .= $l */
288                  || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
289                 && ckWARN(WARN_UNINITIALIZED)
290                 )
291                 report_uninit(left);
292             SvPVCLEAR(left);
293         }
294         else {
295             SvPV_force_nomg_nolen(left);
296         }
297         lbyte = !DO_UTF8(left);
298         if (IN_BYTES)
299             SvUTF8_off(left);
300     }
301
302     if (!rcopied) {
303         rpv = SvPV_nomg_const(right, rlen);
304         rbyte = !DO_UTF8(right);
305     }
306     if (lbyte != rbyte) {
307         if (lbyte)
308             sv_utf8_upgrade_nomg(TARG);
309         else {
310             if (!rcopied)
311                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
312             sv_utf8_upgrade_nomg(right);
313             rpv = SvPV_nomg_const(right, rlen);
314         }
315     }
316     sv_catpvn_nomg(TARG, rpv, rlen);
317
318     SETTARG;
319     RETURN;
320   }
321 }
322
323
324 /* pp_multiconcat()
325
326 Concatenate one or more args, possibly interleaved with constant string
327 segments. The result may be assigned to, or appended to, a variable or
328 expression.
329
330 Several op_flags and/or op_private bits indicate what the target is, and
331 whether it's appended to. Valid permutations are:
332
333     -                                  (PADTMP) = (A.B.C....)
334     OPpTARGET_MY                       $lex     = (A.B.C....)
335     OPpTARGET_MY,OPpLVAL_INTRO         my $lex  = (A.B.C....)
336     OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex    .= (A.B.C....)
337     OPf_STACKED                        expr     = (A.B.C....)
338     OPf_STACKED,OPpMULTICONCAT_APPEND  expr    .= (A.B.C....)
339
340 Other combinations like (A.B).(C.D) are not optimised into a multiconcat
341 op, as it's too hard to get the correct ordering of ties, overload etc.
342
343 In addition:
344
345     OPpMULTICONCAT_FAKE:       not a real concat, instead an optimised
346                                sprintf "...%s...". Don't call '.'
347                                overloading: only use '""' overloading.
348
349     OPpMULTICONCAT_STRINGIFY:  (for Deparse's benefit) the RHS was of the
350                                form "...$a...$b..." rather than
351                                "..." . $a . "..." . $b . "..."
352
353 An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
354 defined with PERL_MULTICONCAT_IX_FOO constants, where:
355
356
357     FOO       index description
358     --------  ----- ----------------------------------
359     NARGS     0     number of arguments
360     PLAIN_PV  1     non-utf8 constant string
361     PLAIN_LEN 2     non-utf8 constant string length
362     UTF8_PV   3     utf8 constant string
363     UTF8_LEN  4     utf8 constant string length
364     LENGTHS   5     first of nargs+1 const segment lengths
365
366 The idea is that a general string concatenation will have a fixed (known
367 at compile time) number of variable args, interspersed with constant
368 strings, e.g. "a=$a b=$b\n"
369
370 All the constant string segments "a=", " b=" and "\n" are stored as a
371 single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
372 with a series of segment lengths: e.g. 2,3,1. In the case where the
373 constant string is plain but has a different utf8 representation, both
374 variants are stored, and two sets of (nargs+1) segments lengths are stored
375 in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
376
377 A segment length of -1 indicates that there is no constant string at that
378 point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
379 have differing overloading behaviour.
380
381 */
382
383 PP(pp_multiconcat)
384 {
385     dSP;
386     SV *targ;                /* The SV to be assigned or appended to */
387     SV *dsv;                 /* the SV to concat args to (often == targ) */
388     char *dsv_pv;            /* where within SvPVX(dsv) we're writing to */
389     STRLEN targ_len;         /* SvCUR(targ) */
390     SV **toparg;             /* the highest arg position on the stack */
391     UNOP_AUX_item *aux;      /* PL_op->op_aux buffer */
392     UNOP_AUX_item *const_lens; /* the segment length array part of aux */
393     const char *const_pv;    /* the current segment of the const string buf */
394     SSize_t nargs;           /* how many args were expected */
395     SSize_t stack_adj;       /* how much to adjust SP on return */
396     STRLEN grow;             /* final size of destination string (dsv) */
397     UV targ_count;           /* how many times targ has appeared on the RHS */
398     bool is_append;          /* OPpMULTICONCAT_APPEND flag is set */
399     bool slow_concat;        /* args too complex for quick concat */
400     U32  dst_utf8;           /* the result will be utf8 (indicate this with
401                                 SVf_UTF8 in a U32, rather than using bool,
402                                 for ease of testing and setting) */
403     /* for each arg, holds the result of an SvPV() call */
404     struct multiconcat_svpv {
405         char          *pv;
406         SSize_t       len;
407     }
408         *targ_chain,         /* chain of slots where targ has appeared on RHS */
409         *svpv_p,             /* ptr for looping through svpv_buf */
410         *svpv_base,          /* first slot (may be greater than svpv_buf), */
411         *svpv_end,           /* and slot after highest result so far, of: */
412         svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
413
414     aux   = cUNOP_AUXx(PL_op)->op_aux;
415     stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
416     is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
417
418     /* get targ from the stack or pad */
419
420     if (PL_op->op_flags & OPf_STACKED) {
421         if (is_append) {
422             /* for 'expr .= ...', expr is the bottom item on the stack */
423             targ = SP[-nargs];
424             stack_adj++;
425         }
426         else
427             /* for 'expr = ...', expr is the top item on the stack */
428             targ = POPs;
429     }
430     else {
431         SV **svp = &(PAD_SVl(PL_op->op_targ));
432         targ = *svp;
433         if (PL_op->op_private & OPpLVAL_INTRO) {
434             assert(PL_op->op_private & OPpTARGET_MY);
435             save_clearsv(svp);
436         }
437         if (!nargs)
438             /* $lex .= "const" doesn't cause anything to be pushed */
439             EXTEND(SP,1);
440     }
441
442     toparg = SP;
443     SP -= (nargs - 1);
444     dsv           = targ; /* Set the destination for all concats. This is
445                              initially targ; later on, dsv may be switched
446                              to point to a TEMP SV if overloading is
447                              encountered.  */
448     grow          = 1;    /* allow for '\0' at minimum */
449     targ_count    = 0;
450     targ_chain    = NULL;
451     targ_len      = 0;
452     svpv_end      = svpv_buf;
453                     /* only utf8 variants of the const strings? */
454     dst_utf8      = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
455
456
457     /* --------------------------------------------------------------
458      * Phase 1:
459      *
460      * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
461      * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
462      *
463      * utf8 is indicated by storing a negative length.
464      *
465      * Where an arg is actually targ, the stringification is deferred:
466      * the length is set to 0, and the slot is added to targ_chain.
467      *
468      * If an overloaded arg is found, the loop is abandoned at that point,
469      * and dsv is set to an SvTEMP SV where the results-so-far will be
470      * accumulated.
471      */
472
473     for (; SP <= toparg; SP++, svpv_end++) {
474         bool simple_flags;
475         U32 utf8;
476         STRLEN len;
477         SV *sv;
478
479         assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
480
481         sv = *SP;
482         simple_flags = (SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK;
483
484         /* this if/else chain is arranged so that common/simple cases
485          * take few conditionals */
486
487         if (LIKELY(simple_flags && (sv != targ))) {
488             /* common case: sv is a simple PV and not the targ */
489             svpv_end->pv  = SvPVX(sv);
490             len           = SvCUR(sv);
491         }
492         else if (simple_flags) {
493             /* sv is targ (but can't be magic or overloaded).
494              * Delay storing PV pointer; instead, add slot to targ_chain
495              * so it can be populated later, after targ has been grown and
496              * we know its final SvPVX() address.
497              */
498           targ_on_rhs:
499             svpv_end->len = 0; /* zerojng here means we can skip
500                                   updating later if targ_len == 0 */
501             svpv_end->pv  = (char*)targ_chain;
502             targ_chain    = svpv_end;
503             targ_count++;
504             continue;
505         }
506         else {
507             if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK))) {
508                 /* its got magic, is tied, and/or is overloaded */
509                 SvGETMAGIC(sv);
510
511                 if (UNLIKELY(SvAMAGIC(sv))
512                     && !(PL_op->op_private & OPpMULTICONCAT_FAKE))
513                 {
514                     /* One of the RHS args is overloaded. Abandon stringifying
515                      * the args at this point, then in the concat loop later
516                      * on, concat the plain args stringified so far into a
517                      * TEMP SV. At the end of this function the remaining
518                      * args (including the current one) will be handled
519                      * specially, using overload calls.
520                      * FAKE implies an optimised sprintf which doesn't use
521                      * concat overloading, only "" overloading.
522                      */
523
524                     if (   svpv_end == svpv_buf + 1
525                            /* no const string segments */
526                         && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize     == -1
527                         && aux[PERL_MULTICONCAT_IX_LENGTHS + 1].ssize == -1
528                     ) {
529                         /* special case: if the overloaded sv is the
530                          * second arg in the concat chain, stop at the
531                          * first arg rather than this, so that
532                          *
533                          *   $arg1 . $arg2
534                          *
535                          * invokes overloading as
536                          *
537                          *    concat($arg2, $arg1, 1)
538                          *
539                          * rather than
540                          *
541                          *    concat($arg2, "$arg1", 1)
542                          *
543                          * This means that if for example arg1 is a ref,
544                          * it gets passed as-is to the concat method
545                          * rather than a stringified copy. If it's not the
546                          * first arg, it doesn't matter, as in $arg0 .
547                          * $arg1 .  $arg2, where the result of ($arg0 .
548                          * $arg1) will already be a string.
549                          * THis isn't perfect: we'll have already
550                          * done SvPV($arg1) on the previous iteration;
551                          * and are now throwing away that result and
552                          * hoping arg1 hasn;t been affected.
553                          */
554                         svpv_end--;
555                         SP--;
556                     }
557
558                   setup_overload:
559                     dsv = newSVpvn_flags("", 0, SVs_TEMP);
560
561                     if (targ_chain) {
562                         /* Get the string value of targ and populate any
563                          * RHS slots which use it */
564                         char *pv = SvPV_nomg(targ, len);
565                         dst_utf8 |= (SvFLAGS(targ) & SVf_UTF8);
566                         grow += len * targ_count;
567                         do {
568                             struct multiconcat_svpv *p = targ_chain;
569                             targ_chain = (struct multiconcat_svpv *)(p->pv);
570                             p->pv  = pv;
571                             p->len = len;
572                         } while (targ_chain);
573                     }
574                     else if (is_append)
575                         SvGETMAGIC(targ);
576
577                     goto phase3;
578                 }
579
580                 if (SvFLAGS(sv) & SVs_RMG) {
581                     /* probably tied; copy it to guarantee separate values
582                      * each time it's used, e.g. "-$tied-$tied-$tied-",
583                      * since FETCH() isn't necessarily idempotent */
584                     SV *nsv = newSV(0);
585                     sv_setsv_flags(nsv, sv, SV_NOSTEAL);
586                     sv_2mortal(nsv);
587                     if (   sv == targ
588                         && is_append
589                         && nargs == 1
590                         /* no const string segments */
591                         && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize   == -1
592                         && aux[PERL_MULTICONCAT_IX_LENGTHS+1].ssize == -1)
593                     {
594                         /* special-case $tied .= $tied.
595                          *
596                          * For something like
597                          *    sub FETCH { $i++ }
598                          * then
599                          *    $tied .= $tied . $tied . $tied;
600                          * will STORE "4123"
601                          * while
602                          *    $tied .= $tied
603                          * will STORE "12"
604                          *
605                          * i.e. for a single mutator concat, the LHS is
606                          * retrieved first; in all other cases it is
607                          * retrieved last. Whether this is sane behaviour
608                          * is open to debate; but for now, multiconcat (as
609                          * it is an optimisation) tries to reproduce
610                          * existing behaviour.
611                          */
612                         sv_catsv(nsv, sv);
613                         sv_setsv(sv,nsv);
614                         SP++;
615                         goto phase7; /* just return targ as-is */
616                     }
617
618                     sv = nsv;
619                 }
620             }
621
622             if (sv == targ) {
623                 /* must warn for each RH usage of targ, except that
624                  * we will later get one warning when doing
625                  * SvPV_force(targ), *except* on '.=' */
626                 if (   !SvOK(sv)
627                     && (targ_chain || is_append)
628                     && ckWARN(WARN_UNINITIALIZED)
629                 )
630                     report_uninit(sv);
631                 goto targ_on_rhs;
632             }
633
634             /* stringify general SV */
635             svpv_end->pv = sv_2pv_flags(sv, &len, 0);
636         }
637
638         utf8 = (SvFLAGS(sv) & SVf_UTF8);
639         dst_utf8   |= utf8;
640         ASSUME(len < SSize_t_MAX);
641         svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
642         grow += len;
643     }
644
645     /* --------------------------------------------------------------
646      * Phase 2:
647      *
648      * Stringify targ:
649      *
650      * if targ appears on the RHS or is appended to, force stringify it;
651      * otherwise set it to "". Then set targ_len.
652      */
653
654     if (is_append) {
655         if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK))) {
656             SvGETMAGIC(targ); /* must do before SvAMAGIC() check */
657             if (UNLIKELY(SvAMAGIC(targ))) {
658                 /* $overloaded .= ....;
659                  * accumulate RHS in a temp SV rather than targ,
660                  * then append tmp to targ at the end using overload
661                  */
662                 assert(!targ_chain);
663                 dsv = newSVpvn_flags("", 0, SVs_TEMP);
664
665                 if (   svpv_end == svpv_buf + 1
666                        /* no const string segments */
667                     && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1
668                 ) {
669                     /* special case $overloaded .= $arg1:
670                      * avoid stringifying $arg1.
671                      * Similar to the $arg1 . $arg2 case in phase1
672                      */
673                     svpv_end--;
674                     SP--;
675                 }
676
677                 goto phase3;
678             }
679         }
680
681         if (SvOK(targ)) {
682             U32 targ_utf8;
683           stringify_targ:
684             SvPV_force_nomg_nolen(targ);
685             targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
686             if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
687                  if (LIKELY(!IN_BYTES))
688                     sv_utf8_upgrade_nomg(targ);
689             }
690             else
691                 dst_utf8 |= targ_utf8;
692
693             targ_len = SvCUR(targ);
694             grow += targ_len * (targ_count + is_append);
695             goto phase3;
696         }
697     }
698     else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
699         /* Assigning to some weird LHS type. Don't force the LHS to be an
700          * empty string; instead, do things 'long hand' by using the
701          * overload code path, which concats to a TEMP sv and does
702          * sv_catsv() calls rather than COPY()s. This ensures that even
703          * bizarre code like this doesn't break or crash:
704          *    *F = *F . *F.
705          * (which makes the 'F' typeglob an alias to the
706          * '*main::F*main::F' typeglob).
707          */
708         goto setup_overload;
709     }
710     else if (targ_chain) {
711         /* targ was found on RHS.
712          * We don't need the SvGETMAGIC() call and SvAMAGIC() test as
713          * both were already done earlier in the SvPV() loop; other
714          * than that we can share the same code with the append
715          * branch below.
716          * Note that this goto jumps directly into the SvOK() branch
717          * even if targ isn't SvOK(), to force an 'uninitialised'
718          * warning; e.g.
719          *   $undef .= ....           targ only on LHS: don't warn
720          *   $undef .= $undef ....    targ on RHS too:  warn
721          */
722         assert(!SvAMAGIC(targ));
723         goto stringify_targ;
724     }
725
726
727     /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
728      * those will be done later. */
729     assert(targ == dsv);
730     SV_CHECK_THINKFIRST_COW_DROP(targ);
731     SvUPGRADE(targ, SVt_PV);
732     SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
733     SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
734
735   phase3:
736
737     /* --------------------------------------------------------------
738      * Phase 3:
739      *
740      * UTF-8 tweaks and grow dsv:
741      *
742      * Now that we know the length and utf8-ness of both the targ and
743      * args, grow dsv to the size needed to accumulate all the args, based
744      * on whether targ appears on the RHS, whether we're appending, and
745      * whether any non-utf8 args expand in size if converted to utf8.
746      *
747      * For the latter, if dst_utf8 we scan non-utf8 args looking for
748      * variant chars, and adjust the svpv->len value of those args to the
749      * utf8 size and negate it to flag them. At the same time we un-negate
750      * the lens of any utf8 args since after this phase we no longer care
751      * whether an arg is utf8 or not.
752      *
753      * Finally, initialise const_lens and const_pv based on utf8ness.
754      * Note that there are 3 permutations:
755      *
756      * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
757      *   then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
758      *        aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
759      *   segment lengths.
760      *
761      * * If the string is fully utf8, e.g. "\x{100}", then
762      *   aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
763      *   one set of segment lengths.
764      *
765      * * If the string has different plain and utf8 representations
766      *   (e.g. "\x80"), then then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
767      *   holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
768      *   holds the utf8 rep, and there are 2 sets of segment lengths,
769      *   with the utf8 set following after the plain set.
770      *
771      * On entry to this section the (pv,len) pairs in svpv_buf have the
772      * following meanings:
773      *    (pv,  len) a plain string
774      *    (pv, -len) a utf8 string
775      *    (NULL,  0) left-most targ \ linked together R-to-L
776      *    (next,  0) other targ     / in targ_chain
777      */
778
779     /* turn off utf8 handling if 'use bytes' is in scope */
780     if (UNLIKELY(dst_utf8 && IN_BYTES)) {
781         dst_utf8 = 0;
782         SvUTF8_off(dsv);
783         /* undo all the negative lengths which flag utf8-ness */
784         for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
785             SSize_t len = svpv_p->len;
786             if (len < 0)
787                 svpv_p->len = -len;
788         }
789     }
790
791     /* grow += total of lengths of constant string segments */
792     {
793         SSize_t len;
794         len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
795                            : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
796         slow_concat = cBOOL(len);
797         grow += len;
798     }
799
800     const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
801
802     if (dst_utf8) {
803         const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
804         if (   aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
805             && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
806             /* separate sets of lengths for plain and utf8 */
807             const_lens += nargs + 1;
808
809         /* If the result is utf8 but some of the args aren't,
810          * calculate how much extra growth is needed for all the chars
811          * which will expand to two utf8 bytes.
812          * Also, if the growth is non-zero, negate the length to indicate
813          * that this this is a variant string. Conversely, un-negate the
814          * length on utf8 args (which was only needed to flag non-utf8
815          * args in this loop */
816         for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
817             char *p;
818             SSize_t len, l, extra;
819
820             len = svpv_p->len;
821             if (len <= 0) {
822                 svpv_p->len = -len;
823                 continue;
824             }
825
826             p = svpv_p->pv;
827             extra = 0;
828             l = len;
829             while (l--)
830                 extra += !UTF8_IS_INVARIANT(*p++);
831             if (UNLIKELY(extra)) {
832                 grow       += extra;
833                               /* -ve len indicates special handling */
834                 svpv_p->len = -(len + extra);
835                 slow_concat = TRUE;
836             }
837         }
838     }
839     else
840         const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
841
842     /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
843      * already have been dropped */
844     assert(!SvIsCOW(dsv));
845     dsv_pv = (SvLEN(dsv) < (grow) ? sv_grow(dsv,grow) : SvPVX(dsv));
846
847
848     /* --------------------------------------------------------------
849      * Phase 4:
850      *
851      * Now that dsv (which is probably targ) has been grown, we know the
852      * final address of the targ PVX, if needed. Preserve / move targ
853      * contents if appending or if targ appears on RHS.
854      *
855      * Also update svpv_buf slots in targ_chain.
856      *
857      * Don't bother with any of this if the target length is zero:
858      * targ_len is set to zero unless we're appending or targ appears on
859      * RHS.  And even if it is, we can optimise by skipping this chunk of
860      * code for zero targ_len. In the latter case, we don't need to update
861      * the slots in targ_chain with the (zero length) target string, since
862      * we set the len in such slots to 0 earlier, and since the Copy() is
863      * skipped on zero length, it doesn't matter what svpv_p->pv contains.
864      *
865      * On entry to this section the (pv,len) pairs in svpv_buf have the
866      * following meanings:
867      *    (pv,  len)         a pure-plain or utf8 string
868      *    (pv, -(len+extra)) a plain string which will expand by 'extra'
869      *                         bytes when converted to utf8
870      *    (NULL,  0)         left-most targ \ linked together R-to-L
871      *    (next,  0)         other targ     / in targ_chain
872      *
873      * On exit, the targ contents will have been moved to the
874      * earliest place they are needed (e.g. $x = "abc$x" will shift them
875      * 3 bytes, while $x .= ... will leave them at the beginning);
876      * and dst_pv will point to the location within SvPVX(dsv) where the
877      * next arg should be copied.
878      */
879
880     svpv_base = svpv_buf;
881
882     if (targ_len) {
883         struct multiconcat_svpv *tc_stop;
884         char *targ_pv = dsv_pv;
885
886         assert(targ == dsv);
887         assert(is_append || targ_count);
888
889         if (is_append) {
890             dsv_pv += targ_len;
891             tc_stop = NULL;
892         }
893         else {
894             /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
895              * Move the current contents of targ to the first
896              * position where it's needed, and use that as the src buffer
897              * for any further uses (such as the second RHS $t above).
898              * In calculating the first position, we need to sum the
899              * lengths of all consts and args before that.
900              */
901
902             UNOP_AUX_item *lens = const_lens;
903                                 /* length of first const string segment */
904             STRLEN offset       = lens->ssize > 0 ? lens->ssize : 0;
905
906             assert(targ_chain);
907             svpv_p = svpv_base;
908
909             for (;;) {
910                 SSize_t len;
911                 if (!svpv_p->pv)
912                     break; /* the first targ argument */
913                 /* add lengths of the next arg and const string segment */
914                 len = svpv_p->len;
915                 if (len < 0)  /* variant args have this */
916                     len = -len;
917                 offset += (STRLEN)len;
918                 len = (++lens)->ssize;
919                 offset += (len >= 0) ? (STRLEN)len : 0;
920                 if (!offset) {
921                     /* all args and consts so far are empty; update
922                      * the start position for the concat later */
923                     svpv_base++;
924                     const_lens++;
925                 }
926                 svpv_p++;
927                 assert(svpv_p < svpv_end);
928             }
929
930             if (offset) {
931                 targ_pv += offset;
932                 Move(dsv_pv, targ_pv, targ_len, char);
933                 /* a negative length implies don't Copy(), but do increment */
934                 svpv_p->len = -targ_len;
935                 slow_concat = TRUE;
936             }
937             else {
938                 /* skip the first targ copy */
939                 svpv_base++;
940                 const_lens++;
941                 dsv_pv += targ_len;
942             }
943
944             /* Don't populate the first targ slot in the loop below; it's
945              * either not used because we advanced svpv_base beyond it, or
946              * we already stored the special -targ_len value in it
947              */
948             tc_stop = svpv_p;
949         }
950
951         /* populate slots in svpv_buf representing targ on RHS */
952         while (targ_chain != tc_stop) {
953             struct multiconcat_svpv *p = targ_chain;
954             targ_chain = (struct multiconcat_svpv *)(p->pv);
955             p->pv  = targ_pv;
956             p->len = (SSize_t)targ_len;
957         }
958     }
959
960
961     /* --------------------------------------------------------------
962      * Phase 5:
963      *
964      * Append all the args in svpv_buf, plus the const strings, to dsv.
965      *
966      * On entry to this section the (pv,len) pairs in svpv_buf have the
967      * following meanings:
968      *    (pv,  len)         a pure-plain or utf8 string (which may be targ)
969      *    (pv, -(len+extra)) a plain string which will expand by 'extra'
970      *                         bytes when converted to utf8
971      *    (0,  -len)         left-most targ, whose content has already
972      *                         been copied. Just advance dsv_pv by len.
973      */
974
975     /* If there are no constant strings and no special case args
976      * (svpv_p->len < 0), use a simpler, more efficient concat loop
977      */
978     if (!slow_concat) {
979         for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
980             SSize_t len = svpv_p->len;
981             if (!len)
982                 continue;
983             Copy(svpv_p->pv, dsv_pv, len, char);
984             dsv_pv += len;
985         }
986         const_lens += (svpv_end - svpv_base + 1);
987     }
988     else {
989         /* Note that we iterate the loop nargs+1 times: to append nargs
990          * arguments and nargs+1 constant strings. For example, "-$a-$b-"
991          */
992         svpv_p = svpv_base - 1;
993
994         for (;;) {
995             SSize_t len = (const_lens++)->ssize;
996
997             /* append next const string segment */
998             if (len > 0) {
999                 Copy(const_pv, dsv_pv, len, char);
1000                 dsv_pv   += len;
1001                 const_pv += len;
1002             }
1003
1004             if (++svpv_p == svpv_end)
1005                 break;
1006
1007             /* append next arg */
1008             len = svpv_p->len;
1009
1010             if (LIKELY(len > 0)) {
1011                 Copy(svpv_p->pv, dsv_pv, len, char);
1012                 dsv_pv += len;
1013             }
1014             else if (UNLIKELY(len < 0)) {
1015                 /* negative length indicates two special cases */
1016                 const char *p = svpv_p->pv;
1017                 len = -len;
1018                 if (UNLIKELY(p)) {
1019                     /* copy plain-but-variant pv to a utf8 targ */
1020                     char * end_pv = dsv_pv + len;
1021                     assert(dst_utf8);
1022                     while (dsv_pv < end_pv) {
1023                         U8 c = (U8) *p++;
1024                         append_utf8_from_native_byte(c, (U8**)&dsv_pv);
1025                     }
1026                 }
1027                 else
1028                     /* arg is already-copied targ */
1029                     dsv_pv += len;
1030             }
1031
1032         }
1033     }
1034
1035     *dsv_pv = '\0';
1036     SvCUR_set(dsv, dsv_pv - SvPVX(dsv));
1037     assert(grow >= SvCUR(dsv) + 1);
1038     assert(SvLEN(dsv) >= SvCUR(dsv) + 1);
1039
1040     /* --------------------------------------------------------------
1041      * Phase 6:
1042      *
1043      * Handle overloading. If an overloaded arg or targ was detected
1044      * earlier, dsv will have been set to a new mortal, and any args and
1045      * consts to the left of the first overloaded arg will have been
1046      * accumulated to it. This section completes any further concatenation
1047      * steps with overloading handled.
1048      */
1049
1050     if (UNLIKELY(dsv != targ)) {
1051         SV *res;
1052
1053         SvFLAGS(dsv) |= dst_utf8;
1054
1055         if (SP <= toparg) {
1056             /* Stringifying the RHS was abandoned because *SP
1057              * is overloaded. dsv contains all the concatted strings
1058              * before *SP. Apply the rest of the args using overloading.
1059              */
1060             SV *left, *right, *res;
1061             int i;
1062             bool getmg = FALSE;
1063                                /* number of args already concatted */
1064             SSize_t n         = (nargs - 1) - (toparg - SP);
1065                                /* current arg is either the first
1066                                 * or second value to be concatted
1067                                 * (including constant strings), so would
1068                                 * form part of the first concat */
1069             bool first_concat = (    n == 0
1070                                  || (n == 1 && const_lens[-2].ssize < 0
1071                                             && const_lens[-1].ssize < 0));
1072             int  f_assign     = first_concat ? 0 : AMGf_assign;
1073
1074             left = dsv;
1075
1076             for (; n < nargs; n++) {
1077                 /* loop twice, first applying the arg, then the const segment */
1078                 for (i = 0; i < 2; i++) {
1079                     if (i) {
1080                         /* append next const string segment */
1081                         STRLEN len = (STRLEN)((const_lens++)->ssize);
1082                         /* a length of -1 implies no constant string
1083                          * rather than a zero-length one, e.g.
1084                          * ($a . $b) versus ($a . "" . $b)
1085                          */
1086                         if ((SSize_t)len < 0)
1087                             continue;
1088
1089                         /* set right to the next constant string segment */
1090                         right = newSVpvn_flags(const_pv, len,
1091                                                     (dst_utf8 | SVs_TEMP));
1092                         const_pv += len;
1093                     }
1094                     else {
1095                         /* append next arg */
1096                         right = *SP++;
1097                         if (getmg)
1098                             SvGETMAGIC(right);
1099                         else
1100                             /* SvGETMAGIC already called on this SV just
1101                              * before we broke from the loop earlier */
1102                             getmg = TRUE;
1103
1104                         if (first_concat && n == 0 && const_lens[-1].ssize < 0) {
1105                             /* nothing before the current arg; repeat the
1106                              * loop to get a second arg */
1107                             left = right;
1108                             first_concat = FALSE;
1109                             continue;
1110                         }
1111                     }
1112
1113                     if ((SvAMAGIC(left) || SvAMAGIC(right))
1114                         && (res = amagic_call(left, right, concat_amg, f_assign))
1115                     )
1116                         left = res;
1117                     else {
1118                         if (left != dsv) {
1119                             sv_setsv(dsv, left);
1120                             left = dsv;
1121                         }
1122                         sv_catsv_nomg(left, right);
1123                     }
1124                     f_assign = AMGf_assign;
1125                 }
1126             }
1127             dsv = left;
1128         }
1129
1130         /* assign/append RHS (dsv) to LHS (targ) */
1131         if (is_append)  {
1132             if ((SvAMAGIC(targ) || SvAMAGIC(dsv))
1133                 && (res = amagic_call(targ, dsv, concat_amg, AMGf_assign))
1134             )
1135                 sv_setsv(targ, res);
1136             else
1137                 sv_catsv_nomg(targ, dsv);
1138         }
1139         else
1140             sv_setsv(targ, dsv);
1141     }
1142
1143     /* --------------------------------------------------------------
1144      * Phase 7:
1145      *
1146      * return result
1147      */
1148
1149   phase7:
1150
1151     SP -= stack_adj;
1152     SvTAINT(targ);
1153     SETTARG;
1154     RETURN;
1155 }
1156
1157
1158 /* push the elements of av onto the stack.
1159  * Returns PL_op->op_next to allow tail-call optimisation of its callers */
1160
1161 STATIC OP*
1162 S_pushav(pTHX_ AV* const av)
1163 {
1164     dSP;
1165     const SSize_t maxarg = AvFILL(av) + 1;
1166     EXTEND(SP, maxarg);
1167     if (UNLIKELY(SvRMAGICAL(av))) {
1168         PADOFFSET i;
1169         for (i=0; i < (PADOFFSET)maxarg; i++) {
1170             SV ** const svp = av_fetch(av, i, FALSE);
1171             SP[i+1] = svp ? *svp : &PL_sv_undef;
1172         }
1173     }
1174     else {
1175         PADOFFSET i;
1176         for (i=0; i < (PADOFFSET)maxarg; i++) {
1177             SV * const sv = AvARRAY(av)[i];
1178             SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
1179         }
1180     }
1181     SP += maxarg;
1182     PUTBACK;
1183     return NORMAL;
1184 }
1185
1186
1187 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
1188
1189 PP(pp_padrange)
1190 {
1191     dSP;
1192     PADOFFSET base = PL_op->op_targ;
1193     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
1194     if (PL_op->op_flags & OPf_SPECIAL) {
1195         /* fake the RHS of my ($x,$y,..) = @_ */
1196         PUSHMARK(SP);
1197         (void)S_pushav(aTHX_ GvAVn(PL_defgv));
1198         SPAGAIN;
1199     }
1200
1201     /* note, this is only skipped for compile-time-known void cxt */
1202     if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
1203         int i;
1204
1205         EXTEND(SP, count);
1206         PUSHMARK(SP);
1207         for (i = 0; i <count; i++)
1208             *++SP = PAD_SV(base+i);
1209     }
1210     if (PL_op->op_private & OPpLVAL_INTRO) {
1211         SV **svp = &(PAD_SVl(base));
1212         const UV payload = (UV)(
1213                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1214                     | (count << SAVE_TIGHT_SHIFT)
1215                     | SAVEt_CLEARPADRANGE);
1216         int i;
1217
1218         STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
1219         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1220                 == (Size_t)base);
1221         {
1222             dSS_ADD;
1223             SS_ADD_UV(payload);
1224             SS_ADD_END(1);
1225         }
1226
1227         for (i = 0; i <count; i++)
1228             SvPADSTALE_off(*svp++); /* mark lexical as active */
1229     }
1230     RETURN;
1231 }
1232
1233
1234 PP(pp_padsv)
1235 {
1236     dSP;
1237     EXTEND(SP, 1);
1238     {
1239         OP * const op = PL_op;
1240         /* access PL_curpad once */
1241         SV ** const padentry = &(PAD_SVl(op->op_targ));
1242         {
1243             dTARG;
1244             TARG = *padentry;
1245             PUSHs(TARG);
1246             PUTBACK; /* no pop/push after this, TOPs ok */
1247         }
1248         if (op->op_flags & OPf_MOD) {
1249             if (op->op_private & OPpLVAL_INTRO)
1250                 if (!(op->op_private & OPpPAD_STATE))
1251                     save_clearsv(padentry);
1252             if (op->op_private & OPpDEREF) {
1253                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
1254                    than TARG reduces the scope of TARG, so it does not
1255                    span the call to save_clearsv, resulting in smaller
1256                    machine code. */
1257                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
1258             }
1259         }
1260         return op->op_next;
1261     }
1262 }
1263
1264 PP(pp_readline)
1265 {
1266     dSP;
1267     /* pp_coreargs pushes a NULL to indicate no args passed to
1268      * CORE::readline() */
1269     if (TOPs) {
1270         SvGETMAGIC(TOPs);
1271         tryAMAGICunTARGETlist(iter_amg, 0);
1272         PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1273     }
1274     else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
1275     if (!isGV_with_GP(PL_last_in_gv)) {
1276         if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
1277             PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
1278         else {
1279             dSP;
1280             XPUSHs(MUTABLE_SV(PL_last_in_gv));
1281             PUTBACK;
1282             Perl_pp_rv2gv(aTHX);
1283             PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1284             assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
1285         }
1286     }
1287     return do_readline();
1288 }
1289
1290 PP(pp_eq)
1291 {
1292     dSP;
1293     SV *left, *right;
1294
1295     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
1296     right = POPs;
1297     left  = TOPs;
1298     SETs(boolSV(
1299         (SvIOK_notUV(left) && SvIOK_notUV(right))
1300         ? (SvIVX(left) == SvIVX(right))
1301         : ( do_ncmp(left, right) == 0)
1302     ));
1303     RETURN;
1304 }
1305
1306
1307 /* also used for: pp_i_preinc() */
1308
1309 PP(pp_preinc)
1310 {
1311     SV *sv = *PL_stack_sp;
1312
1313     if (LIKELY(((sv->sv_flags &
1314                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1315                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1316                 == SVf_IOK))
1317         && SvIVX(sv) != IV_MAX)
1318     {
1319         SvIV_set(sv, SvIVX(sv) + 1);
1320     }
1321     else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1322         sv_inc(sv);
1323     SvSETMAGIC(sv);
1324     return NORMAL;
1325 }
1326
1327
1328 /* also used for: pp_i_predec() */
1329
1330 PP(pp_predec)
1331 {
1332     SV *sv = *PL_stack_sp;
1333
1334     if (LIKELY(((sv->sv_flags &
1335                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1336                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1337                 == SVf_IOK))
1338         && SvIVX(sv) != IV_MIN)
1339     {
1340         SvIV_set(sv, SvIVX(sv) - 1);
1341     }
1342     else /* Do all the PERL_PRESERVE_IVUV and hard cases  in sv_dec */
1343         sv_dec(sv);
1344     SvSETMAGIC(sv);
1345     return NORMAL;
1346 }
1347
1348
1349 /* also used for: pp_orassign() */
1350
1351 PP(pp_or)
1352 {
1353     dSP;
1354     SV *sv;
1355     PERL_ASYNC_CHECK();
1356     sv = TOPs;
1357     if (SvTRUE_NN(sv))
1358         RETURN;
1359     else {
1360         if (PL_op->op_type == OP_OR)
1361             --SP;
1362         RETURNOP(cLOGOP->op_other);
1363     }
1364 }
1365
1366
1367 /* also used for: pp_dor() pp_dorassign() */
1368
1369 PP(pp_defined)
1370 {
1371     dSP;
1372     SV* sv;
1373     bool defined;
1374     const int op_type = PL_op->op_type;
1375     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
1376
1377     if (is_dor) {
1378         PERL_ASYNC_CHECK();
1379         sv = TOPs;
1380         if (UNLIKELY(!sv || !SvANY(sv))) {
1381             if (op_type == OP_DOR)
1382                 --SP;
1383             RETURNOP(cLOGOP->op_other);
1384         }
1385     }
1386     else {
1387         /* OP_DEFINED */
1388         sv = POPs;
1389         if (UNLIKELY(!sv || !SvANY(sv)))
1390             RETPUSHNO;
1391     }
1392
1393     defined = FALSE;
1394     switch (SvTYPE(sv)) {
1395     case SVt_PVAV:
1396         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1397             defined = TRUE;
1398         break;
1399     case SVt_PVHV:
1400         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1401             defined = TRUE;
1402         break;
1403     case SVt_PVCV:
1404         if (CvROOT(sv) || CvXSUB(sv))
1405             defined = TRUE;
1406         break;
1407     default:
1408         SvGETMAGIC(sv);
1409         if (SvOK(sv))
1410             defined = TRUE;
1411         break;
1412     }
1413
1414     if (is_dor) {
1415         if(defined) 
1416             RETURN; 
1417         if(op_type == OP_DOR)
1418             --SP;
1419         RETURNOP(cLOGOP->op_other);
1420     }
1421     /* assuming OP_DEFINED */
1422     if(defined) 
1423         RETPUSHYES;
1424     RETPUSHNO;
1425 }
1426
1427
1428
1429 PP(pp_add)
1430 {
1431     dSP; dATARGET; bool useleft; SV *svl, *svr;
1432
1433     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1434     svr = TOPs;
1435     svl = TOPm1s;
1436
1437 #ifdef PERL_PRESERVE_IVUV
1438
1439     /* special-case some simple common cases */
1440     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1441         IV il, ir;
1442         U32 flags = (svl->sv_flags & svr->sv_flags);
1443         if (flags & SVf_IOK) {
1444             /* both args are simple IVs */
1445             UV topl, topr;
1446             il = SvIVX(svl);
1447             ir = SvIVX(svr);
1448           do_iv:
1449             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1450             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1451
1452             /* if both are in a range that can't under/overflow, do a
1453              * simple integer add: if the top of both numbers
1454              * are 00  or 11, then it's safe */
1455             if (!( ((topl+1) | (topr+1)) & 2)) {
1456                 SP--;
1457                 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1458                 SETs(TARG);
1459                 RETURN;
1460             }
1461             goto generic;
1462         }
1463         else if (flags & SVf_NOK) {
1464             /* both args are NVs */
1465             NV nl = SvNVX(svl);
1466             NV nr = SvNVX(svr);
1467
1468             if (
1469 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1470                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1471                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1472 #else
1473                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1474 #endif
1475                 )
1476                 /* nothing was lost by converting to IVs */
1477                 goto do_iv;
1478             SP--;
1479             TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1480             SETs(TARG);
1481             RETURN;
1482         }
1483     }
1484
1485   generic:
1486
1487     useleft = USE_LEFT(svl);
1488     /* We must see if we can perform the addition with integers if possible,
1489        as the integer code detects overflow while the NV code doesn't.
1490        If either argument hasn't had a numeric conversion yet attempt to get
1491        the IV. It's important to do this now, rather than just assuming that
1492        it's not IOK as a PV of "9223372036854775806" may not take well to NV
1493        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1494        integer in case the second argument is IV=9223372036854775806
1495        We can (now) rely on sv_2iv to do the right thing, only setting the
1496        public IOK flag if the value in the NV (or PV) slot is truly integer.
1497
1498        A side effect is that this also aggressively prefers integer maths over
1499        fp maths for integer values.
1500
1501        How to detect overflow?
1502
1503        C 99 section 6.2.6.1 says
1504
1505        The range of nonnegative values of a signed integer type is a subrange
1506        of the corresponding unsigned integer type, and the representation of
1507        the same value in each type is the same. A computation involving
1508        unsigned operands can never overflow, because a result that cannot be
1509        represented by the resulting unsigned integer type is reduced modulo
1510        the number that is one greater than the largest value that can be
1511        represented by the resulting type.
1512
1513        (the 9th paragraph)
1514
1515        which I read as "unsigned ints wrap."
1516
1517        signed integer overflow seems to be classed as "exception condition"
1518
1519        If an exceptional condition occurs during the evaluation of an
1520        expression (that is, if the result is not mathematically defined or not
1521        in the range of representable values for its type), the behavior is
1522        undefined.
1523
1524        (6.5, the 5th paragraph)
1525
1526        I had assumed that on 2s complement machines signed arithmetic would
1527        wrap, hence coded pp_add and pp_subtract on the assumption that
1528        everything perl builds on would be happy.  After much wailing and
1529        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1530        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
1531        unsigned code below is actually shorter than the old code. :-)
1532     */
1533
1534     if (SvIV_please_nomg(svr)) {
1535         /* Unless the left argument is integer in range we are going to have to
1536            use NV maths. Hence only attempt to coerce the right argument if
1537            we know the left is integer.  */
1538         UV auv = 0;
1539         bool auvok = FALSE;
1540         bool a_valid = 0;
1541
1542         if (!useleft) {
1543             auv = 0;
1544             a_valid = auvok = 1;
1545             /* left operand is undef, treat as zero. + 0 is identity,
1546                Could SETi or SETu right now, but space optimise by not adding
1547                lots of code to speed up what is probably a rarish case.  */
1548         } else {
1549             /* Left operand is defined, so is it IV? */
1550             if (SvIV_please_nomg(svl)) {
1551                 if ((auvok = SvUOK(svl)))
1552                     auv = SvUVX(svl);
1553                 else {
1554                     const IV aiv = SvIVX(svl);
1555                     if (aiv >= 0) {
1556                         auv = aiv;
1557                         auvok = 1;      /* Now acting as a sign flag.  */
1558                     } else {
1559                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1560                     }
1561                 }
1562                 a_valid = 1;
1563             }
1564         }
1565         if (a_valid) {
1566             bool result_good = 0;
1567             UV result;
1568             UV buv;
1569             bool buvok = SvUOK(svr);
1570         
1571             if (buvok)
1572                 buv = SvUVX(svr);
1573             else {
1574                 const IV biv = SvIVX(svr);
1575                 if (biv >= 0) {
1576                     buv = biv;
1577                     buvok = 1;
1578                 } else
1579                     buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1580             }
1581             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1582                else "IV" now, independent of how it came in.
1583                if a, b represents positive, A, B negative, a maps to -A etc
1584                a + b =>  (a + b)
1585                A + b => -(a - b)
1586                a + B =>  (a - b)
1587                A + B => -(a + b)
1588                all UV maths. negate result if A negative.
1589                add if signs same, subtract if signs differ. */
1590
1591             if (auvok ^ buvok) {
1592                 /* Signs differ.  */
1593                 if (auv >= buv) {
1594                     result = auv - buv;
1595                     /* Must get smaller */
1596                     if (result <= auv)
1597                         result_good = 1;
1598                 } else {
1599                     result = buv - auv;
1600                     if (result <= buv) {
1601                         /* result really should be -(auv-buv). as its negation
1602                            of true value, need to swap our result flag  */
1603                         auvok = !auvok;
1604                         result_good = 1;
1605                     }
1606                 }
1607             } else {
1608                 /* Signs same */
1609                 result = auv + buv;
1610                 if (result >= auv)
1611                     result_good = 1;
1612             }
1613             if (result_good) {
1614                 SP--;
1615                 if (auvok)
1616                     SETu( result );
1617                 else {
1618                     /* Negate result */
1619                     if (result <= (UV)IV_MIN)
1620                         SETi(result == (UV)IV_MIN
1621                                 ? IV_MIN : -(IV)result);
1622                     else {
1623                         /* result valid, but out of range for IV.  */
1624                         SETn( -(NV)result );
1625                     }
1626                 }
1627                 RETURN;
1628             } /* Overflow, drop through to NVs.  */
1629         }
1630     }
1631
1632 #else
1633     useleft = USE_LEFT(svl);
1634 #endif
1635
1636     {
1637         NV value = SvNV_nomg(svr);
1638         (void)POPs;
1639         if (!useleft) {
1640             /* left operand is undef, treat as zero. + 0.0 is identity. */
1641             SETn(value);
1642             RETURN;
1643         }
1644         SETn( value + SvNV_nomg(svl) );
1645         RETURN;
1646     }
1647 }
1648
1649
1650 /* also used for: pp_aelemfast_lex() */
1651
1652 PP(pp_aelemfast)
1653 {
1654     dSP;
1655     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
1656         ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
1657     const U32 lval = PL_op->op_flags & OPf_MOD;
1658     const I8 key   = (I8)PL_op->op_private;
1659     SV** svp;
1660     SV *sv;
1661
1662     assert(SvTYPE(av) == SVt_PVAV);
1663
1664     EXTEND(SP, 1);
1665
1666     /* inlined av_fetch() for simple cases ... */
1667     if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1668         sv = AvARRAY(av)[key];
1669         if (sv) {
1670             PUSHs(sv);
1671             RETURN;
1672         }
1673     }
1674
1675     /* ... else do it the hard way */
1676     svp = av_fetch(av, key, lval);
1677     sv = (svp ? *svp : &PL_sv_undef);
1678
1679     if (UNLIKELY(!svp && lval))
1680         DIE(aTHX_ PL_no_aelem, (int)key);
1681
1682     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
1683         mg_get(sv);
1684     PUSHs(sv);
1685     RETURN;
1686 }
1687
1688 PP(pp_join)
1689 {
1690     dSP; dMARK; dTARGET;
1691     MARK++;
1692     do_join(TARG, *MARK, MARK, SP);
1693     SP = MARK;
1694     SETs(TARG);
1695     RETURN;
1696 }
1697
1698 /* Oversized hot code. */
1699
1700 /* also used for: pp_say() */
1701
1702 PP(pp_print)
1703 {
1704     dSP; dMARK; dORIGMARK;
1705     PerlIO *fp;
1706     MAGIC *mg;
1707     GV * const gv
1708         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1709     IO *io = GvIO(gv);
1710
1711     if (io
1712         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1713     {
1714       had_magic:
1715         if (MARK == ORIGMARK) {
1716             /* If using default handle then we need to make space to
1717              * pass object as 1st arg, so move other args up ...
1718              */
1719             MEXTEND(SP, 1);
1720             ++MARK;
1721             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1722             ++SP;
1723         }
1724         return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
1725                                 mg,
1726                                 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1727                                  | (PL_op->op_type == OP_SAY
1728                                     ? TIED_METHOD_SAY : 0)), sp - mark);
1729     }
1730     if (!io) {
1731         if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
1732             && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1733             goto had_magic;
1734         report_evil_fh(gv);
1735         SETERRNO(EBADF,RMS_IFI);
1736         goto just_say_no;
1737     }
1738     else if (!(fp = IoOFP(io))) {
1739         if (IoIFP(io))
1740             report_wrongway_fh(gv, '<');
1741         else
1742             report_evil_fh(gv);
1743         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1744         goto just_say_no;
1745     }
1746     else {
1747         SV * const ofs = GvSV(PL_ofsgv); /* $, */
1748         MARK++;
1749         if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
1750             while (MARK <= SP) {
1751                 if (!do_print(*MARK, fp))
1752                     break;
1753                 MARK++;
1754                 if (MARK <= SP) {
1755                     /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1756                     if (!do_print(GvSV(PL_ofsgv), fp)) {
1757                         MARK--;
1758                         break;
1759                     }
1760                 }
1761             }
1762         }
1763         else {
1764             while (MARK <= SP) {
1765                 if (!do_print(*MARK, fp))
1766                     break;
1767                 MARK++;
1768             }
1769         }
1770         if (MARK <= SP)
1771             goto just_say_no;
1772         else {
1773             if (PL_op->op_type == OP_SAY) {
1774                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1775                     goto just_say_no;
1776             }
1777             else if (PL_ors_sv && SvOK(PL_ors_sv))
1778                 if (!do_print(PL_ors_sv, fp)) /* $\ */
1779                     goto just_say_no;
1780
1781             if (IoFLAGS(io) & IOf_FLUSH)
1782                 if (PerlIO_flush(fp) == EOF)
1783                     goto just_say_no;
1784         }
1785     }
1786     SP = ORIGMARK;
1787     XPUSHs(&PL_sv_yes);
1788     RETURN;
1789
1790   just_say_no:
1791     SP = ORIGMARK;
1792     XPUSHs(&PL_sv_undef);
1793     RETURN;
1794 }
1795
1796
1797 /* do the common parts of pp_padhv() and pp_rv2hv()
1798  * It assumes the caller has done EXTEND(SP, 1) or equivalent.
1799  * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
1800  * 'has_targ' indicates that the op has a target - this should
1801  * be a compile-time constant so that the code can constant-folded as
1802  * appropriate
1803  * */
1804
1805 PERL_STATIC_INLINE OP*
1806 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
1807 {
1808     bool is_tied;
1809     bool is_bool;
1810     MAGIC *mg;
1811     dSP;
1812     IV  i;
1813     SV *sv;
1814
1815     assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1816
1817     if (gimme == G_ARRAY) {
1818         hv_pushkv(hv, 3);
1819         return NORMAL;
1820     }
1821
1822     if (is_keys)
1823         /* 'keys %h' masquerading as '%h': reset iterator */
1824         (void)hv_iterinit(hv);
1825
1826     if (gimme == G_VOID)
1827         return NORMAL;
1828
1829     is_bool = (     PL_op->op_private & OPpTRUEBOOL
1830               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
1831                   && block_gimme() == G_VOID));
1832     is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
1833
1834     if (UNLIKELY(is_tied)) {
1835         if (is_keys && !is_bool) {
1836             i = 0;
1837             while (hv_iternext(hv))
1838                 i++;
1839             goto push_i;
1840         }
1841         else {
1842             sv = magic_scalarpack(hv, mg);
1843             goto push_sv;
1844         }
1845     }
1846     else {
1847         i = HvUSEDKEYS(hv);
1848         if (is_bool) {
1849             sv = i ? &PL_sv_yes : &PL_sv_zero;
1850           push_sv:
1851             PUSHs(sv);
1852         }
1853         else {
1854           push_i:
1855             if (has_targ) {
1856                 dTARGET;
1857                 PUSHi(i);
1858             }
1859             else
1860 #ifdef PERL_OP_PARENT
1861             if (is_keys) {
1862                 /* parent op should be an unused OP_KEYS whose targ we can
1863                  * use */
1864                 dTARG;
1865                 OP *k;
1866
1867                 assert(!OpHAS_SIBLING(PL_op));
1868                 k = PL_op->op_sibparent;
1869                 assert(k->op_type == OP_KEYS);
1870                 TARG = PAD_SV(k->op_targ);
1871                 PUSHi(i);
1872             }
1873             else
1874 #endif
1875                 mPUSHi(i);
1876         }
1877     }
1878
1879     PUTBACK;
1880     return NORMAL;
1881 }
1882
1883
1884 /* This is also called directly by pp_lvavref.  */
1885 PP(pp_padav)
1886 {
1887     dSP; dTARGET;
1888     U8 gimme;
1889     assert(SvTYPE(TARG) == SVt_PVAV);
1890     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1891         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1892             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1893     EXTEND(SP, 1);
1894
1895     if (PL_op->op_flags & OPf_REF) {
1896         PUSHs(TARG);
1897         RETURN;
1898     }
1899     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1900         const I32 flags = is_lvalue_sub();
1901         if (flags && !(flags & OPpENTERSUB_INARGS)) {
1902             if (GIMME_V == G_SCALAR)
1903                 /* diag_listed_as: Can't return %s to lvalue scalar context */
1904                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1905             PUSHs(TARG);
1906             RETURN;
1907        }
1908     }
1909
1910     gimme = GIMME_V;
1911     if (gimme == G_ARRAY)
1912         return S_pushav(aTHX_ (AV*)TARG);
1913
1914     if (gimme == G_SCALAR) {
1915         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1916         if (!maxarg)
1917             PUSHs(&PL_sv_zero);
1918         else if (PL_op->op_private & OPpTRUEBOOL)
1919             PUSHs(&PL_sv_yes);
1920         else
1921             mPUSHi(maxarg);
1922     }
1923     RETURN;
1924 }
1925
1926
1927 PP(pp_padhv)
1928 {
1929     dSP; dTARGET;
1930     U8 gimme;
1931
1932     assert(SvTYPE(TARG) == SVt_PVHV);
1933     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1934         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1935             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1936
1937     EXTEND(SP, 1);
1938
1939     if (PL_op->op_flags & OPf_REF) {
1940         PUSHs(TARG);
1941         RETURN;
1942     }
1943     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1944         const I32 flags = is_lvalue_sub();
1945         if (flags && !(flags & OPpENTERSUB_INARGS)) {
1946             if (GIMME_V == G_SCALAR)
1947                 /* diag_listed_as: Can't return %s to lvalue scalar context */
1948                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
1949             PUSHs(TARG);
1950             RETURN;
1951         }
1952     }
1953
1954     gimme = GIMME_V;
1955
1956     return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
1957                         cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1958                         0 /* has_targ*/);
1959 }
1960
1961
1962 /* also used for: pp_rv2hv() */
1963 /* also called directly by pp_lvavref */
1964
1965 PP(pp_rv2av)
1966 {
1967     dSP; dTOPss;
1968     const U8 gimme = GIMME_V;
1969     static const char an_array[] = "an ARRAY";
1970     static const char a_hash[] = "a HASH";
1971     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1972                           || PL_op->op_type == OP_LVAVREF;
1973     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
1974
1975     SvGETMAGIC(sv);
1976     if (SvROK(sv)) {
1977         if (UNLIKELY(SvAMAGIC(sv))) {
1978             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
1979         }
1980         sv = SvRV(sv);
1981         if (UNLIKELY(SvTYPE(sv) != type))
1982             /* diag_listed_as: Not an ARRAY reference */
1983             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
1984         else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1985                 && PL_op->op_private & OPpLVAL_INTRO))
1986             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
1987     }
1988     else if (UNLIKELY(SvTYPE(sv) != type)) {
1989             GV *gv;
1990         
1991             if (!isGV_with_GP(sv)) {
1992                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
1993                                      type, &sp);
1994                 if (!gv)
1995                     RETURN;
1996             }
1997             else {
1998                 gv = MUTABLE_GV(sv);
1999             }
2000             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
2001             if (PL_op->op_private & OPpLVAL_INTRO)
2002                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
2003     }
2004     if (PL_op->op_flags & OPf_REF) {
2005                 SETs(sv);
2006                 RETURN;
2007     }
2008     else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
2009               const I32 flags = is_lvalue_sub();
2010               if (flags && !(flags & OPpENTERSUB_INARGS)) {
2011                 if (gimme != G_ARRAY)
2012                     goto croak_cant_return;
2013                 SETs(sv);
2014                 RETURN;
2015               }
2016     }
2017
2018     if (is_pp_rv2av) {
2019         AV *const av = MUTABLE_AV(sv);
2020
2021         if (gimme == G_ARRAY) {
2022             SP--;
2023             PUTBACK;
2024             return S_pushav(aTHX_ av);
2025         }
2026
2027         if (gimme == G_SCALAR) {
2028             const SSize_t maxarg = AvFILL(av) + 1;
2029             if (PL_op->op_private & OPpTRUEBOOL)
2030                 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
2031             else {
2032                 dTARGET;
2033                 SETi(maxarg);
2034             }
2035         }
2036     }
2037     else {
2038         SP--; PUTBACK;
2039         return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
2040                         cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2041                         1 /* has_targ*/);
2042     }
2043     RETURN;
2044
2045  croak_cant_return:
2046     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2047                is_pp_rv2av ? "array" : "hash");
2048     RETURN;
2049 }
2050
2051 STATIC void
2052 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
2053 {
2054     PERL_ARGS_ASSERT_DO_ODDBALL;
2055
2056     if (*oddkey) {
2057         if (ckWARN(WARN_MISC)) {
2058             const char *err;
2059             if (oddkey == firstkey &&
2060                 SvROK(*oddkey) &&
2061                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2062                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
2063             {
2064                 err = "Reference found where even-sized list expected";
2065             }
2066             else
2067                 err = "Odd number of elements in hash assignment";
2068             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
2069         }
2070
2071     }
2072 }
2073
2074
2075 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2076  * are common to both the LHS and RHS of an aassign, and replace them
2077  * with copies. All these copies are made before the actual list assign is
2078  * done.
2079  *
2080  * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2081  * element ($b) to the first LH element ($a), modifies $a; when the
2082  * second assignment is done, the second RH element now has the wrong
2083  * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2084  * Note that we don't need to make a mortal copy of $b.
2085  *
2086  * The algorithm below works by, for every RHS element, mark the
2087  * corresponding LHS target element with SVf_BREAK. Then if the RHS
2088  * element is found with SVf_BREAK set, it means it would have been
2089  * modified, so make a copy.
2090  * Note that by scanning both LHS and RHS in lockstep, we avoid
2091  * unnecessary copies (like $b above) compared with a naive
2092  * "mark all LHS; copy all marked RHS; unmark all LHS".
2093  *
2094  * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2095  * it can't be common and can be skipped.
2096  *
2097  * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2098  * that we thought we didn't need to call S_aassign_copy_common(), but we
2099  * have anyway for sanity checking. If we find we need to copy, then panic.
2100  */
2101
2102 PERL_STATIC_INLINE void
2103 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
2104         SV **firstrelem, SV **lastrelem
2105 #ifdef DEBUGGING
2106         , bool fake
2107 #endif
2108 )
2109 {
2110     dVAR;
2111     SV **relem;
2112     SV **lelem;
2113     SSize_t lcount = lastlelem - firstlelem + 1;
2114     bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2115     bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
2116     bool copy_all = FALSE;
2117
2118     assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2119     assert(firstlelem < lastlelem); /* at least 2 LH elements */
2120     assert(firstrelem < lastrelem); /* at least 2 RH elements */
2121
2122
2123     lelem = firstlelem;
2124     /* we never have to copy the first RH element; it can't be corrupted
2125      * by assigning something to the corresponding first LH element.
2126      * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2127      */
2128     relem = firstrelem + 1;
2129
2130     for (; relem <= lastrelem; relem++) {
2131         SV *svr;
2132
2133         /* mark next LH element */
2134
2135         if (--lcount >= 0) {
2136             SV *svl = *lelem++;
2137
2138             if (UNLIKELY(!svl)) {/* skip AV alias marker */
2139                 assert (lelem <= lastlelem);
2140                 svl = *lelem++;
2141                 lcount--;
2142             }
2143
2144             assert(svl);
2145             if (SvSMAGICAL(svl)) {
2146                 copy_all = TRUE;
2147             }
2148             if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2149                 if (!marked)
2150                     return;
2151                 /* this LH element will consume all further args;
2152                  * no need to mark any further LH elements (if any).
2153                  * But we still need to scan any remaining RHS elements;
2154                  * set lcount negative to distinguish from  lcount == 0,
2155                  * so the loop condition continues being true
2156                  */
2157                 lcount = -1;
2158                 lelem--; /* no need to unmark this element */
2159             }
2160             else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
2161                 SvFLAGS(svl) |= SVf_BREAK;
2162                 marked = TRUE;
2163             }
2164             else if (!marked) {
2165                 /* don't check RH element if no SVf_BREAK flags set yet */
2166                 if (!lcount)
2167                     break;
2168                 continue;
2169             }
2170         }
2171
2172         /* see if corresponding RH element needs copying */
2173
2174         assert(marked);
2175         svr = *relem;
2176         assert(svr);
2177
2178         if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
2179             U32 brk = (SvFLAGS(svr) & SVf_BREAK);
2180
2181 #ifdef DEBUGGING
2182             if (fake) {
2183                 /* op_dump(PL_op); */
2184                 Perl_croak(aTHX_
2185                     "panic: aassign skipped needed copy of common RH elem %"
2186                         UVuf, (UV)(relem - firstrelem));
2187             }
2188 #endif
2189
2190             TAINT_NOT;  /* Each item is independent */
2191
2192             /* Dear TODO test in t/op/sort.t, I love you.
2193                (It's relying on a panic, not a "semi-panic" from newSVsv()
2194                and then an assertion failure below.)  */
2195             if (UNLIKELY(SvIS_FREED(svr))) {
2196                 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2197                            (void*)svr);
2198             }
2199             /* avoid break flag while copying; otherwise COW etc
2200              * disabled... */
2201             SvFLAGS(svr) &= ~SVf_BREAK;
2202             /* Not newSVsv(), as it does not allow copy-on-write,
2203                resulting in wasteful copies.
2204                Also, we use SV_NOSTEAL in case the SV is used more than
2205                once, e.g.  (...) = (f())[0,0]
2206                Where the same SV appears twice on the RHS without a ref
2207                count bump.  (Although I suspect that the SV won't be
2208                stealable here anyway - DAPM).
2209                */
2210             *relem = sv_mortalcopy_flags(svr,
2211                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2212             /* ... but restore afterwards in case it's needed again,
2213              * e.g. ($a,$b,$c) = (1,$a,$a)
2214              */
2215             SvFLAGS(svr) |= brk;
2216         }
2217
2218         if (!lcount)
2219             break;
2220     }
2221
2222     if (!marked)
2223         return;
2224
2225     /*unmark LHS */
2226
2227     while (lelem > firstlelem) {
2228         SV * const svl = *(--lelem);
2229         if (svl)
2230             SvFLAGS(svl) &= ~SVf_BREAK;
2231     }
2232 }
2233
2234
2235
2236 PP(pp_aassign)
2237 {
2238     dVAR; dSP;
2239     SV **lastlelem = PL_stack_sp;
2240     SV **lastrelem = PL_stack_base + POPMARK;
2241     SV **firstrelem = PL_stack_base + POPMARK + 1;
2242     SV **firstlelem = lastrelem + 1;
2243
2244     SV **relem;
2245     SV **lelem;
2246     U8 gimme;
2247     /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
2248      * only need to save locally, not on the save stack */
2249     U16 old_delaymagic = PL_delaymagic;
2250 #ifdef DEBUGGING
2251     bool fake = 0;
2252 #endif
2253
2254     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
2255
2256     /* If there's a common identifier on both sides we have to take
2257      * special care that assigning the identifier on the left doesn't
2258      * clobber a value on the right that's used later in the list.
2259      */
2260
2261     /* at least 2 LH and RH elements, or commonality isn't an issue */
2262     if (firstlelem < lastlelem && firstrelem < lastrelem) {
2263         for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2264             if (SvGMAGICAL(*relem))
2265                 goto do_scan;
2266         }
2267         for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2268             if (*lelem && SvSMAGICAL(*lelem))
2269                 goto do_scan;
2270         }
2271         if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2272             if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2273                 /* skip the scan if all scalars have a ref count of 1 */
2274                 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2275                     SV *sv = *lelem;
2276                     if (!sv || SvREFCNT(sv) == 1)
2277                         continue;
2278                     if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2279                         goto do_scan;
2280                     break;
2281                 }
2282             }
2283             else {
2284             do_scan:
2285                 S_aassign_copy_common(aTHX_
2286                                       firstlelem, lastlelem, firstrelem, lastrelem
2287 #ifdef DEBUGGING
2288                     , fake
2289 #endif
2290                 );
2291             }
2292         }
2293     }
2294 #ifdef DEBUGGING
2295     else {
2296         /* on debugging builds, do the scan even if we've concluded we
2297          * don't need to, then panic if we find commonality. Note that the
2298          * scanner assumes at least 2 elements */
2299         if (firstlelem < lastlelem && firstrelem < lastrelem) {
2300             fake = 1;
2301             goto do_scan;
2302         }
2303     }
2304 #endif
2305
2306     gimme = GIMME_V;
2307     relem = firstrelem;
2308     lelem = firstlelem;
2309
2310     if (relem > lastrelem)
2311         goto no_relems;
2312
2313     /* first lelem loop while there are still relems */
2314     while (LIKELY(lelem <= lastlelem)) {
2315         bool alias = FALSE;
2316         SV *lsv = *lelem++;
2317
2318         TAINT_NOT; /* Each item stands on its own, taintwise. */
2319
2320         assert(relem <= lastrelem);
2321         if (UNLIKELY(!lsv)) {
2322             alias = TRUE;
2323             lsv = *lelem++;
2324             ASSUME(SvTYPE(lsv) == SVt_PVAV);
2325         }
2326
2327         switch (SvTYPE(lsv)) {
2328         case SVt_PVAV: {
2329             SV **svp;
2330             SSize_t i;
2331             SSize_t tmps_base;
2332             SSize_t nelems = lastrelem - relem + 1;
2333             AV *ary = MUTABLE_AV(lsv);
2334
2335             /* Assigning to an aggregate is tricky. First there is the
2336              * issue of commonality, e.g. @a = ($a[0]). Since the
2337              * stack isn't refcounted, clearing @a prior to storing
2338              * elements will free $a[0]. Similarly with
2339              *    sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2340              *
2341              * The way to avoid these issues is to make the copy of each
2342              * SV (and we normally store a *copy* in the array) *before*
2343              * clearing the array. But this has a problem in that
2344              * if the code croaks during copying, the not-yet-stored copies
2345              * could leak. One way to avoid this is to make all the copies
2346              * mortal, but that's quite expensive.
2347              *
2348              * The current solution to these issues is to use a chunk
2349              * of the tmps stack as a temporary refcounted-stack. SVs
2350              * will be put on there during processing to avoid leaks,
2351              * but will be removed again before the end of this block,
2352              * so free_tmps() is never normally called. Also, the
2353              * sv_refcnt of the SVs doesn't have to be manipulated, since
2354              * the ownership of 1 reference count is transferred directly
2355              * from the tmps stack to the AV when the SV is stored.
2356              *
2357              * We disarm slots in the temps stack by storing PL_sv_undef
2358              * there: it doesn't matter if that SV's refcount is
2359              * repeatedly decremented during a croak. But usually this is
2360              * only an interim measure. By the end of this code block
2361              * we try where possible to not leave any PL_sv_undef's on the
2362              * tmps stack e.g. by shuffling newer entries down.
2363              *
2364              * There is one case where we don't copy: non-magical
2365              * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2366              * is on the tmps stack, so its safe to directly steal the SV
2367              * rather than copying. This is common in things like function
2368              * returns, map etc, which all return a list of such SVs.
2369              *
2370              * Note however something like @a = (f())[0,0], where there is
2371              * a danger of the same SV being shared:  this avoided because
2372              * when the SV is stored as $a[0], its ref count gets bumped,
2373              * so the RC==1 test fails and the second element is copied
2374              * instead.
2375              *
2376              * We also use one slot in the tmps stack to hold an extra
2377              * ref to the array, to ensure it doesn't get prematurely
2378              * freed. Again, this is removed before the end of this block.
2379              *
2380              * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2381              * @a = ($a[0]) case, but the current implementation uses the
2382              * same algorithm regardless, so ignores that flag. (It *is*
2383              * used in the hash branch below, however).
2384             */
2385
2386             /* Reserve slots for ary, plus the elems we're about to copy,
2387              * then protect ary and temporarily void the remaining slots
2388              * with &PL_sv_undef */
2389             EXTEND_MORTAL(nelems + 1);
2390             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2391             tmps_base = PL_tmps_ix + 1;
2392             for (i = 0; i < nelems; i++)
2393                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2394             PL_tmps_ix += nelems;
2395
2396             /* Make a copy of each RHS elem and save on the tmps_stack
2397              * (or pass through where we can optimise away the copy) */
2398
2399             if (UNLIKELY(alias)) {
2400                 U32 lval = (gimme == G_ARRAY)
2401                                 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
2402                 for (svp = relem; svp <= lastrelem; svp++) {
2403                     SV *rsv = *svp;
2404
2405                     SvGETMAGIC(rsv);
2406                     if (!SvROK(rsv))
2407                         DIE(aTHX_ "Assigned value is not a reference");
2408                     if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2409                    /* diag_listed_as: Assigned value is not %s reference */
2410                         DIE(aTHX_
2411                            "Assigned value is not a SCALAR reference");
2412                     if (lval)
2413                         *svp = rsv = sv_mortalcopy(rsv);
2414                     /* XXX else check for weak refs?  */
2415                     rsv = SvREFCNT_inc_NN(SvRV(rsv));
2416                     assert(tmps_base <= PL_tmps_max);
2417                     PL_tmps_stack[tmps_base++] = rsv;
2418                 }
2419             }
2420             else {
2421                 for (svp = relem; svp <= lastrelem; svp++) {
2422                     SV *rsv = *svp;
2423
2424                     if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2425                         /* can skip the copy */
2426                         SvREFCNT_inc_simple_void_NN(rsv);
2427                         SvTEMP_off(rsv);
2428                     }
2429                     else {
2430                         SV *nsv;
2431                         /* do get before newSV, in case it dies and leaks */
2432                         SvGETMAGIC(rsv);
2433                         nsv = newSV(0);
2434                         /* see comment in S_aassign_copy_common about
2435                          * SV_NOSTEAL */
2436                         sv_setsv_flags(nsv, rsv,
2437                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2438                         rsv = *svp = nsv;
2439                     }
2440
2441                     assert(tmps_base <= PL_tmps_max);
2442                     PL_tmps_stack[tmps_base++] = rsv;
2443                 }
2444             }
2445
2446             if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2447                 av_clear(ary);
2448
2449             /* store in the array, the SVs that are in the tmps stack */
2450
2451             tmps_base -= nelems;
2452
2453             if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
2454                 /* for arrays we can't cheat with, use the official API */
2455                 av_extend(ary, nelems - 1);
2456                 for (i = 0; i < nelems; i++) {
2457                     SV **svp = &(PL_tmps_stack[tmps_base + i]);
2458                     SV *rsv = *svp;
2459                     /* A tied store won't take ownership of rsv, so keep
2460                      * the 1 refcnt on the tmps stack; otherwise disarm
2461                      * the tmps stack entry */
2462                     if (av_store(ary, i, rsv))
2463                         *svp = &PL_sv_undef;
2464                     /* av_store() may have added set magic to rsv */;
2465                     SvSETMAGIC(rsv);
2466                 }
2467                 /* disarm ary refcount: see comments below about leak */
2468                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2469             }
2470             else {
2471                 /* directly access/set the guts of the AV */
2472                 SSize_t fill = nelems - 1;
2473                 if (fill > AvMAX(ary))
2474                     av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2475                                     &AvARRAY(ary));
2476                 AvFILLp(ary) = fill;
2477                 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2478                 /* Quietly remove all the SVs from the tmps stack slots,
2479                  * since ary has now taken ownership of the refcnt.
2480                  * Also remove ary: which will now leak if we die before
2481                  * the SvREFCNT_dec_NN(ary) below */
2482                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2483                     Move(&PL_tmps_stack[tmps_base + nelems],
2484                          &PL_tmps_stack[tmps_base - 1],
2485                          PL_tmps_ix - (tmps_base + nelems) + 1,
2486                          SV*);
2487                 PL_tmps_ix -= (nelems + 1);
2488             }
2489
2490             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2491                 /* its assumed @ISA set magic can't die and leak ary */
2492                 SvSETMAGIC(MUTABLE_SV(ary));
2493             SvREFCNT_dec_NN(ary);
2494
2495             relem = lastrelem + 1;
2496             goto no_relems;
2497         }
2498
2499         case SVt_PVHV: {                                /* normal hash */
2500
2501             SV **svp;
2502             bool dirty_tmps;
2503             SSize_t i;
2504             SSize_t tmps_base;
2505             SSize_t nelems = lastrelem - relem + 1;
2506             HV *hash = MUTABLE_HV(lsv);
2507
2508             if (UNLIKELY(nelems & 1)) {
2509                 do_oddball(lastrelem, relem);
2510                 /* we have firstlelem to reuse, it's not needed any more */
2511                 *++lastrelem = &PL_sv_undef;
2512                 nelems++;
2513             }
2514
2515             /* See the SVt_PVAV branch above for a long description of
2516              * how the following all works. The main difference for hashes
2517              * is that we treat keys and values separately (and have
2518              * separate loops for them): as for arrays, values are always
2519              * copied (except for the SvTEMP optimisation), since they
2520              * need to be stored in the hash; while keys are only
2521              * processed where they might get prematurely freed or
2522              * whatever. */
2523
2524             /* tmps stack slots:
2525              * * reserve a slot for the hash keepalive;
2526              * * reserve slots for the hash values we're about to copy;
2527              * * preallocate for the keys we'll possibly copy or refcount bump
2528              *   later;
2529              * then protect hash and temporarily void the remaining
2530              * value slots with &PL_sv_undef */
2531             EXTEND_MORTAL(nelems + 1);
2532
2533              /* convert to number of key/value pairs */
2534              nelems >>= 1;
2535
2536             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2537             tmps_base = PL_tmps_ix + 1;
2538             for (i = 0; i < nelems; i++)
2539                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2540             PL_tmps_ix += nelems;
2541
2542             /* Make a copy of each RHS hash value and save on the tmps_stack
2543              * (or pass through where we can optimise away the copy) */
2544
2545             for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2546                 SV *rsv = *svp;
2547
2548                 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2549                     /* can skip the copy */
2550                     SvREFCNT_inc_simple_void_NN(rsv);
2551                     SvTEMP_off(rsv);
2552                 }
2553                 else {
2554                     SV *nsv;
2555                     /* do get before newSV, in case it dies and leaks */
2556                     SvGETMAGIC(rsv);
2557                     nsv = newSV(0);
2558                     /* see comment in S_aassign_copy_common about
2559                      * SV_NOSTEAL */
2560                     sv_setsv_flags(nsv, rsv,
2561                             (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2562                     rsv = *svp = nsv;
2563                 }
2564
2565                 assert(tmps_base <= PL_tmps_max);
2566                 PL_tmps_stack[tmps_base++] = rsv;
2567             }
2568             tmps_base -= nelems;
2569
2570
2571             /* possibly protect keys */
2572
2573             if (UNLIKELY(gimme == G_ARRAY)) {
2574                 /* handle e.g.
2575                 *     @a = ((%h = ($$r, 1)), $r = "x");
2576                 *     $_++ for %h = (1,2,3,4);
2577                 */
2578                 EXTEND_MORTAL(nelems);
2579                 for (svp = relem; svp <= lastrelem; svp += 2)
2580                     *svp = sv_mortalcopy_flags(*svp,
2581                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2582             }
2583             else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2584                 /* for possible commonality, e.g.
2585                  *       %h = ($h{a},1)
2586                  * avoid premature freeing RHS keys by mortalising
2587                  * them.
2588                  * For a magic element, make a copy so that its magic is
2589                  * called *before* the hash is emptied (which may affect
2590                  * a tied value for example).
2591                  * In theory we should check for magic keys in all
2592                  * cases, not just under OPpASSIGN_COMMON_AGG, but in
2593                  * practice, !OPpASSIGN_COMMON_AGG implies only
2594                  * constants or padtmps on the RHS.
2595                  */
2596                 EXTEND_MORTAL(nelems);
2597                 for (svp = relem; svp <= lastrelem; svp += 2) {
2598                     SV *rsv = *svp;
2599                     if (UNLIKELY(SvGMAGICAL(rsv))) {
2600                         SSize_t n;
2601                         *svp = sv_mortalcopy_flags(*svp,
2602                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2603                         /* allow other branch to continue pushing
2604                          * onto tmps stack without checking each time */
2605                         n = (lastrelem - relem) >> 1;
2606                         EXTEND_MORTAL(n);
2607                     }
2608                     else
2609                         PL_tmps_stack[++PL_tmps_ix] =
2610                                     SvREFCNT_inc_simple_NN(rsv);
2611                 }
2612             }
2613
2614             if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2615                 hv_clear(hash);
2616
2617             /* now assign the keys and values to the hash */
2618
2619             dirty_tmps = FALSE;
2620
2621             if (UNLIKELY(gimme == G_ARRAY)) {
2622                 /* @a = (%h = (...)) etc */
2623                 SV **svp;
2624                 SV **topelem = relem;
2625
2626                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2627                     SV *key = *svp++;
2628                     SV *val = *svp;
2629                     /* remove duplicates from list we return */
2630                     if (!hv_exists_ent(hash, key, 0)) {
2631                         /* copy key back: possibly to an earlier
2632                          * stack location if we encountered dups earlier,
2633                          * The values will be updated later
2634                          */
2635                         *topelem = key;
2636                         topelem += 2;
2637                     }
2638                     /* A tied store won't take ownership of val, so keep
2639                      * the 1 refcnt on the tmps stack; otherwise disarm
2640                      * the tmps stack entry */
2641                     if (hv_store_ent(hash, key, val, 0))
2642                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2643                     else
2644                         dirty_tmps = TRUE;
2645                     /* hv_store_ent() may have added set magic to val */;
2646                     SvSETMAGIC(val);
2647                 }
2648                 if (topelem < svp) {
2649                     /* at this point we have removed the duplicate key/value
2650                      * pairs from the stack, but the remaining values may be
2651                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
2652                      * the (a 2), but the stack now probably contains
2653                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
2654                      * obliterates the earlier key. So refresh all values. */
2655                     lastrelem = topelem - 1;
2656                     while (relem < lastrelem) {
2657                         HE *he;
2658                         he = hv_fetch_ent(hash, *relem++, 0, 0);
2659                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
2660                     }
2661                 }
2662             }
2663             else {
2664                 SV **svp;
2665                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2666                     SV *key = *svp++;
2667                     SV *val = *svp;
2668                     if (hv_store_ent(hash, key, val, 0))
2669                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2670                     else
2671                         dirty_tmps = TRUE;
2672                     /* hv_store_ent() may have added set magic to val */;
2673                     SvSETMAGIC(val);
2674                 }
2675             }
2676
2677             if (dirty_tmps) {
2678                 /* there are still some 'live' recounts on the tmps stack
2679                  * - usually caused by storing into a tied hash. So let
2680                  * free_tmps() do the proper but slow job later.
2681                  * Just disarm hash refcount: see comments below about leak
2682                  */
2683                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2684             }
2685             else {
2686                 /* Quietly remove all the SVs from the tmps stack slots,
2687                  * since hash has now taken ownership of the refcnt.
2688                  * Also remove hash: which will now leak if we die before
2689                  * the SvREFCNT_dec_NN(hash) below */
2690                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2691                     Move(&PL_tmps_stack[tmps_base + nelems],
2692                          &PL_tmps_stack[tmps_base - 1],
2693                          PL_tmps_ix - (tmps_base + nelems) + 1,
2694                          SV*);
2695                 PL_tmps_ix -= (nelems + 1);
2696             }
2697
2698             SvREFCNT_dec_NN(hash);
2699
2700             relem = lastrelem + 1;
2701             goto no_relems;
2702         }
2703
2704         default:
2705             if (!SvIMMORTAL(lsv)) {
2706                 SV *ref;
2707
2708                 if (UNLIKELY(
2709                   SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
2710                   (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
2711                 ))
2712                     Perl_warner(aTHX_
2713                        packWARN(WARN_MISC),
2714                       "Useless assignment to a temporary"
2715                     );
2716
2717                 /* avoid freeing $$lsv if it might be needed for further
2718                  * elements, e.g. ($ref, $foo) = (1, $$ref) */
2719                 if (   SvROK(lsv)
2720                     && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
2721                     && lelem <= lastlelem
2722                 ) {
2723                     SSize_t ix;
2724                     SvREFCNT_inc_simple_void_NN(ref);
2725                     /* an unrolled sv_2mortal */
2726                     ix = ++PL_tmps_ix;
2727                     if (UNLIKELY(ix >= PL_tmps_max))
2728                         /* speculatively grow enough to cover other
2729                          * possible refs */
2730                          (void)tmps_grow_p(ix + (lastlelem - lelem));
2731                     PL_tmps_stack[ix] = ref;
2732                 }
2733
2734                 sv_setsv(lsv, *relem);
2735                 *relem = lsv;
2736                 SvSETMAGIC(lsv);
2737             }
2738             if (++relem > lastrelem)
2739                 goto no_relems;
2740             break;
2741         } /* switch */
2742     } /* while */
2743
2744
2745   no_relems:
2746
2747     /* simplified lelem loop for when there are no relems left */
2748     while (LIKELY(lelem <= lastlelem)) {
2749         SV *lsv = *lelem++;
2750
2751         TAINT_NOT; /* Each item stands on its own, taintwise. */
2752
2753         if (UNLIKELY(!lsv)) {
2754             lsv = *lelem++;
2755             ASSUME(SvTYPE(lsv) == SVt_PVAV);
2756         }
2757
2758         switch (SvTYPE(lsv)) {
2759         case SVt_PVAV:
2760             if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
2761                 av_clear((AV*)lsv);
2762                 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2763                     SvSETMAGIC(lsv);
2764             }
2765             break;
2766
2767         case SVt_PVHV:
2768             if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
2769                 hv_clear((HV*)lsv);
2770             break;
2771
2772         default:
2773             if (!SvIMMORTAL(lsv)) {
2774                 sv_set_undef(lsv);
2775                 SvSETMAGIC(lsv);
2776                 *relem++ = lsv;
2777             }
2778             break;
2779         } /* switch */
2780     } /* while */
2781
2782     TAINT_NOT; /* result of list assign isn't tainted */
2783
2784     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
2785         /* Will be used to set PL_tainting below */
2786         Uid_t tmp_uid  = PerlProc_getuid();
2787         Uid_t tmp_euid = PerlProc_geteuid();
2788         Gid_t tmp_gid  = PerlProc_getgid();
2789         Gid_t tmp_egid = PerlProc_getegid();
2790
2791         /* XXX $> et al currently silently ignore failures */
2792         if (PL_delaymagic & DM_UID) {
2793 #ifdef HAS_SETRESUID
2794             PERL_UNUSED_RESULT(
2795                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
2796                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
2797                          (Uid_t)-1));
2798 #elif defined(HAS_SETREUID)
2799             PERL_UNUSED_RESULT(
2800                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
2801                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
2802 #else
2803 #    ifdef HAS_SETRUID
2804             if ((PL_delaymagic & DM_UID) == DM_RUID) {
2805                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
2806                 PL_delaymagic &= ~DM_RUID;
2807             }
2808 #    endif /* HAS_SETRUID */
2809 #    ifdef HAS_SETEUID
2810             if ((PL_delaymagic & DM_UID) == DM_EUID) {
2811                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
2812                 PL_delaymagic &= ~DM_EUID;
2813             }
2814 #    endif /* HAS_SETEUID */
2815             if (PL_delaymagic & DM_UID) {
2816                 if (PL_delaymagic_uid != PL_delaymagic_euid)
2817                     DIE(aTHX_ "No setreuid available");
2818                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
2819             }
2820 #endif /* HAS_SETRESUID */
2821
2822             tmp_uid  = PerlProc_getuid();
2823             tmp_euid = PerlProc_geteuid();
2824         }
2825         /* XXX $> et al currently silently ignore failures */
2826         if (PL_delaymagic & DM_GID) {
2827 #ifdef HAS_SETRESGID
2828             PERL_UNUSED_RESULT(
2829                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
2830                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
2831                           (Gid_t)-1));
2832 #elif defined(HAS_SETREGID)
2833             PERL_UNUSED_RESULT(
2834                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
2835                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
2836 #else
2837 #    ifdef HAS_SETRGID
2838             if ((PL_delaymagic & DM_GID) == DM_RGID) {
2839                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
2840                 PL_delaymagic &= ~DM_RGID;
2841             }
2842 #    endif /* HAS_SETRGID */
2843 #    ifdef HAS_SETEGID
2844             if ((PL_delaymagic & DM_GID) == DM_EGID) {
2845                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
2846                 PL_delaymagic &= ~DM_EGID;
2847             }
2848 #    endif /* HAS_SETEGID */
2849             if (PL_delaymagic & DM_GID) {
2850                 if (PL_delaymagic_gid != PL_delaymagic_egid)
2851                     DIE(aTHX_ "No setregid available");
2852                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
2853             }
2854 #endif /* HAS_SETRESGID */
2855
2856             tmp_gid  = PerlProc_getgid();
2857             tmp_egid = PerlProc_getegid();
2858         }
2859         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
2860 #ifdef NO_TAINT_SUPPORT
2861         PERL_UNUSED_VAR(tmp_uid);
2862         PERL_UNUSED_VAR(tmp_euid);
2863         PERL_UNUSED_VAR(tmp_gid);
2864         PERL_UNUSED_VAR(tmp_egid);
2865 #endif
2866     }
2867     PL_delaymagic = old_delaymagic;
2868
2869     if (gimme == G_VOID)
2870         SP = firstrelem - 1;
2871     else if (gimme == G_SCALAR) {
2872         SP = firstrelem;
2873         EXTEND(SP,1);
2874         if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2875             SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2876         else {
2877             dTARGET;
2878             SETi(firstlelem - firstrelem);
2879         }
2880     }
2881     else
2882         SP = relem - 1;
2883
2884     RETURN;
2885 }
2886
2887 PP(pp_qr)
2888 {
2889     dSP;
2890     PMOP * const pm = cPMOP;
2891     REGEXP * rx = PM_GETRE(pm);
2892     regexp *prog = ReANY(rx);
2893     SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
2894     SV * const rv = sv_newmortal();
2895     CV **cvp;
2896     CV *cv;
2897
2898     SvUPGRADE(rv, SVt_IV);
2899     /* For a subroutine describing itself as "This is a hacky workaround" I'm
2900        loathe to use it here, but it seems to be the right fix. Or close.
2901        The key part appears to be that it's essential for pp_qr to return a new
2902        object (SV), which implies that there needs to be an effective way to
2903        generate a new SV from the existing SV that is pre-compiled in the
2904        optree.  */
2905     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
2906     SvROK_on(rv);
2907
2908     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
2909     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
2910         *cvp = cv_clone(cv);
2911         SvREFCNT_dec_NN(cv);
2912     }
2913
2914     if (pkg) {
2915         HV *const stash = gv_stashsv(pkg, GV_ADD);
2916         SvREFCNT_dec_NN(pkg);
2917         (void)sv_bless(rv, stash);
2918     }
2919
2920     if (UNLIKELY(RXp_ISTAINTED(prog))) {
2921         SvTAINTED_on(rv);
2922         SvTAINTED_on(SvRV(rv));
2923     }
2924     XPUSHs(rv);
2925     RETURN;
2926 }
2927
2928 PP(pp_match)
2929 {
2930     dSP; dTARG;
2931     PMOP *pm = cPMOP;
2932     PMOP *dynpm = pm;
2933     const char *s;
2934     const char *strend;
2935     SSize_t curpos = 0; /* initial pos() or current $+[0] */
2936     I32 global;
2937     U8 r_flags = 0;
2938     const char *truebase;                       /* Start of string  */
2939     REGEXP *rx = PM_GETRE(pm);
2940     regexp *prog = ReANY(rx);
2941     bool rxtainted;
2942     const U8 gimme = GIMME_V;
2943     STRLEN len;
2944     const I32 oldsave = PL_savestack_ix;
2945     I32 had_zerolen = 0;
2946     MAGIC *mg = NULL;
2947
2948     if (PL_op->op_flags & OPf_STACKED)
2949         TARG = POPs;
2950     else {
2951         if (ARGTARG)
2952             GETTARGET;
2953         else {
2954             TARG = DEFSV;
2955         }
2956         EXTEND(SP,1);
2957     }
2958
2959     PUTBACK;                            /* EVAL blocks need stack_sp. */
2960     /* Skip get-magic if this is a qr// clone, because regcomp has
2961        already done it. */
2962     truebase = prog->mother_re
2963          ? SvPV_nomg_const(TARG, len)
2964          : SvPV_const(TARG, len);
2965     if (!truebase)
2966         DIE(aTHX_ "panic: pp_match");
2967     strend = truebase + len;
2968     rxtainted = (RXp_ISTAINTED(prog) ||
2969                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
2970     TAINT_NOT;
2971
2972     /* We need to know this in case we fail out early - pos() must be reset */
2973     global = dynpm->op_pmflags & PMf_GLOBAL;
2974
2975     /* PMdf_USED is set after a ?? matches once */
2976     if (
2977 #ifdef USE_ITHREADS
2978         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2979 #else
2980         pm->op_pmflags & PMf_USED
2981 #endif
2982     ) {
2983         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
2984         goto nope;
2985     }
2986
2987     /* handle the empty pattern */
2988     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
2989         if (PL_curpm == PL_reg_curpm) {
2990             if (PL_curpm_under) {
2991                 if (PL_curpm_under == PL_reg_curpm) {
2992                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2993                 } else {
2994                     pm = PL_curpm_under;
2995                 }
2996             }
2997         } else {
2998             pm = PL_curpm;
2999         }
3000         rx = PM_GETRE(pm);
3001         prog = ReANY(rx);
3002     }
3003
3004     if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
3005         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
3006                                               UVuf " < %" IVdf ")\n",
3007                                               (UV)len, (IV)RXp_MINLEN(prog)));
3008         goto nope;
3009     }
3010
3011     /* get pos() if //g */
3012     if (global) {
3013         mg = mg_find_mglob(TARG);
3014         if (mg && mg->mg_len >= 0) {
3015             curpos = MgBYTEPOS(mg, TARG, truebase, len);
3016             /* last time pos() was set, it was zero-length match */
3017             if (mg->mg_flags & MGf_MINMATCH)
3018                 had_zerolen = 1;
3019         }
3020     }
3021
3022 #ifdef PERL_SAWAMPERSAND
3023     if (       RXp_NPARENS(prog)
3024             || PL_sawampersand
3025             || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3026             || (dynpm->op_pmflags & PMf_KEEPCOPY)
3027     )
3028 #endif
3029     {
3030         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
3031         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
3032          * only on the first iteration. Therefore we need to copy $' as well
3033          * as $&, to make the rest of the string available for captures in
3034          * subsequent iterations */
3035         if (! (global && gimme == G_ARRAY))
3036             r_flags |= REXEC_COPY_SKIP_POST;
3037     };
3038 #ifdef PERL_SAWAMPERSAND
3039     if (dynpm->op_pmflags & PMf_KEEPCOPY)
3040         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3041         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3042 #endif
3043
3044     s = truebase;
3045
3046   play_it_again:
3047     if (global)
3048         s = truebase + curpos;
3049
3050     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
3051                      had_zerolen, TARG, NULL, r_flags))
3052         goto nope;
3053
3054     PL_curpm = pm;
3055     if (dynpm->op_pmflags & PMf_ONCE)
3056 #ifdef USE_ITHREADS
3057         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
3058 #else
3059         dynpm->op_pmflags |= PMf_USED;
3060 #endif
3061
3062     if (rxtainted)
3063         RXp_MATCH_TAINTED_on(prog);
3064     TAINT_IF(RXp_MATCH_TAINTED(prog));
3065
3066     /* update pos */
3067
3068     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
3069         if (!mg)
3070             mg = sv_magicext_mglob(TARG);
3071         MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
3072         if (RXp_ZERO_LEN(prog))
3073             mg->mg_flags |= MGf_MINMATCH;
3074         else
3075             mg->mg_flags &= ~MGf_MINMATCH;
3076     }
3077
3078     if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
3079         LEAVE_SCOPE(oldsave);
3080         RETPUSHYES;
3081     }
3082
3083     /* push captures on stack */
3084
3085     {
3086         const I32 nparens = RXp_NPARENS(prog);
3087         I32 i = (global && !nparens) ? 1 : 0;
3088
3089         SPAGAIN;                        /* EVAL blocks could move the stack. */
3090         EXTEND(SP, nparens + i);
3091         EXTEND_MORTAL(nparens + i);
3092         for (i = !i; i <= nparens; i++) {
3093             PUSHs(sv_newmortal());
3094             if (LIKELY((RXp_OFFS(prog)[i].start != -1)
3095                      && RXp_OFFS(prog)[i].end   != -1 ))
3096             {
3097                 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
3098                 const char * const s = RXp_OFFS(prog)[i].start + truebase;
3099                 if (UNLIKELY(  RXp_OFFS(prog)[i].end   < 0
3100                             || RXp_OFFS(prog)[i].start < 0
3101                             || len < 0
3102                             || len > strend - s)
3103                 )
3104                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
3105                         "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
3106                         (long) i, (long) RXp_OFFS(prog)[i].start,
3107                         (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
3108                 sv_setpvn(*SP, s, len);
3109                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
3110                     SvUTF8_on(*SP);
3111             }
3112         }
3113         if (global) {
3114             curpos = (UV)RXp_OFFS(prog)[0].end;
3115             had_zerolen = RXp_ZERO_LEN(prog);
3116             PUTBACK;                    /* EVAL blocks may use stack */
3117             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
3118             goto play_it_again;
3119         }
3120         LEAVE_SCOPE(oldsave);
3121         RETURN;
3122     }
3123     NOT_REACHED; /* NOTREACHED */
3124
3125   nope:
3126     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
3127         if (!mg)
3128             mg = mg_find_mglob(TARG);
3129         if (mg)
3130             mg->mg_len = -1;
3131     }
3132     LEAVE_SCOPE(oldsave);
3133     if (gimme == G_ARRAY)
3134         RETURN;
3135     RETPUSHNO;
3136 }
3137
3138 OP *
3139 Perl_do_readline(pTHX)
3140 {
3141     dSP; dTARGETSTACKED;
3142     SV *sv;
3143     STRLEN tmplen = 0;
3144     STRLEN offset;
3145     PerlIO *fp;
3146     IO * const io = GvIO(PL_last_in_gv);
3147     const I32 type = PL_op->op_type;
3148     const U8 gimme = GIMME_V;
3149
3150     if (io) {
3151         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
3152         if (mg) {
3153             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
3154             if (gimme == G_SCALAR) {
3155                 SPAGAIN;
3156                 SvSetSV_nosteal(TARG, TOPs);
3157                 SETTARG;
3158             }
3159             return NORMAL;
3160         }
3161     }
3162     fp = NULL;
3163     if (io) {
3164         fp = IoIFP(io);
3165         if (!fp) {
3166             if (IoFLAGS(io) & IOf_ARGV) {
3167                 if (IoFLAGS(io) & IOf_START) {
3168                     IoLINES(io) = 0;
3169                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
3170                         IoFLAGS(io) &= ~IOf_START;
3171                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
3172                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
3173                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
3174                         SvSETMAGIC(GvSV(PL_last_in_gv));
3175                         fp = IoIFP(io);
3176                         goto have_fp;
3177                     }
3178                 }
3179                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3180                 if (!fp) { /* Note: fp != IoIFP(io) */
3181                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
3182                 }
3183             }
3184             else if (type == OP_GLOB)
3185                 fp = Perl_start_glob(aTHX_ POPs, io);
3186         }
3187         else if (type == OP_GLOB)
3188             SP--;
3189         else if (IoTYPE(io) == IoTYPE_WRONLY) {
3190             report_wrongway_fh(PL_last_in_gv, '>');
3191         }
3192     }
3193     if (!fp) {
3194         if ((!io || !(IoFLAGS(io) & IOf_START))
3195             && ckWARN(WARN_CLOSED)
3196             && type != OP_GLOB)
3197         {
3198             report_evil_fh(PL_last_in_gv);
3199         }
3200         if (gimme == G_SCALAR) {
3201             /* undef TARG, and push that undefined value */
3202             if (type != OP_RCATLINE) {
3203                 sv_set_undef(TARG);
3204             }
3205             PUSHTARG;
3206         }
3207         RETURN;
3208     }
3209   have_fp:
3210     if (gimme == G_SCALAR) {
3211         sv = TARG;
3212         if (type == OP_RCATLINE && SvGMAGICAL(sv))
3213             mg_get(sv);
3214         if (SvROK(sv)) {
3215             if (type == OP_RCATLINE)
3216                 SvPV_force_nomg_nolen(sv);
3217             else
3218                 sv_unref(sv);
3219         }
3220         else if (isGV_with_GP(sv)) {
3221             SvPV_force_nomg_nolen(sv);
3222         }
3223         SvUPGRADE(sv, SVt_PV);
3224         tmplen = SvLEN(sv);     /* remember if already alloced */
3225         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
3226             /* try short-buffering it. Please update t/op/readline.t
3227              * if you change the growth length.
3228              */
3229             Sv_Grow(sv, 80);
3230         }
3231         offset = 0;
3232         if (type == OP_RCATLINE && SvOK(sv)) {
3233             if (!SvPOK(sv)) {
3234                 SvPV_force_nomg_nolen(sv);
3235             }
3236             offset = SvCUR(sv);
3237         }
3238     }
3239     else {
3240         sv = sv_2mortal(newSV(80));
3241         offset = 0;
3242     }
3243
3244     /* This should not be marked tainted if the fp is marked clean */
3245 #define MAYBE_TAINT_LINE(io, sv) \
3246     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3247         TAINT;                          \
3248         SvTAINTED_on(sv);               \
3249     }
3250
3251 /* delay EOF state for a snarfed empty file */
3252 #define SNARF_EOF(gimme,rs,io,sv) \
3253     (gimme != G_SCALAR || SvCUR(sv)                                     \
3254      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
3255
3256     for (;;) {
3257         PUTBACK;
3258         if (!sv_gets(sv, fp, offset)
3259             && (type == OP_GLOB
3260                 || SNARF_EOF(gimme, PL_rs, io, sv)
3261                 || PerlIO_error(fp)))
3262         {
3263             PerlIO_clearerr(fp);
3264             if (IoFLAGS(io) & IOf_ARGV) {
3265                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3266                 if (fp)
3267                     continue;
3268                 (void)do_close(PL_last_in_gv, FALSE);
3269             }
3270             else if (type == OP_GLOB) {
3271                 if (!do_close(PL_last_in_gv, FALSE)) {
3272                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3273                                    "glob failed (child exited with status %d%s)",
3274                                    (int)(STATUS_CURRENT >> 8),
3275                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
3276                 }
3277             }
3278             if (gimme == G_SCALAR) {
3279                 if (type != OP_RCATLINE) {
3280                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
3281                     SvOK_off(TARG);
3282                 }
3283                 SPAGAIN;
3284                 PUSHTARG;
3285             }
3286             MAYBE_TAINT_LINE(io, sv);
3287             RETURN;
3288         }
3289         MAYBE_TAINT_LINE(io, sv);
3290         IoLINES(io)++;
3291         IoFLAGS(io) |= IOf_NOLINE;
3292         SvSETMAGIC(sv);
3293         SPAGAIN;
3294         XPUSHs(sv);
3295         if (type == OP_GLOB) {
3296             const char *t1;
3297             Stat_t statbuf;
3298
3299             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
3300                 char * const tmps = SvEND(sv) - 1;
3301                 if (*tmps == *SvPVX_const(PL_rs)) {
3302                     *tmps = '\0';
3303                     SvCUR_set(sv, SvCUR(sv) - 1);
3304                 }
3305             }
3306             for (t1 = SvPVX_const(sv); *t1; t1++)
3307 #ifdef __VMS
3308                 if (strchr("*%?", *t1))
3309 #else
3310                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
3311 #endif
3312                         break;
3313             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
3314                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
3315                 continue;
3316             }
3317         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
3318              if (ckWARN(WARN_UTF8)) {
3319                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3320                 const STRLEN len = SvCUR(sv) - offset;
3321                 const U8 *f;
3322
3323                 if (!is_utf8_string_loc(s, len, &f))
3324                     /* Emulate :encoding(utf8) warning in the same case. */
3325                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
3326                                 "utf8 \"\\x%02X\" does not map to Unicode",
3327                                 f < (U8*)SvEND(sv) ? *f : 0);
3328              }
3329         }
3330         if (gimme == G_ARRAY) {
3331             if (SvLEN(sv) - SvCUR(sv) > 20) {
3332                 SvPV_shrink_to_cur(sv);
3333             }
3334             sv = sv_2mortal(newSV(80));
3335             continue;
3336         }
3337         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
3338             /* try to reclaim a bit of scalar space (only on 1st alloc) */
3339             const STRLEN new_len
3340                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
3341             SvPV_renew(sv, new_len);
3342         }
3343         RETURN;
3344     }
3345 }
3346
3347 PP(pp_helem)
3348 {
3349     dSP;
3350     HE* he;
3351     SV **svp;
3352     SV * const keysv = POPs;
3353     HV * const hv = MUTABLE_HV(POPs);
3354     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3355     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3356     SV *sv;
3357     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3358     bool preeminent = TRUE;
3359
3360     if (SvTYPE(hv) != SVt_PVHV)
3361         RETPUSHUNDEF;
3362
3363     if (localizing) {
3364         MAGIC *mg;
3365         HV *stash;
3366
3367         /* If we can determine whether the element exist,
3368          * Try to preserve the existenceness of a tied hash
3369          * element by using EXISTS and DELETE if possible.
3370          * Fallback to FETCH and STORE otherwise. */
3371         if (SvCANEXISTDELETE(hv))
3372             preeminent = hv_exists_ent(hv, keysv, 0);
3373     }
3374
3375     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3376     svp = he ? &HeVAL(he) : NULL;
3377     if (lval) {
3378         if (!svp || !*svp || *svp == &PL_sv_undef) {
3379             SV* lv;
3380             SV* key2;
3381             if (!defer) {
3382                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3383             }
3384             lv = sv_newmortal();
3385             sv_upgrade(lv, SVt_PVLV);
3386             LvTYPE(lv) = 'y';
3387             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
3388             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
3389             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3390             LvTARGLEN(lv) = 1;
3391             PUSHs(lv);
3392             RETURN;
3393         }
3394         if (localizing) {
3395             if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
3396                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
3397             else if (preeminent)
3398                 save_helem_flags(hv, keysv, svp,
3399                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3400             else
3401                 SAVEHDELETE(hv, keysv);
3402         }
3403         else if (PL_op->op_private & OPpDEREF) {
3404             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3405             RETURN;
3406         }
3407     }
3408     sv = (svp && *svp ? *svp : &PL_sv_undef);
3409     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3410      * was to make C<local $tied{foo} = $tied{foo}> possible.
3411      * However, it seems no longer to be needed for that purpose, and
3412      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3413      * would loop endlessly since the pos magic is getting set on the
3414      * mortal copy and lost. However, the copy has the effect of
3415      * triggering the get magic, and losing it altogether made things like
3416      * c<$tied{foo};> in void context no longer do get magic, which some
3417      * code relied on. Also, delayed triggering of magic on @+ and friends
3418      * meant the original regex may be out of scope by now. So as a
3419      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3420      * being called too many times). */
3421     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
3422         mg_get(sv);
3423     PUSHs(sv);
3424     RETURN;
3425 }
3426
3427
3428 /* a stripped-down version of Perl_softref2xv() for use by
3429  * pp_multideref(), which doesn't use PL_op->op_flags */
3430
3431 STATIC GV *
3432 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3433                 const svtype type)
3434 {
3435     if (PL_op->op_private & HINT_STRICT_REFS) {
3436         if (SvOK(sv))
3437             Perl_die(aTHX_ PL_no_symref_sv, sv,
3438                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3439         else
3440             Perl_die(aTHX_ PL_no_usym, what);
3441     }
3442     if (!SvOK(sv))
3443         Perl_die(aTHX_ PL_no_usym, what);
3444     return gv_fetchsv_nomg(sv, GV_ADD, type);
3445 }
3446
3447
3448 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
3449  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
3450  *
3451  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
3452  * Each of these either contains a set of actions, or an argument, such as
3453  * an IV to use as an array index, or a lexical var to retrieve.
3454  * Several actions re stored per UV; we keep shifting new actions off the
3455  * one UV, and only reload when it becomes zero.
3456  */
3457
3458 PP(pp_multideref)
3459 {
3460     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3461     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3462     UV actions = items->uv;
3463
3464     assert(actions);
3465     /* this tells find_uninit_var() where we're up to */
3466     PL_multideref_pc = items;
3467
3468     while (1) {
3469         /* there are three main classes of action; the first retrieve
3470          * the initial AV or HV from a variable or the stack; the second
3471          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3472          * the third an unrolled (/DREFHV, rv2hv, helem).
3473          */
3474         switch (actions & MDEREF_ACTION_MASK) {
3475
3476         case MDEREF_reload:
3477             actions = (++items)->uv;
3478             continue;
3479
3480         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
3481             sv = PAD_SVl((++items)->pad_offset);
3482             goto do_AV_aelem;
3483
3484         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
3485             sv = UNOP_AUX_item_sv(++items);
3486             assert(isGV_with_GP(sv));
3487             sv = (SV*)GvAVn((GV*)sv);
3488             goto do_AV_aelem;
3489
3490         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
3491             {
3492                 dSP;
3493                 sv = POPs;
3494                 PUTBACK;
3495                 goto do_AV_rv2av_aelem;
3496             }
3497
3498         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
3499             sv = UNOP_AUX_item_sv(++items);
3500             assert(isGV_with_GP(sv));
3501             sv = GvSVn((GV*)sv);
3502             goto do_AV_vivify_rv2av_aelem;
3503
3504         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
3505             sv = PAD_SVl((++items)->pad_offset);
3506             /* FALLTHROUGH */
3507
3508         do_AV_vivify_rv2av_aelem:
3509         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
3510             /* this is the OPpDEREF action normally found at the end of
3511              * ops like aelem, helem, rv2sv */
3512             sv = vivify_ref(sv, OPpDEREF_AV);
3513             /* FALLTHROUGH */
3514
3515         do_AV_rv2av_aelem:
3516             /* this is basically a copy of pp_rv2av when it just has the
3517              * sKR/1 flags */
3518             SvGETMAGIC(sv);
3519             if (LIKELY(SvROK(sv))) {
3520                 if (UNLIKELY(SvAMAGIC(sv))) {
3521                     sv = amagic_deref_call(sv, to_av_amg);
3522                 }
3523                 sv = SvRV(sv);
3524                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3525                     DIE(aTHX_ "Not an ARRAY reference");
3526             }
3527             else if (SvTYPE(sv) != SVt_PVAV) {
3528                 if (!isGV_with_GP(sv))
3529                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3530                 sv = MUTABLE_SV(GvAVn((GV*)sv));
3531             }
3532             /* FALLTHROUGH */
3533
3534         do_AV_aelem:
3535             {
3536                 /* retrieve the key; this may be either a lexical or package
3537                  * var (whose index/ptr is stored as an item) or a signed
3538                  * integer constant stored as an item.
3539                  */
3540                 SV *elemsv;
3541                 IV elem = 0; /* to shut up stupid compiler warnings */
3542
3543
3544                 assert(SvTYPE(sv) == SVt_PVAV);
3545
3546                 switch (actions & MDEREF_INDEX_MASK) {
3547                 case MDEREF_INDEX_none:
3548                     goto finish;
3549                 case MDEREF_INDEX_const:
3550                     elem  = (++items)->iv;
3551                     break;
3552                 case MDEREF_INDEX_padsv:
3553                     elemsv = PAD_SVl((++items)->pad_offset);
3554                     goto check_elem;
3555                 case MDEREF_INDEX_gvsv:
3556                     elemsv = UNOP_AUX_item_sv(++items);
3557                     assert(isGV_with_GP(elemsv));
3558                     elemsv = GvSVn((GV*)elemsv);
3559                 check_elem:
3560                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
3561                                             && ckWARN(WARN_MISC)))
3562                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3563                                 "Use of reference \"%" SVf "\" as array index",
3564                                 SVfARG(elemsv));
3565                     /* the only time that S_find_uninit_var() needs this
3566                      * is to determine which index value triggered the
3567                      * undef warning. So just update it here. Note that
3568                      * since we don't save and restore this var (e.g. for
3569                      * tie or overload execution), its value will be
3570                      * meaningless apart from just here */
3571                     PL_multideref_pc = items;
3572                     elem = SvIV(elemsv);
3573                     break;
3574                 }
3575
3576
3577                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
3578
3579                 if (!(actions & MDEREF_FLAG_last)) {
3580                     SV** svp = av_fetch((AV*)sv, elem, 1);
3581                     if (!svp || ! (sv=*svp))
3582                         DIE(aTHX_ PL_no_aelem, elem);
3583                     break;
3584                 }
3585
3586                 if (PL_op->op_private &
3587                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3588                 {
3589                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3590                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
3591                     }
3592                     else {
3593                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3594                         sv = av_delete((AV*)sv, elem, discard);
3595                         if (discard)
3596                             return NORMAL;
3597                         if (!sv)
3598                             sv = &PL_sv_undef;
3599                     }
3600                 }
3601                 else {
3602                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3603                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3604                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3605                     bool preeminent = TRUE;
3606                     AV *const av = (AV*)sv;
3607                     SV** svp;
3608
3609                     if (UNLIKELY(localizing)) {
3610                         MAGIC *mg;
3611                         HV *stash;
3612
3613                         /* If we can determine whether the element exist,
3614                          * Try to preserve the existenceness of a tied array
3615                          * element by using EXISTS and DELETE if possible.
3616                          * Fallback to FETCH and STORE otherwise. */
3617                         if (SvCANEXISTDELETE(av))
3618                             preeminent = av_exists(av, elem);
3619                     }
3620
3621                     svp = av_fetch(av, elem, lval && !defer);
3622
3623                     if (lval) {
3624                         if (!svp || !(sv = *svp)) {
3625                             IV len;
3626                             if (!defer)
3627                                 DIE(aTHX_ PL_no_aelem, elem);
3628                             len = av_tindex(av);
3629                             sv = sv_2mortal(newSVavdefelem(av,
3630                             /* Resolve a negative index now, unless it points
3631                              * before the beginning of the array, in which
3632                              * case record it for error reporting in
3633                              * magic_setdefelem. */
3634                                 elem < 0 && len + elem >= 0
3635                                     ? len + elem : elem, 1));
3636                         }
3637                         else {
3638                             if (UNLIKELY(localizing)) {
3639                                 if (preeminent) {
3640                                     save_aelem(av, elem, svp);
3641                                     sv = *svp; /* may have changed */
3642                                 }
3643                                 else
3644                                     SAVEADELETE(av, elem);
3645                             }
3646                         }
3647                     }
3648                     else {
3649                         sv = (svp ? *svp : &PL_sv_undef);
3650                         /* see note in pp_helem() */
3651                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3652                             mg_get(sv);
3653                     }
3654                 }
3655
3656             }
3657           finish:
3658             {
3659                 dSP;
3660                 XPUSHs(sv);
3661                 RETURN;
3662             }
3663             /* NOTREACHED */
3664
3665
3666
3667
3668         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
3669             sv = PAD_SVl((++items)->pad_offset);
3670             goto do_HV_helem;
3671
3672         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
3673             sv = UNOP_AUX_item_sv(++items);
3674             assert(isGV_with_GP(sv));
3675             sv = (SV*)GvHVn((GV*)sv);
3676             goto do_HV_helem;
3677
3678         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
3679             {
3680                 dSP;
3681                 sv = POPs;
3682                 PUTBACK;
3683                 goto do_HV_rv2hv_helem;
3684             }
3685
3686         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
3687             sv = UNOP_AUX_item_sv(++items);
3688             assert(isGV_with_GP(sv));
3689             sv = GvSVn((GV*)sv);
3690             goto do_HV_vivify_rv2hv_helem;
3691
3692         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
3693             sv = PAD_SVl((++items)->pad_offset);
3694             /* FALLTHROUGH */
3695
3696         do_HV_vivify_rv2hv_helem:
3697         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
3698             /* this is the OPpDEREF action normally found at the end of
3699              * ops like aelem, helem, rv2sv */
3700             sv = vivify_ref(sv, OPpDEREF_HV);
3701             /* FALLTHROUGH */
3702
3703         do_HV_rv2hv_helem:
3704             /* this is basically a copy of pp_rv2hv when it just has the
3705              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3706
3707             SvGETMAGIC(sv);
3708             if (LIKELY(SvROK(sv))) {
3709                 if (UNLIKELY(SvAMAGIC(sv))) {
3710                     sv = amagic_deref_call(sv, to_hv_amg);
3711                 }
3712                 sv = SvRV(sv);
3713                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3714                     DIE(aTHX_ "Not a HASH reference");
3715             }
3716             else if (SvTYPE(sv) != SVt_PVHV) {
3717                 if (!isGV_with_GP(sv))
3718                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3719                 sv = MUTABLE_SV(GvHVn((GV*)sv));
3720             }
3721             /* FALLTHROUGH */
3722
3723         do_HV_helem:
3724             {
3725                 /* retrieve the key; this may be either a lexical / package
3726                  * var or a string constant, whose index/ptr is stored as an
3727                  * item
3728                  */
3729                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3730
3731                 assert(SvTYPE(sv) == SVt_PVHV);
3732
3733                 switch (actions & MDEREF_INDEX_MASK) {
3734                 case MDEREF_INDEX_none:
3735                     goto finish;
3736
3737                 case MDEREF_INDEX_const:
3738                     keysv = UNOP_AUX_item_sv(++items);
3739                     break;
3740
3741                 case MDEREF_INDEX_padsv:
3742                     keysv = PAD_SVl((++items)->pad_offset);
3743                     break;
3744
3745                 case MDEREF_INDEX_gvsv:
3746                     keysv = UNOP_AUX_item_sv(++items);
3747                     keysv = GvSVn((GV*)keysv);
3748                     break;
3749                 }
3750
3751                 /* see comment above about setting this var */
3752                 PL_multideref_pc = items;
3753
3754
3755                 /* ensure that candidate CONSTs have been HEKified */
3756                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3757                        || SvTYPE(keysv) >= SVt_PVMG
3758                        || !SvOK(keysv)
3759                        || SvROK(keysv)
3760                        || SvIsCOW_shared_hash(keysv));
3761
3762                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3763
3764                 if (!(actions & MDEREF_FLAG_last)) {
3765                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3766                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3767                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3768                     break;
3769                 }
3770
3771                 if (PL_op->op_private &
3772                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3773                 {
3774                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3775                         sv = hv_exists_ent((HV*)sv, keysv, 0)
3776                                                 ? &PL_sv_yes : &PL_sv_no;
3777                     }
3778                     else {
3779                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3780                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3781                         if (discard)
3782                             return NORMAL;
3783                         if (!sv)
3784                             sv = &PL_sv_undef;
3785                     }
3786                 }
3787                 else {
3788                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3789                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3790                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3791                     bool preeminent = TRUE;
3792                     SV **svp;
3793                     HV * const hv = (HV*)sv;
3794                     HE* he;
3795
3796                     if (UNLIKELY(localizing)) {
3797                         MAGIC *mg;
3798                         HV *stash;
3799
3800                         /* If we can determine whether the element exist,
3801                          * Try to preserve the existenceness of a tied hash
3802                          * element by using EXISTS and DELETE if possible.
3803                          * Fallback to FETCH and STORE otherwise. */
3804                         if (SvCANEXISTDELETE(hv))
3805                             preeminent = hv_exists_ent(hv, keysv, 0);
3806                     }
3807
3808                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3809                     svp = he ? &HeVAL(he) : NULL;
3810
3811
3812                     if (lval) {
3813                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
3814                             SV* lv;
3815                             SV* key2;
3816                             if (!defer)
3817                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3818                             lv = sv_newmortal();
3819                             sv_upgrade(lv, SVt_PVLV);
3820                             LvTYPE(lv) = 'y';
3821                             sv_magic(lv, key2 = newSVsv(keysv),
3822                                                 PERL_MAGIC_defelem, NULL, 0);
3823                             /* sv_magic() increments refcount */
3824                             SvREFCNT_dec_NN(key2);
3825                             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3826                             LvTARGLEN(lv) = 1;
3827                             sv = lv;
3828                         }
3829                         else {
3830                             if (localizing) {
3831                                 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
3832                                     save_gp(MUTABLE_GV(sv),
3833                                         !(PL_op->op_flags & OPf_SPECIAL));
3834                                 else if (preeminent) {
3835                                     save_helem_flags(hv, keysv, svp,
3836                                          (PL_op->op_flags & OPf_SPECIAL)
3837                                             ? 0 : SAVEf_SETMAGIC);
3838                                     sv = *svp; /* may have changed */
3839                                 }
3840                                 else
3841                                     SAVEHDELETE(hv, keysv);
3842                             }
3843                         }
3844                     }
3845                     else {
3846                         sv = (svp && *svp ? *svp : &PL_sv_undef);
3847                         /* see note in pp_helem() */
3848                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
3849                             mg_get(sv);
3850                     }
3851                 }
3852                 goto finish;
3853             }
3854
3855         } /* switch */
3856
3857         actions >>= MDEREF_SHIFT;
3858     } /* while */
3859     /* NOTREACHED */
3860 }
3861
3862
3863 PP(pp_iter)
3864 {
3865     PERL_CONTEXT *cx;
3866     SV *oldsv;
3867     SV **itersvp;
3868
3869     SV *sv;
3870     AV *av;
3871     IV ix;
3872     IV inc;
3873
3874     cx = CX_CUR();
3875     itersvp = CxITERVAR(cx);
3876     assert(itersvp);
3877
3878     switch (CxTYPE(cx)) {
3879
3880     case CXt_LOOP_LAZYSV: /* string increment */
3881     {
3882         SV* cur = cx->blk_loop.state_u.lazysv.cur;
3883         SV *end = cx->blk_loop.state_u.lazysv.end;
3884         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
3885            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
3886         STRLEN maxlen = 0;
3887         const char *max = SvPV_const(end, maxlen);
3888         if (DO_UTF8(end) && IN_UNI_8_BIT)
3889             maxlen = sv_len_utf8_nomg(end);
3890         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
3891             goto retno;
3892
3893         oldsv = *itersvp;
3894         /* NB: on the first iteration, oldsv will have a ref count of at
3895          * least 2 (one extra from blk_loop.itersave), so the GV or pad
3896          * slot will get localised; on subsequent iterations the RC==1
3897          * optimisation may kick in and the SV will be reused. */
3898          if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3899             /* safe to reuse old SV */
3900             sv_setsv(oldsv, cur);
3901         }
3902         else
3903         {
3904             /* we need a fresh SV every time so that loop body sees a
3905              * completely new SV for closures/references to work as
3906              * they used to */
3907             *itersvp = newSVsv(cur);
3908             SvREFCNT_dec(oldsv);
3909         }
3910         if (strEQ(SvPVX_const(cur), max))
3911             sv_setiv(cur, 0); /* terminate next time */
3912         else
3913             sv_inc(cur);
3914         break;
3915     }
3916
3917     case CXt_LOOP_LAZYIV: /* integer increment */
3918     {
3919         IV cur = cx->blk_loop.state_u.lazyiv.cur;
3920         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
3921             goto retno;
3922
3923         oldsv = *itersvp;
3924         /* see NB comment above */
3925         if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3926             /* safe to reuse old SV */
3927
3928             if (    (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
3929                  == SVt_IV)
3930             {
3931                 /* Cheap SvIOK_only().
3932                  * Assert that flags which SvIOK_only() would test or
3933                  * clear can't be set, because we're SVt_IV */
3934                 assert(!(SvFLAGS(oldsv) &
3935                     (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
3936                 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
3937                 /* SvIV_set() where sv_any points to head */
3938                 oldsv->sv_u.svu_iv = cur;
3939
3940             }
3941             else
3942                 sv_setiv(oldsv, cur);
3943         }
3944         else
3945         {
3946             /* we need a fresh SV every time so that loop body sees a
3947              * completely new SV for closures/references to work as they
3948              * used to */
3949             *itersvp = newSViv(cur);
3950             SvREFCNT_dec(oldsv);
3951         }
3952
3953         if (UNLIKELY(cur == IV_MAX)) {
3954             /* Handle end of range at IV_MAX */
3955             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
3956         } else
3957             ++cx->blk_loop.state_u.lazyiv.cur;
3958         break;
3959     }
3960
3961     case CXt_LOOP_LIST: /* for (1,2,3) */
3962
3963         assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
3964         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3965         ix = (cx->blk_loop.state_u.stack.ix += inc);
3966         if (UNLIKELY(inc > 0
3967                         ? ix > cx->blk_oldsp
3968                         : ix <= cx->blk_loop.state_u.stack.basesp)
3969         )
3970             goto retno;
3971
3972         sv = PL_stack_base[ix];
3973         av = NULL;
3974         goto loop_ary_common;
3975
3976     case CXt_LOOP_ARY: /* for (@ary) */
3977
3978         av = cx->blk_loop.state_u.ary.ary;
3979         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3980         ix = (cx->blk_loop.state_u.ary.ix += inc);
3981         if (UNLIKELY(inc > 0
3982                         ? ix > AvFILL(av)
3983                         : ix < 0)
3984         )
3985             goto retno;
3986
3987         if (UNLIKELY(SvRMAGICAL(av))) {
3988             SV * const * const svp = av_fetch(av, ix, FALSE);
3989             sv = svp ? *svp : NULL;
3990         }
3991         else {
3992             sv = AvARRAY(av)[ix];
3993         }
3994
3995       loop_ary_common:
3996
3997         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
3998             SvSetMagicSV(*itersvp, sv);
3999             break;
4000         }
4001
4002         if (LIKELY(sv)) {
4003             if (UNLIKELY(SvIS_FREED(sv))) {
4004                 *itersvp = NULL;
4005                 Perl_croak(aTHX_ "Use of freed value in iteration");
4006             }
4007             if (SvPADTMP(sv)) {
4008                 sv = newSVsv(sv);
4009             }
4010             else {
4011                 SvTEMP_off(sv);
4012                 SvREFCNT_inc_simple_void_NN(sv);
4013             }
4014         }
4015         else if (av) {
4016             sv = newSVavdefelem(av, ix, 0);
4017         }
4018         else
4019             sv = &PL_sv_undef;
4020
4021         oldsv = *itersvp;
4022         *itersvp = sv;
4023         SvREFCNT_dec(oldsv);
4024         break;
4025
4026     default:
4027         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
4028     }
4029
4030     /* Bypass pushing &PL_sv_yes and calling pp_and(); instead
4031      * jump straight to the AND op's op_other */
4032     assert(PL_op->op_next->op_type == OP_AND);
4033     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
4034     return cLOGOPx(PL_op->op_next)->op_other;
4035
4036   retno:
4037     /* Bypass pushing &PL_sv_no and calling pp_and(); instead
4038      * jump straight to the AND op's op_next */
4039     assert(PL_op->op_next->op_type == OP_AND);
4040     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
4041     /* pp_enteriter should have pre-extended the stack */
4042     EXTEND_SKIP(PL_stack_sp, 1);
4043     /* we only need this for the rare case where the OP_AND isn't
4044      * in void context, e.g. $x = do { for (..) {...} };
4045      * but its cheaper to just push it rather than testing first
4046      */
4047     *++PL_stack_sp = &PL_sv_no;
4048     return PL_op->op_next->op_next;
4049 }
4050
4051
4052 /*
4053 A description of how taint works in pattern matching and substitution.
4054
4055 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
4056 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
4057
4058 While the pattern is being assembled/concatenated and then compiled,
4059 PL_tainted will get set (via TAINT_set) if any component of the pattern
4060 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
4061 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
4062 TAINT_get).  It will also be set if any component of the pattern matches
4063 based on locale-dependent behavior.
4064
4065 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
4066 the pattern is marked as tainted. This means that subsequent usage, such
4067 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
4068 on the new pattern too.
4069
4070 RXf_TAINTED_SEEN is used post-execution by the get magic code
4071 of $1 et al to indicate whether the returned value should be tainted.
4072 It is the responsibility of the caller of the pattern (i.e. pp_match,
4073 pp_subst etc) to set this flag for any other circumstances where $1 needs
4074 to be tainted.
4075
4076 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
4077
4078 There are three possible sources of taint
4079     * the source string
4080     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
4081     * the replacement string (or expression under /e)
4082     
4083 There are four destinations of taint and they are affected by the sources
4084 according to the rules below:
4085
4086     * the return value (not including /r):
4087         tainted by the source string and pattern, but only for the
4088         number-of-iterations case; boolean returns aren't tainted;
4089     * the modified string (or modified copy under /r):
4090         tainted by the source string, pattern, and replacement strings;
4091     * $1 et al:
4092         tainted by the pattern, and under 'use re "taint"', by the source
4093         string too;
4094     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
4095         should always be unset before executing subsequent code.
4096
4097 The overall action of pp_subst is:
4098
4099     * at the start, set bits in rxtainted indicating the taint status of
4100         the various sources.
4101
4102     * After each pattern execution, update the SUBST_TAINT_PAT bit in
4103         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
4104         pattern has subsequently become tainted via locale ops.
4105
4106     * If control is being passed to pp_substcont to execute a /e block,
4107         save rxtainted in the CXt_SUBST block, for future use by
4108         pp_substcont.
4109
4110     * Whenever control is being returned to perl code (either by falling
4111         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
4112         use the flag bits in rxtainted to make all the appropriate types of
4113         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
4114         et al will appear tainted.
4115
4116 pp_match is just a simpler version of the above.
4117
4118 */
4119
4120 PP(pp_subst)
4121 {
4122     dSP; dTARG;
4123     PMOP *pm = cPMOP;
4124     PMOP *rpm = pm;
4125     char *s;
4126     char *strend;
4127     const char *c;
4128     STRLEN clen;
4129     SSize_t iters = 0;
4130     SSize_t maxiters;
4131     bool once;
4132     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
4133                         See "how taint works" above */
4134     char *orig;
4135     U8 r_flags;
4136     REGEXP *rx = PM_GETRE(pm);
4137     regexp *prog = ReANY(rx);
4138     STRLEN len;
4139     int force_on_match = 0;
4140     const I32 oldsave = PL_savestack_ix;
4141     STRLEN slen;
4142     bool doutf8 = FALSE; /* whether replacement is in utf8 */
4143 #ifdef PERL_ANY_COW
4144     bool was_cow;
4145 #endif
4146     SV *nsv = NULL;
4147     /* known replacement string? */
4148     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
4149
4150     PERL_ASYNC_CHECK();
4151
4152     if (PL_op->op_flags & OPf_STACKED)
4153         TARG = POPs;
4154     else {
4155         if (ARGTARG)
4156             GETTARGET;
4157         else {
4158             TARG = DEFSV;
4159         }
4160         EXTEND(SP,1);
4161     }
4162
4163     SvGETMAGIC(TARG); /* must come before cow check */
4164 #ifdef PERL_ANY_COW
4165     /* note that a string might get converted to COW during matching */
4166     was_cow = cBOOL(SvIsCOW(TARG));
4167 #endif
4168     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4169 #ifndef PERL_ANY_COW
4170         if (SvIsCOW(TARG))
4171             sv_force_normal_flags(TARG,0);
4172 #endif
4173         if ((SvREADONLY(TARG)
4174                 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
4175                       || SvTYPE(TARG) > SVt_PVLV)
4176                      && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
4177             Perl_croak_no_modify();
4178     }
4179     PUTBACK;
4180
4181     orig = SvPV_nomg(TARG, len);
4182     /* note we don't (yet) force the var into being a string; if we fail
4183      * to match, we leave as-is; on successful match however, we *will*
4184      * coerce into a string, then repeat the match */
4185     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
4186         force_on_match = 1;
4187
4188     /* only replace once? */
4189     once = !(rpm->op_pmflags & PMf_GLOBAL);
4190
4191     /* See "how taint works" above */
4192     if (TAINTING_get) {
4193         rxtainted  = (
4194             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
4195           | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
4196           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
4197           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4198                 ? SUBST_TAINT_BOOLRET : 0));
4199         TAINT_NOT;
4200     }
4201
4202   force_it:
4203     if (!pm || !orig)
4204         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
4205
4206     strend = orig + len;
4207     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
4208     maxiters = 2 * slen + 10;   /* We can match twice at each
4209                                    position, once with zero-length,
4210                                    second time with non-zero. */
4211
4212     /* handle the empty pattern */
4213     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
4214         if (PL_curpm == PL_reg_curpm) {
4215             if (PL_curpm_under) {
4216                 if (PL_curpm_under == PL_reg_curpm) {
4217                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
4218                 } else {
4219                     pm = PL_curpm_under;
4220                 }
4221             }
4222         } else {
4223             pm = PL_curpm;
4224         }
4225         rx = PM_GETRE(pm);
4226         prog = ReANY(rx);
4227     }
4228
4229 #ifdef PERL_SAWAMPERSAND
4230     r_flags = (    RXp_NPARENS(prog)
4231                 || PL_sawampersand
4232                 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
4233                 || (rpm->op_pmflags & PMf_KEEPCOPY)
4234               )
4235           ? REXEC_COPY_STR
4236           : 0;
4237 #else
4238     r_flags = REXEC_COPY_STR;
4239 #endif
4240
4241     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
4242     {
4243         SPAGAIN;
4244         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
4245         LEAVE_SCOPE(oldsave);
4246         RETURN;
4247     }
4248     PL_curpm = pm;
4249
4250     /* known replacement string? */
4251     if (dstr) {
4252         /* replacement needing upgrading? */
4253         if (DO_UTF8(TARG) && !doutf8) {
4254              nsv = sv_newmortal();
4255              SvSetSV(nsv, dstr);
4256              sv_utf8_upgrade(nsv);
4257              c = SvPV_const(nsv, clen);
4258              doutf8 = TRUE;
4259         }
4260         else {
4261             c = SvPV_const(dstr, clen);
4262             doutf8 = DO_UTF8(dstr);
4263         }
4264
4265         if (UNLIKELY(TAINT_get))
4266             rxtainted |= SUBST_TAINT_REPL;
4267     }
4268     else {
4269         c = NULL;
4270         doutf8 = FALSE;
4271     }
4272     
4273     /* can do inplace substitution? */
4274     if (c
4275 #ifdef PERL_ANY_COW
4276         && !was_cow
4277 #endif
4278         && (I32)clen <= RXp_MINLENRET(prog)
4279         && (  once
4280            || !(r_flags & REXEC_COPY_STR)
4281            || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
4282            )
4283         && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
4284         && (!doutf8 || SvUTF8(TARG))
4285         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4286     {
4287
4288 #ifdef PERL_ANY_COW
4289         /* string might have got converted to COW since we set was_cow */
4290         if (SvIsCOW(TARG)) {
4291           if (!force_on_match)
4292             goto have_a_cow;
4293           assert(SvVOK(TARG));
4294         }
4295 #endif
4296         if (force_on_match) {
4297             /* redo the first match, this time with the orig var
4298              * forced into being a string */
4299             force_on_match = 0;
4300             orig = SvPV_force_nomg(TARG, len);
4301             goto force_it;
4302         }
4303
4304         if (once) {
4305             char *d, *m;
4306             if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4307                 rxtainted |= SUBST_TAINT_PAT;
4308             m = orig + RXp_OFFS(prog)[0].start;
4309             d = orig + RXp_OFFS(prog)[0].end;
4310             s = orig;
4311             if (m - s > strend - d) {  /* faster to shorten from end */
4312                 I32 i;
4313                 if (clen) {
4314                     Copy(c, m, clen, char);
4315                     m += clen;
4316                 }
4317                 i = strend - d;
4318                 if (i > 0) {
4319                     Move(d, m, i, char);
4320                     m += i;
4321                 }
4322                 *m = '\0';
4323                 SvCUR_set(TARG, m - s);
4324             }
4325             else {      /* faster from front */
4326                 I32 i = m - s;
4327                 d -= clen;
4328                 if (i > 0)
4329                     Move(s, d - i, i, char);
4330                 sv_chop(TARG, d-i);
4331                 if (clen)
4332                     Copy(c, d, clen, char);
4333             }
4334             SPAGAIN;
4335             PUSHs(&PL_sv_yes);
4336         }
4337         else {
4338             char *d, *m;
4339             d = s = RXp_OFFS(prog)[0].start + orig;
4340             do {
4341                 I32 i;
4342                 if (UNLIKELY(iters++ > maxiters))
4343                     DIE(aTHX_ "Substitution loop");
4344                 /* run time pattern taint, eg locale */
4345                 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4346                     rxtainted |= SUBST_TAINT_PAT;
4347                 m = RXp_OFFS(prog)[0].start + orig;
4348                 if ((i = m - s)) {
4349                     if (s != d)
4350                         Move(s, d, i, char);
4351                     d += i;
4352                 }
4353                 if (clen) {
4354                     Copy(c, d, clen, char);
4355                     d += clen;
4356                 }
4357                 s = RXp_OFFS(prog)[0].end + orig;
4358             } while (CALLREGEXEC(rx, s, strend, orig,
4359                                  s == m, /* don't match same null twice */
4360                                  TARG, NULL,
4361                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4362             if (s != d) {
4363                 I32 i = strend - s;
4364                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
4365                 Move(s, d, i+1, char);          /* include the NUL */
4366             }
4367             SPAGAIN;
4368             if (PL_op->op_private & OPpTRUEBOOL)
4369                 PUSHs(iters ? &PL_sv_yes : &PL_sv_zero);
4370             else
4371                 mPUSHi(iters);
4372         }
4373     }
4374     else {
4375         bool first;
4376         char *m;
4377         SV *repl;
4378         if (force_on_match) {
4379             /* redo the first match, this time with the orig var
4380              * forced into being a string */
4381             force_on_match = 0;
4382             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4383                 /* I feel that it should be possible to avoid this mortal copy
4384                    given that the code below copies into a new destination.
4385                    However, I suspect it isn't worth the complexity of
4386                    unravelling the C<goto force_it> for the small number of
4387                    cases where it would be viable to drop into the copy code. */
4388                 TARG = sv_2mortal(newSVsv(TARG));
4389             }
4390             orig = SvPV_force_nomg(TARG, len);
4391             goto force_it;
4392         }
4393 #ifdef PERL_ANY_COW
4394       have_a_cow:
4395 #endif
4396         if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4397             rxtainted |= SUBST_TAINT_PAT;
4398         repl = dstr;
4399         s = RXp_OFFS(prog)[0].start + orig;
4400         dstr = newSVpvn_flags(orig, s-orig,
4401                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
4402         if (!c) {
4403             PERL_CONTEXT *cx;
4404             SPAGAIN;
4405             m = orig;
4406             /* note that a whole bunch of local vars are saved here for
4407              * use by pp_substcont: here's a list of them in case you're
4408              * searching for places in this sub that uses a particular var:
4409              * iters maxiters r_flags oldsave rxtainted orig dstr targ
4410              * s m strend rx once */
4411             CX_PUSHSUBST(cx);
4412             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
4413         }
4414         first = TRUE;
4415         do {
4416             if (UNLIKELY(iters++ > maxiters))
4417                 DIE(aTHX_ "Substitution loop");
4418             if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4419                 rxtainted |= SUBST_TAINT_PAT;
4420             if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
4421                 char *old_s    = s;
4422                 char *old_orig = orig;
4423                 assert(RXp_SUBOFFSET(prog) == 0);
4424
4425                 orig = RXp_SUBBEG(prog);
4426                 s = orig + (old_s - old_orig);
4427                 strend = s + (strend - old_s);
4428             }
4429             m = RXp_OFFS(prog)[0].start + orig;
4430             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
4431             s = RXp_OFFS(prog)[0].end + orig;
4432             if (first) {
4433                 /* replacement already stringified */
4434               if (clen)
4435                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
4436               first = FALSE;
4437             }
4438             else {
4439                 sv_catsv(dstr, repl);
4440             }
4441             if (once)
4442                 break;
4443         } while (CALLREGEXEC(rx, s, strend, orig,
4444                              s == m,    /* Yields minend of 0 or 1 */
4445                              TARG, NULL,
4446                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4447         assert(strend >= s);
4448         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
4449
4450         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4451             /* From here on down we're using the copy, and leaving the original
4452                untouched.  */
4453             TARG = dstr;
4454             SPAGAIN;
4455             PUSHs(dstr);
4456         } else {
4457 #ifdef PERL_ANY_COW
4458             /* The match may make the string COW. If so, brilliant, because
4459                that's just saved us one malloc, copy and free - the regexp has
4460                donated the old buffer, and we malloc an entirely new one, rather
4461                than the regexp malloc()ing a buffer and copying our original,
4462                only for us to throw it away here during the substitution.  */
4463             if (SvIsCOW(TARG)) {
4464                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
4465             } else
4466 #endif
4467             {
4468                 SvPV_free(TARG);
4469             }
4470             SvPV_set(TARG, SvPVX(dstr));
4471             SvCUR_set(TARG, SvCUR(dstr));
4472             SvLEN_set(TARG, SvLEN(dstr));
4473             SvFLAGS(TARG) |= SvUTF8(dstr);
4474             SvPV_set(dstr, NULL);
4475
4476             SPAGAIN;
4477             mPUSHi(iters);
4478         }
4479     }
4480
4481     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4482         (void)SvPOK_only_UTF8(TARG);
4483     }
4484
4485     /* See "how taint works" above */
4486     if (TAINTING_get) {
4487         if ((rxtainted & SUBST_TAINT_PAT) ||
4488             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
4489                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
4490         )
4491             (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
4492
4493         if (!(rxtainted & SUBST_TAINT_BOOLRET)
4494             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
4495         )
4496             SvTAINTED_on(TOPs);  /* taint return value */
4497         else
4498             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
4499
4500         /* needed for mg_set below */
4501         TAINT_set(
4502           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
4503         );
4504         SvTAINT(TARG);
4505     }
4506     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
4507     TAINT_NOT;
4508     LEAVE_SCOPE(oldsave);
4509     RETURN;
4510 }
4511
4512 PP(pp_grepwhile)
4513 {
4514     dSP;
4515     dPOPss;
4516
4517     if (SvTRUE_NN(sv))
4518         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
4519     ++*PL_markstack_ptr;
4520     FREETMPS;
4521     LEAVE_with_name("grep_item");                                       /* exit inner scope */
4522
4523     /* All done yet? */
4524     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
4525         I32 items;
4526         const U8 gimme = GIMME_V;
4527
4528         LEAVE_with_name("grep");                                        /* exit outer scope */
4529         (void)POPMARK;                          /* pop src */
4530         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
4531         (void)POPMARK;                          /* pop dst */
4532         SP = PL_stack_base + POPMARK;           /* pop original mark */
4533         if (gimme == G_SCALAR) {
4534             if (PL_op->op_private & OPpTRUEBOOL)
4535                 PUSHs(items ? &PL_sv_yes : &PL_sv_zero);
4536             else {
4537                 dTARGET;
4538                 PUSHi(items);
4539             }
4540         }
4541         else if (gimme == G_ARRAY)
4542             SP += items;
4543         RETURN;
4544     }
4545     else {
4546         SV *src;
4547
4548         ENTER_with_name("grep_item");                                   /* enter inner scope */
4549         SAVEVPTR(PL_curpm);
4550
4551         src = PL_stack_base[TOPMARK];
4552         if (SvPADTMP(src)) {
4553             src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
4554             PL_tmps_floor++;
4555         }
4556         SvTEMP_off(src);
4557         DEFSV_set(src);
4558
4559         RETURNOP(cLOGOP->op_other);
4560     }
4561 }
4562
4563 /* leave_adjust_stacks():
4564  *
4565  * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
4566  * positioning them at to_sp+1 onwards, and do the equivalent of a
4567  * FREEMPS and TAINT_NOT.
4568  *
4569  * Not intended to be called in void context.
4570  *
4571  * When leaving a sub, eval, do{} or other scope, the things that need
4572  * doing to process the return args are:
4573  *    * in scalar context, only return the last arg (or PL_sv_undef if none);
4574  *    * for the types of return that return copies of their args (such
4575  *      as rvalue sub return), make a mortal copy of every return arg,
4576  *      except where we can optimise the copy away without it being
4577  *      semantically visible;
4578  *    * make sure that the arg isn't prematurely freed; in the case of an
4579  *      arg not copied, this may involve mortalising it. For example, in
4580  *      C<sub f { my $x = ...; $x }>, $x would be freed when we do
4581  *      CX_LEAVE_SCOPE(cx) unless it's protected or copied.
4582  *
4583  * What condition to use when deciding whether to pass the arg through
4584  * or make a copy, is determined by the 'pass' arg; its valid values are:
4585  *   0: rvalue sub/eval exit
4586  *   1: other rvalue scope exit
4587  *   2: :lvalue sub exit in rvalue context
4588  *   3: :lvalue sub exit in lvalue context and other lvalue scope exits
4589  *
4590  * There is a big issue with doing a FREETMPS. We would like to free any
4591  * temps created by the last statement which the sub executed, rather than
4592  * leaving them for the caller. In a situation where a sub call isn't
4593  * soon followed by a nextstate (e.g. nested recursive calls, a la
4594  * fibonacci()), temps can accumulate, causing memory and performance
4595  * issues.
4596  *
4597  * On the other hand, we don't want to free any TEMPs which are keeping
4598  * alive any return args that we skipped copying; nor do we wish to undo
4599  * any mortalising done here.
4600  *
4601  * The solution is to split the temps stack frame into two, with a cut
4602  * point delineating the two halves. We arrange that by the end of this
4603  * function, all the temps stack frame entries we wish to keep are in the
4604  * range  PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
4605  * the range  tmps_base .. PL_tmps_ix.  During the course of this
4606  * function, tmps_base starts off as PL_tmps_floor+1, then increases
4607  * whenever we find or create a temp that we know should be kept. In
4608  * general the stuff above tmps_base is undecided until we reach the end,
4609  * and we may need a sort stage for that.
4610  *
4611  * To determine whether a TEMP is keeping a return arg alive, every
4612  * arg that is kept rather than copied and which has the SvTEMP flag
4613  * set, has the flag temporarily unset, to mark it. At the end we scan
4614  * the temps stack frame above the cut for entries without SvTEMP and
4615  * keep them, while turning SvTEMP on again. Note that if we die before
4616  * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
4617  * those SVs may be slightly less efficient.
4618  *
4619  * In practice various optimisations for some common cases mean we can
4620  * avoid most of the scanning and swapping about with the temps stack.
4621  */
4622
4623 void
4624 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
4625 {
4626     dVAR;
4627     dSP;
4628     SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
4629     SSize_t nargs;
4630
4631     PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
4632
4633     TAINT_NOT;
4634
4635     if (gimme == G_ARRAY) {
4636         nargs = SP - from_sp;
4637         from_sp++;
4638     }
4639     else {
4640         assert(gimme == G_SCALAR);
4641         if (UNLIKELY(from_sp >= SP)) {
4642             /* no return args */
4643             assert(from_sp == SP);
4644             EXTEND(SP, 1);
4645             *++SP = &PL_sv_undef;
4646             to_sp = SP;
4647             nargs   = 0;
4648         }
4649         else {
4650             from_sp = SP;
4651             nargs   = 1;
4652         }
4653     }
4654
4655     /* common code for G_SCALAR and G_ARRAY */
4656
4657     tmps_base = PL_tmps_floor + 1;
4658
4659     assert(nargs >= 0);
4660     if (nargs) {
4661         /* pointer version of tmps_base. Not safe across temp stack
4662          * reallocs. */
4663         SV **tmps_basep;
4664
4665         EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
4666         tmps_basep = PL_tmps_stack + tmps_base;
4667
4668         /* process each return arg */
4669
4670         do {
4671             SV *sv = *from_sp++;
4672
4673             assert(PL_tmps_ix + nargs < PL_tmps_max);
4674 #ifdef DEBUGGING
4675             /* PADTMPs with container set magic shouldn't appear in the
4676              * wild. This assert is more important for pp_leavesublv(),
4677              * but by testing for it here, we're more likely to catch
4678              * bad cases (what with :lvalue subs not being widely
4679              * deployed). The two issues are that for something like
4680              *     sub :lvalue { $tied{foo} }
4681              * or
4682              *     sub :lvalue { substr($foo,1,2) }
4683              * pp_leavesublv() will croak if the sub returns a PADTMP,
4684              * and currently functions like pp_substr() return a mortal
4685              * rather than using their PADTMP when returning a PVLV.
4686              * This is because the PVLV will hold a ref to $foo,
4687              * so $foo would get delayed in being freed while
4688              * the PADTMP SV remained in the PAD.
4689              * So if this assert fails it means either:
4690              *  1) there is pp code similar to pp_substr that is
4691              *     returning a PADTMP instead of a mortal, and probably
4692              *     needs fixing, or
4693              *  2) pp_leavesublv is making unwarranted assumptions
4694              *     about always croaking on a PADTMP
4695              */
4696             if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
4697                 MAGIC *mg;
4698                 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
4699                     assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
4700                 }
4701             }
4702 #endif
4703
4704             if (
4705                pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
4706              : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
4707              : pass == 2 ? (!SvPADTMP(sv))
4708              : 1)
4709             {
4710                 /* pass through: skip copy for logic or optimisation
4711                  * reasons; instead mortalise it, except that ... */
4712                 *++to_sp = sv;
4713
4714                 if (SvTEMP(sv)) {
4715                     /* ... since this SV is an SvTEMP , we don't need to
4716                      * re-mortalise it; instead we just need to ensure
4717                      * that its existing entry in the temps stack frame
4718                      * ends up below the cut and so avoids being freed
4719                      * this time round. We mark it as needing to be kept
4720                      * by temporarily unsetting SvTEMP; then at the end,
4721                      * we shuffle any !SvTEMP entries on the tmps stack
4722                      * back below the cut.
4723                      * However, there's a significant chance that there's
4724                      * a 1:1 correspondence between the first few (or all)
4725                      * elements in the return args stack frame and those
4726                      * in the temps stack frame; e,g.:
4727                      *      sub f { ....; map {...} .... },
4728                      * or if we're exiting multiple scopes and one of the
4729                      * inner scopes has already made mortal copies of each
4730                      * return arg.
4731                      *
4732                      * If so, this arg sv will correspond to the next item
4733                      * on the tmps stack above the cut, and so can be kept
4734                      * merely by moving the cut boundary up one, rather
4735                      * than messing with SvTEMP.  If all args are 1:1 then
4736                      * we can avoid the sorting stage below completely.
4737                      *
4738                      * If there are no items above the cut on the tmps
4739                      * stack, then the SvTEMP must comne from an item
4740                      * below the cut, so there's nothing to do.
4741                      */
4742                     if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
4743                         if (sv == *tmps_basep)
4744                             tmps_basep++;
4745                         else
4746                             SvTEMP_off(sv);
4747                     }
4748                 }
4749                 else if (!SvPADTMP(sv)) {
4750                     /* mortalise arg to avoid it being freed during save
4751                      * stack unwinding. Pad tmps don't need mortalising as
4752                      * they're never freed. This is the equivalent of
4753                      * sv_2mortal(SvREFCNT_inc(sv)), except that:
4754                      *  * it assumes that the temps stack has already been
4755                      *    extended;
4756                      *  * it puts the new item at the cut rather than at
4757                      *    ++PL_tmps_ix, moving the previous occupant there
4758                      *    instead.
4759                      */
4760                     if (!SvIMMORTAL(sv)) {
4761                         SvREFCNT_inc_simple_void_NN(sv);
4762                         SvTEMP_on(sv);
4763                         /* Note that if there's nothing above the cut,
4764                          * this copies the garbage one slot above
4765                          * PL_tmps_ix onto itself. This is harmless (the
4766                          * stack's already been extended), but might in
4767                          * theory trigger warnings from tools like ASan
4768                          */
4769                         PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
4770                         *tmps_basep++ = sv;
4771                     }
4772                 }
4773             }
4774             else {
4775                 /* Make a mortal copy of the SV.
4776                  * The following code is the equivalent of sv_mortalcopy()
4777                  * except that:
4778                  *  * it assumes the temps stack has already been extended;
4779                  *  * it optimises the copying for some simple SV types;
4780                  *  * it puts the new item at the cut rather than at
4781                  *    ++PL_tmps_ix, moving the previous occupant there
4782                  *    instead.
4783                  */
4784                 SV *newsv = newSV(0);
4785
4786                 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
4787                 /* put it on the tmps stack early so it gets freed if we die */
4788                 *tmps_basep++ = newsv;
4789                 *++to_sp = newsv;
4790
4791                 if (SvTYPE(sv) <= SVt_IV) {
4792                     /* arg must be one of undef, IV/UV, or RV: skip
4793                      * sv_setsv_flags() and do the copy directly */
4794                     U32 dstflags;
4795                     U32 srcflags = SvFLAGS(sv);
4796
4797                     assert(!SvGMAGICAL(sv));
4798                     if (srcflags & (SVf_IOK|SVf_ROK)) {
4799                         SET_SVANY_FOR_BODYLESS_IV(newsv);
4800
4801                         if (srcflags & SVf_ROK) {
4802                             newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
4803                             /* SV type plus flags */
4804                             dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
4805                         }
4806                         else {
4807                             /* both src and dst are <= SVt_IV, so sv_any
4808                              * points to the head; so access the heads
4809                              * directly rather than going via sv_any.
4810                              */
4811                             assert(    &(sv->sv_u.svu_iv)
4812                                     == &(((XPVIV*) SvANY(sv))->xiv_iv));
4813                             assert(    &(newsv->sv_u.svu_iv)
4814                                     == &(((XPVIV*) SvANY(newsv))->xiv_iv));
4815                             newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
4816                             /* SV type plus flags */
4817                             dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
4818                                             |(srcflags & SVf_IVisUV));
4819                         }
4820                     }
4821                     else {
4822                         assert(!(srcflags & SVf_OK));
4823                         dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
4824                     }
4825                     SvFLAGS(newsv) = dstflags;
4826
4827                 }
4828                 else {
4829                     /* do the full sv_setsv() */
4830                     SSize_t old_base;
4831
4832                     SvTEMP_on(newsv);
4833                     old_base = tmps_basep - PL_tmps_stack;
4834                     SvGETMAGIC(sv);
4835                     sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
4836                     /* the mg_get or sv_setsv might have created new temps
4837                      * or realloced the tmps stack; regrow and reload */
4838                     EXTEND_MORTAL(nargs);
4839                     tmps_basep = PL_tmps_stack + old_base;
4840                     TAINT_NOT;  /* Each item is independent */
4841                 }
4842
4843             }
4844         } while (--nargs);
4845
4846         /* If there are any temps left above the cut, we need to sort
4847          * them into those to keep and those to free. The only ones to
4848          * keep are those for which we've temporarily unset SvTEMP.
4849          * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
4850          * swapping pairs as necessary. Stop when we meet in the middle.
4851          */
4852         {
4853             SV **top = PL_tmps_stack + PL_tmps_ix;
4854             while (tmps_basep <= top) {
4855                 SV *sv = *top;
4856                 if (SvTEMP(sv))
4857                     top--;
4858                 else {
4859                     SvTEMP_on(sv);
4860                     *top = *tmps_basep;
4861                     *tmps_basep = sv;
4862                     tmps_basep++;
4863                 }
4864             }
4865         }
4866
4867         tmps_base = tmps_basep - PL_tmps_stack;
4868     }
4869
4870     PL_stack_sp = to_sp;
4871
4872     /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
4873     while (PL_tmps_ix >= tmps_base) {
4874         SV* const sv = PL_tmps_stack[PL_tmps_ix--];
4875 #ifdef PERL_POISON
4876         PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
4877 #endif
4878         if (LIKELY(sv)) {
4879             SvTEMP_off(sv);
4880             SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
4881         }
4882     }
4883 }
4884
4885
4886 /* also tail-called by pp_return */
4887
4888 PP(pp_leavesub)
4889 {
4890     U8 gimme;
4891     PERL_CONTEXT *cx;
4892     SV **oldsp;
4893     OP *retop;
4894
4895     cx = CX_CUR();
4896     assert(CxTYPE(cx) == CXt_SUB);
4897
4898     if (CxMULTICALL(cx)) {
4899         /* entry zero of a stack is always PL_sv_undef, which
4900          * simplifies converting a '()' return into undef in scalar context */
4901         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
4902         return 0;
4903     }
4904
4905     gimme = cx->blk_gimme;
4906     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
4907
4908     if (gimme == G_VOID)
4909         PL_stack_sp = oldsp;
4910     else
4911         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4912
4913     CX_LEAVE_SCOPE(cx);
4914     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
4915     cx_popblock(cx);
4916     retop = cx->blk_sub.retop;
4917     CX_POP(cx);
4918
4919     return retop;
4920 }
4921
4922
4923 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
4924  * forces an abandon */
4925
4926 void
4927 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
4928 {
4929     const SSize_t fill = AvFILLp(av);
4930
4931     PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
4932
4933     if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
4934         av_clear(av);
4935         AvREIFY_only(av);
4936     }
4937     else {
4938         AV *newav = newAV();
4939         av_extend(newav, fill);
4940         AvREIFY_only(newav);
4941         PAD_SVl(0) = MUTABLE_SV(newav);
4942         SvREFCNT_dec_NN(av);
4943     }
4944 }
4945
4946
4947 PP(pp_entersub)
4948 {
4949     dSP; dPOPss;
4950     GV *gv;
4951     CV *cv;
4952     PERL_CONTEXT *cx;
4953     I32 old_savestack_ix;
4954
4955     if (UNLIKELY(!sv))
4956         goto do_die;
4957
4958     /* Locate the CV to call:
4959      * - most common case: RV->CV: f(), $ref->():
4960      *   note that if a sub is compiled before its caller is compiled,
4961      *   the stash entry will be a ref to a CV, rather than being a GV.
4962      * - second most common case: CV: $ref->method()
4963      */
4964
4965     /* a non-magic-RV -> CV ? */
4966     if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
4967         cv = MUTABLE_CV(SvRV(sv));
4968         if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
4969             goto do_ref;
4970     }
4971     else
4972         cv = MUTABLE_CV(sv);
4973
4974     /* a CV ? */
4975     if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
4976         /* handle all the weird cases */
4977         switch (SvTYPE(sv)) {
4978         case SVt_PVLV:
4979             if (!isGV_with_GP(sv))
4980                 goto do_default;
4981             /* FALLTHROUGH */
4982         case SVt_PVGV:
4983             cv = GvCVu((const GV *)sv);
4984             if (UNLIKELY(!cv)) {
4985                 HV *stash;
4986                 cv = sv_2cv(sv, &stash, &gv, 0);
4987                 if (!cv) {
4988                     old_savestack_ix = PL_savestack_ix;
4989                     goto try_autoload;
4990                 }
4991             }
4992             break;
4993
4994         default:
4995           do_default:
4996             SvGETMAGIC(sv);
4997             if (SvROK(sv)) {
4998               do_ref:
4999                 if (UNLIKELY(SvAMAGIC(sv))) {
5000                     sv = amagic_deref_call(sv, to_cv_amg);
5001                     /* Don't SPAGAIN here.  */
5002                 }
5003             }
5004             else {
5005                 const char *sym;
5006                 STRLEN len;
5007                 if (UNLIKELY(!SvOK(sv)))
5008                     DIE(aTHX_ PL_no_usym, "a subroutine");
5009
5010                 sym = SvPV_nomg_const(sv, len);
5011                 if (PL_op->op_private & HINT_STRICT_REFS)
5012                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
5013                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
5014                 break;
5015             }
5016             cv = MUTABLE_CV(SvRV(sv));
5017             if (LIKELY(SvTYPE(cv) == SVt_PVCV))
5018                 break;
5019             /* FALLTHROUGH */
5020         case SVt_PVHV:
5021         case SVt_PVAV:
5022           do_die:
5023             DIE(aTHX_ "Not a CODE reference");
5024         }
5025     }
5026
5027     /* At this point we want to save PL_savestack_ix, either by doing a
5028      * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
5029      * CV we will be using (so we don't know whether its XS, so we can't
5030      * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
5031      * the save stack. So remember where we are currently on the save
5032      * stack, and later update the CX or scopestack entry accordingly. */
5033     old_savestack_ix = PL_savestack_ix;
5034
5035     /* these two fields are in a union. If they ever become separate,
5036      * we have to test for both of them being null below */
5037     assert(cv);
5038     assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
5039     while (UNLIKELY(!CvROOT(cv))) {
5040         GV* autogv;
5041         SV* sub_name;
5042
5043         /* anonymous or undef'd function leaves us no recourse */
5044         if (CvLEXICAL(cv) && CvHASGV(cv))
5045             DIE(aTHX_ "Undefined subroutine &%" SVf " called",
5046            &