Bump the perl version in various places for 5.27.9
[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             SSize_t len, extra;
818
819             len = svpv_p->len;
820             if (len <= 0) {
821                 svpv_p->len = -len;
822                 continue;
823             }
824
825             extra = variant_under_utf8_count((U8 *) svpv_p->pv,
826                                              (U8 *) svpv_p->pv + len);
827             if (UNLIKELY(extra)) {
828                 grow       += extra;
829                               /* -ve len indicates special handling */
830                 svpv_p->len = -(len + extra);
831                 slow_concat = TRUE;
832             }
833         }
834     }
835     else
836         const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
837
838     /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
839      * already have been dropped */
840     assert(!SvIsCOW(dsv));
841     dsv_pv = (SvLEN(dsv) < (grow) ? sv_grow(dsv,grow) : SvPVX(dsv));
842
843
844     /* --------------------------------------------------------------
845      * Phase 4:
846      *
847      * Now that dsv (which is probably targ) has been grown, we know the
848      * final address of the targ PVX, if needed. Preserve / move targ
849      * contents if appending or if targ appears on RHS.
850      *
851      * Also update svpv_buf slots in targ_chain.
852      *
853      * Don't bother with any of this if the target length is zero:
854      * targ_len is set to zero unless we're appending or targ appears on
855      * RHS.  And even if it is, we can optimise by skipping this chunk of
856      * code for zero targ_len. In the latter case, we don't need to update
857      * the slots in targ_chain with the (zero length) target string, since
858      * we set the len in such slots to 0 earlier, and since the Copy() is
859      * skipped on zero length, it doesn't matter what svpv_p->pv contains.
860      *
861      * On entry to this section the (pv,len) pairs in svpv_buf have the
862      * following meanings:
863      *    (pv,  len)         a pure-plain or utf8 string
864      *    (pv, -(len+extra)) a plain string which will expand by 'extra'
865      *                         bytes when converted to utf8
866      *    (NULL,  0)         left-most targ \ linked together R-to-L
867      *    (next,  0)         other targ     / in targ_chain
868      *
869      * On exit, the targ contents will have been moved to the
870      * earliest place they are needed (e.g. $x = "abc$x" will shift them
871      * 3 bytes, while $x .= ... will leave them at the beginning);
872      * and dst_pv will point to the location within SvPVX(dsv) where the
873      * next arg should be copied.
874      */
875
876     svpv_base = svpv_buf;
877
878     if (targ_len) {
879         struct multiconcat_svpv *tc_stop;
880         char *targ_pv = dsv_pv;
881
882         assert(targ == dsv);
883         assert(is_append || targ_count);
884
885         if (is_append) {
886             dsv_pv += targ_len;
887             tc_stop = NULL;
888         }
889         else {
890             /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
891              * Move the current contents of targ to the first
892              * position where it's needed, and use that as the src buffer
893              * for any further uses (such as the second RHS $t above).
894              * In calculating the first position, we need to sum the
895              * lengths of all consts and args before that.
896              */
897
898             UNOP_AUX_item *lens = const_lens;
899                                 /* length of first const string segment */
900             STRLEN offset       = lens->ssize > 0 ? lens->ssize : 0;
901
902             assert(targ_chain);
903             svpv_p = svpv_base;
904
905             for (;;) {
906                 SSize_t len;
907                 if (!svpv_p->pv)
908                     break; /* the first targ argument */
909                 /* add lengths of the next arg and const string segment */
910                 len = svpv_p->len;
911                 if (len < 0)  /* variant args have this */
912                     len = -len;
913                 offset += (STRLEN)len;
914                 len = (++lens)->ssize;
915                 offset += (len >= 0) ? (STRLEN)len : 0;
916                 if (!offset) {
917                     /* all args and consts so far are empty; update
918                      * the start position for the concat later */
919                     svpv_base++;
920                     const_lens++;
921                 }
922                 svpv_p++;
923                 assert(svpv_p < svpv_end);
924             }
925
926             if (offset) {
927                 targ_pv += offset;
928                 Move(dsv_pv, targ_pv, targ_len, char);
929                 /* a negative length implies don't Copy(), but do increment */
930                 svpv_p->len = -((SSize_t)targ_len);
931                 slow_concat = TRUE;
932             }
933             else {
934                 /* skip the first targ copy */
935                 svpv_base++;
936                 const_lens++;
937                 dsv_pv += targ_len;
938             }
939
940             /* Don't populate the first targ slot in the loop below; it's
941              * either not used because we advanced svpv_base beyond it, or
942              * we already stored the special -targ_len value in it
943              */
944             tc_stop = svpv_p;
945         }
946
947         /* populate slots in svpv_buf representing targ on RHS */
948         while (targ_chain != tc_stop) {
949             struct multiconcat_svpv *p = targ_chain;
950             targ_chain = (struct multiconcat_svpv *)(p->pv);
951             p->pv  = targ_pv;
952             p->len = (SSize_t)targ_len;
953         }
954     }
955
956
957     /* --------------------------------------------------------------
958      * Phase 5:
959      *
960      * Append all the args in svpv_buf, plus the const strings, to dsv.
961      *
962      * On entry to this section the (pv,len) pairs in svpv_buf have the
963      * following meanings:
964      *    (pv,  len)         a pure-plain or utf8 string (which may be targ)
965      *    (pv, -(len+extra)) a plain string which will expand by 'extra'
966      *                         bytes when converted to utf8
967      *    (0,  -len)         left-most targ, whose content has already
968      *                         been copied. Just advance dsv_pv by len.
969      */
970
971     /* If there are no constant strings and no special case args
972      * (svpv_p->len < 0), use a simpler, more efficient concat loop
973      */
974     if (!slow_concat) {
975         for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
976             SSize_t len = svpv_p->len;
977             if (!len)
978                 continue;
979             Copy(svpv_p->pv, dsv_pv, len, char);
980             dsv_pv += len;
981         }
982         const_lens += (svpv_end - svpv_base + 1);
983     }
984     else {
985         /* Note that we iterate the loop nargs+1 times: to append nargs
986          * arguments and nargs+1 constant strings. For example, "-$a-$b-"
987          */
988         svpv_p = svpv_base - 1;
989
990         for (;;) {
991             SSize_t len = (const_lens++)->ssize;
992
993             /* append next const string segment */
994             if (len > 0) {
995                 Copy(const_pv, dsv_pv, len, char);
996                 dsv_pv   += len;
997                 const_pv += len;
998             }
999
1000             if (++svpv_p == svpv_end)
1001                 break;
1002
1003             /* append next arg */
1004             len = svpv_p->len;
1005
1006             if (LIKELY(len > 0)) {
1007                 Copy(svpv_p->pv, dsv_pv, len, char);
1008                 dsv_pv += len;
1009             }
1010             else if (UNLIKELY(len < 0)) {
1011                 /* negative length indicates two special cases */
1012                 const char *p = svpv_p->pv;
1013                 len = -len;
1014                 if (UNLIKELY(p)) {
1015                     /* copy plain-but-variant pv to a utf8 targ */
1016                     char * end_pv = dsv_pv + len;
1017                     assert(dst_utf8);
1018                     while (dsv_pv < end_pv) {
1019                         U8 c = (U8) *p++;
1020                         append_utf8_from_native_byte(c, (U8**)&dsv_pv);
1021                     }
1022                 }
1023                 else
1024                     /* arg is already-copied targ */
1025                     dsv_pv += len;
1026             }
1027
1028         }
1029     }
1030
1031     *dsv_pv = '\0';
1032     SvCUR_set(dsv, dsv_pv - SvPVX(dsv));
1033     assert(grow >= SvCUR(dsv) + 1);
1034     assert(SvLEN(dsv) >= SvCUR(dsv) + 1);
1035
1036     /* --------------------------------------------------------------
1037      * Phase 6:
1038      *
1039      * Handle overloading. If an overloaded arg or targ was detected
1040      * earlier, dsv will have been set to a new mortal, and any args and
1041      * consts to the left of the first overloaded arg will have been
1042      * accumulated to it. This section completes any further concatenation
1043      * steps with overloading handled.
1044      */
1045
1046     if (UNLIKELY(dsv != targ)) {
1047         SV *res;
1048
1049         SvFLAGS(dsv) |= dst_utf8;
1050
1051         if (SP <= toparg) {
1052             /* Stringifying the RHS was abandoned because *SP
1053              * is overloaded. dsv contains all the concatted strings
1054              * before *SP. Apply the rest of the args using overloading.
1055              */
1056             SV *left, *right, *res;
1057             int i;
1058             bool getmg = FALSE;
1059                                /* number of args already concatted */
1060             SSize_t n         = (nargs - 1) - (toparg - SP);
1061                                /* current arg is either the first
1062                                 * or second value to be concatted
1063                                 * (including constant strings), so would
1064                                 * form part of the first concat */
1065             bool first_concat = (    n == 0
1066                                  || (n == 1 && const_lens[-2].ssize < 0
1067                                             && const_lens[-1].ssize < 0));
1068             int  f_assign     = first_concat ? 0 : AMGf_assign;
1069
1070             left = dsv;
1071
1072             for (; n < nargs; n++) {
1073                 /* loop twice, first applying the arg, then the const segment */
1074                 for (i = 0; i < 2; i++) {
1075                     if (i) {
1076                         /* append next const string segment */
1077                         STRLEN len = (STRLEN)((const_lens++)->ssize);
1078                         /* a length of -1 implies no constant string
1079                          * rather than a zero-length one, e.g.
1080                          * ($a . $b) versus ($a . "" . $b)
1081                          */
1082                         if ((SSize_t)len < 0)
1083                             continue;
1084
1085                         /* set right to the next constant string segment */
1086                         right = newSVpvn_flags(const_pv, len,
1087                                                     (dst_utf8 | SVs_TEMP));
1088                         const_pv += len;
1089                     }
1090                     else {
1091                         /* append next arg */
1092                         right = *SP++;
1093                         if (getmg)
1094                             SvGETMAGIC(right);
1095                         else
1096                             /* SvGETMAGIC already called on this SV just
1097                              * before we broke from the loop earlier */
1098                             getmg = TRUE;
1099
1100                         if (first_concat && n == 0 && const_lens[-1].ssize < 0) {
1101                             /* nothing before the current arg; repeat the
1102                              * loop to get a second arg */
1103                             left = right;
1104                             first_concat = FALSE;
1105                             continue;
1106                         }
1107                     }
1108
1109                     if ((SvAMAGIC(left) || SvAMAGIC(right))
1110                         && (res = amagic_call(left, right, concat_amg, f_assign))
1111                     )
1112                         left = res;
1113                     else {
1114                         if (left != dsv) {
1115                             sv_setsv(dsv, left);
1116                             left = dsv;
1117                         }
1118                         sv_catsv_nomg(left, right);
1119                     }
1120                     f_assign = AMGf_assign;
1121                 }
1122             }
1123             dsv = left;
1124         }
1125
1126         /* assign/append RHS (dsv) to LHS (targ) */
1127         if (is_append)  {
1128             if ((SvAMAGIC(targ) || SvAMAGIC(dsv))
1129                 && (res = amagic_call(targ, dsv, concat_amg, AMGf_assign))
1130             )
1131                 sv_setsv(targ, res);
1132             else
1133                 sv_catsv_nomg(targ, dsv);
1134         }
1135         else
1136             sv_setsv(targ, dsv);
1137     }
1138
1139     /* --------------------------------------------------------------
1140      * Phase 7:
1141      *
1142      * return result
1143      */
1144
1145   phase7:
1146
1147     SP -= stack_adj;
1148     SvTAINT(targ);
1149     SETTARG;
1150     RETURN;
1151 }
1152
1153
1154 /* push the elements of av onto the stack.
1155  * Returns PL_op->op_next to allow tail-call optimisation of its callers */
1156
1157 STATIC OP*
1158 S_pushav(pTHX_ AV* const av)
1159 {
1160     dSP;
1161     const SSize_t maxarg = AvFILL(av) + 1;
1162     EXTEND(SP, maxarg);
1163     if (UNLIKELY(SvRMAGICAL(av))) {
1164         PADOFFSET i;
1165         for (i=0; i < (PADOFFSET)maxarg; i++) {
1166             SV ** const svp = av_fetch(av, i, FALSE);
1167             SP[i+1] = LIKELY(svp)
1168                        ? *svp
1169                        : UNLIKELY(PL_op->op_flags & OPf_MOD)
1170                           ? newSVavdefelem(av,i,1)
1171                           : &PL_sv_undef;
1172         }
1173     }
1174     else {
1175         PADOFFSET i;
1176         for (i=0; i < (PADOFFSET)maxarg; i++) {
1177             SV *sv = AvARRAY(av)[i];
1178             if (!LIKELY(sv))
1179                 AvARRAY(av)[i] = sv = newSV(0);
1180             SP[i+1] = LIKELY(sv)
1181                        ? sv
1182                        : UNLIKELY(PL_op->op_flags & OPf_MOD)
1183                           ? newSVavdefelem(av,i,1)
1184                           : &PL_sv_undef;
1185         }
1186     }
1187     SP += maxarg;
1188     PUTBACK;
1189     return NORMAL;
1190 }
1191
1192
1193 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
1194
1195 PP(pp_padrange)
1196 {
1197     dSP;
1198     PADOFFSET base = PL_op->op_targ;
1199     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
1200     if (PL_op->op_flags & OPf_SPECIAL) {
1201         /* fake the RHS of my ($x,$y,..) = @_ */
1202         PUSHMARK(SP);
1203         (void)S_pushav(aTHX_ GvAVn(PL_defgv));
1204         SPAGAIN;
1205     }
1206
1207     /* note, this is only skipped for compile-time-known void cxt */
1208     if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
1209         int i;
1210
1211         EXTEND(SP, count);
1212         PUSHMARK(SP);
1213         for (i = 0; i <count; i++)
1214             *++SP = PAD_SV(base+i);
1215     }
1216     if (PL_op->op_private & OPpLVAL_INTRO) {
1217         SV **svp = &(PAD_SVl(base));
1218         const UV payload = (UV)(
1219                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1220                     | (count << SAVE_TIGHT_SHIFT)
1221                     | SAVEt_CLEARPADRANGE);
1222         int i;
1223
1224         STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
1225         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1226                 == (Size_t)base);
1227         {
1228             dSS_ADD;
1229             SS_ADD_UV(payload);
1230             SS_ADD_END(1);
1231         }
1232
1233         for (i = 0; i <count; i++)
1234             SvPADSTALE_off(*svp++); /* mark lexical as active */
1235     }
1236     RETURN;
1237 }
1238
1239
1240 PP(pp_padsv)
1241 {
1242     dSP;
1243     EXTEND(SP, 1);
1244     {
1245         OP * const op = PL_op;
1246         /* access PL_curpad once */
1247         SV ** const padentry = &(PAD_SVl(op->op_targ));
1248         {
1249             dTARG;
1250             TARG = *padentry;
1251             PUSHs(TARG);
1252             PUTBACK; /* no pop/push after this, TOPs ok */
1253         }
1254         if (op->op_flags & OPf_MOD) {
1255             if (op->op_private & OPpLVAL_INTRO)
1256                 if (!(op->op_private & OPpPAD_STATE))
1257                     save_clearsv(padentry);
1258             if (op->op_private & OPpDEREF) {
1259                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
1260                    than TARG reduces the scope of TARG, so it does not
1261                    span the call to save_clearsv, resulting in smaller
1262                    machine code. */
1263                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
1264             }
1265         }
1266         return op->op_next;
1267     }
1268 }
1269
1270 PP(pp_readline)
1271 {
1272     dSP;
1273     /* pp_coreargs pushes a NULL to indicate no args passed to
1274      * CORE::readline() */
1275     if (TOPs) {
1276         SvGETMAGIC(TOPs);
1277         tryAMAGICunTARGETlist(iter_amg, 0);
1278         PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1279     }
1280     else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
1281     if (!isGV_with_GP(PL_last_in_gv)) {
1282         if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
1283             PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
1284         else {
1285             dSP;
1286             XPUSHs(MUTABLE_SV(PL_last_in_gv));
1287             PUTBACK;
1288             Perl_pp_rv2gv(aTHX);
1289             PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1290             assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
1291         }
1292     }
1293     return do_readline();
1294 }
1295
1296 PP(pp_eq)
1297 {
1298     dSP;
1299     SV *left, *right;
1300
1301     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
1302     right = POPs;
1303     left  = TOPs;
1304     SETs(boolSV(
1305         (SvIOK_notUV(left) && SvIOK_notUV(right))
1306         ? (SvIVX(left) == SvIVX(right))
1307         : ( do_ncmp(left, right) == 0)
1308     ));
1309     RETURN;
1310 }
1311
1312
1313 /* also used for: pp_i_preinc() */
1314
1315 PP(pp_preinc)
1316 {
1317     SV *sv = *PL_stack_sp;
1318
1319     if (LIKELY(((sv->sv_flags &
1320                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1321                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1322                 == SVf_IOK))
1323         && SvIVX(sv) != IV_MAX)
1324     {
1325         SvIV_set(sv, SvIVX(sv) + 1);
1326     }
1327     else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1328         sv_inc(sv);
1329     SvSETMAGIC(sv);
1330     return NORMAL;
1331 }
1332
1333
1334 /* also used for: pp_i_predec() */
1335
1336 PP(pp_predec)
1337 {
1338     SV *sv = *PL_stack_sp;
1339
1340     if (LIKELY(((sv->sv_flags &
1341                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1342                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1343                 == SVf_IOK))
1344         && SvIVX(sv) != IV_MIN)
1345     {
1346         SvIV_set(sv, SvIVX(sv) - 1);
1347     }
1348     else /* Do all the PERL_PRESERVE_IVUV and hard cases  in sv_dec */
1349         sv_dec(sv);
1350     SvSETMAGIC(sv);
1351     return NORMAL;
1352 }
1353
1354
1355 /* also used for: pp_orassign() */
1356
1357 PP(pp_or)
1358 {
1359     dSP;
1360     SV *sv;
1361     PERL_ASYNC_CHECK();
1362     sv = TOPs;
1363     if (SvTRUE_NN(sv))
1364         RETURN;
1365     else {
1366         if (PL_op->op_type == OP_OR)
1367             --SP;
1368         RETURNOP(cLOGOP->op_other);
1369     }
1370 }
1371
1372
1373 /* also used for: pp_dor() pp_dorassign() */
1374
1375 PP(pp_defined)
1376 {
1377     dSP;
1378     SV* sv;
1379     bool defined;
1380     const int op_type = PL_op->op_type;
1381     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
1382
1383     if (is_dor) {
1384         PERL_ASYNC_CHECK();
1385         sv = TOPs;
1386         if (UNLIKELY(!sv || !SvANY(sv))) {
1387             if (op_type == OP_DOR)
1388                 --SP;
1389             RETURNOP(cLOGOP->op_other);
1390         }
1391     }
1392     else {
1393         /* OP_DEFINED */
1394         sv = POPs;
1395         if (UNLIKELY(!sv || !SvANY(sv)))
1396             RETPUSHNO;
1397     }
1398
1399     defined = FALSE;
1400     switch (SvTYPE(sv)) {
1401     case SVt_PVAV:
1402         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1403             defined = TRUE;
1404         break;
1405     case SVt_PVHV:
1406         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1407             defined = TRUE;
1408         break;
1409     case SVt_PVCV:
1410         if (CvROOT(sv) || CvXSUB(sv))
1411             defined = TRUE;
1412         break;
1413     default:
1414         SvGETMAGIC(sv);
1415         if (SvOK(sv))
1416             defined = TRUE;
1417         break;
1418     }
1419
1420     if (is_dor) {
1421         if(defined) 
1422             RETURN; 
1423         if(op_type == OP_DOR)
1424             --SP;
1425         RETURNOP(cLOGOP->op_other);
1426     }
1427     /* assuming OP_DEFINED */
1428     if(defined) 
1429         RETPUSHYES;
1430     RETPUSHNO;
1431 }
1432
1433
1434
1435 PP(pp_add)
1436 {
1437     dSP; dATARGET; bool useleft; SV *svl, *svr;
1438
1439     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1440     svr = TOPs;
1441     svl = TOPm1s;
1442
1443 #ifdef PERL_PRESERVE_IVUV
1444
1445     /* special-case some simple common cases */
1446     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1447         IV il, ir;
1448         U32 flags = (svl->sv_flags & svr->sv_flags);
1449         if (flags & SVf_IOK) {
1450             /* both args are simple IVs */
1451             UV topl, topr;
1452             il = SvIVX(svl);
1453             ir = SvIVX(svr);
1454           do_iv:
1455             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1456             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1457
1458             /* if both are in a range that can't under/overflow, do a
1459              * simple integer add: if the top of both numbers
1460              * are 00  or 11, then it's safe */
1461             if (!( ((topl+1) | (topr+1)) & 2)) {
1462                 SP--;
1463                 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1464                 SETs(TARG);
1465                 RETURN;
1466             }
1467             goto generic;
1468         }
1469         else if (flags & SVf_NOK) {
1470             /* both args are NVs */
1471             NV nl = SvNVX(svl);
1472             NV nr = SvNVX(svr);
1473
1474             if (
1475 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1476                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1477                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1478 #else
1479                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1480 #endif
1481                 )
1482                 /* nothing was lost by converting to IVs */
1483                 goto do_iv;
1484             SP--;
1485             TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1486             SETs(TARG);
1487             RETURN;
1488         }
1489     }
1490
1491   generic:
1492
1493     useleft = USE_LEFT(svl);
1494     /* We must see if we can perform the addition with integers if possible,
1495        as the integer code detects overflow while the NV code doesn't.
1496        If either argument hasn't had a numeric conversion yet attempt to get
1497        the IV. It's important to do this now, rather than just assuming that
1498        it's not IOK as a PV of "9223372036854775806" may not take well to NV
1499        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1500        integer in case the second argument is IV=9223372036854775806
1501        We can (now) rely on sv_2iv to do the right thing, only setting the
1502        public IOK flag if the value in the NV (or PV) slot is truly integer.
1503
1504        A side effect is that this also aggressively prefers integer maths over
1505        fp maths for integer values.
1506
1507        How to detect overflow?
1508
1509        C 99 section 6.2.6.1 says
1510
1511        The range of nonnegative values of a signed integer type is a subrange
1512        of the corresponding unsigned integer type, and the representation of
1513        the same value in each type is the same. A computation involving
1514        unsigned operands can never overflow, because a result that cannot be
1515        represented by the resulting unsigned integer type is reduced modulo
1516        the number that is one greater than the largest value that can be
1517        represented by the resulting type.
1518
1519        (the 9th paragraph)
1520
1521        which I read as "unsigned ints wrap."
1522
1523        signed integer overflow seems to be classed as "exception condition"
1524
1525        If an exceptional condition occurs during the evaluation of an
1526        expression (that is, if the result is not mathematically defined or not
1527        in the range of representable values for its type), the behavior is
1528        undefined.
1529
1530        (6.5, the 5th paragraph)
1531
1532        I had assumed that on 2s complement machines signed arithmetic would
1533        wrap, hence coded pp_add and pp_subtract on the assumption that
1534        everything perl builds on would be happy.  After much wailing and
1535        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1536        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
1537        unsigned code below is actually shorter than the old code. :-)
1538     */
1539
1540     if (SvIV_please_nomg(svr)) {
1541         /* Unless the left argument is integer in range we are going to have to
1542            use NV maths. Hence only attempt to coerce the right argument if
1543            we know the left is integer.  */
1544         UV auv = 0;
1545         bool auvok = FALSE;
1546         bool a_valid = 0;
1547
1548         if (!useleft) {
1549             auv = 0;
1550             a_valid = auvok = 1;
1551             /* left operand is undef, treat as zero. + 0 is identity,
1552                Could SETi or SETu right now, but space optimise by not adding
1553                lots of code to speed up what is probably a rarish case.  */
1554         } else {
1555             /* Left operand is defined, so is it IV? */
1556             if (SvIV_please_nomg(svl)) {
1557                 if ((auvok = SvUOK(svl)))
1558                     auv = SvUVX(svl);
1559                 else {
1560                     const IV aiv = SvIVX(svl);
1561                     if (aiv >= 0) {
1562                         auv = aiv;
1563                         auvok = 1;      /* Now acting as a sign flag.  */
1564                     } else {
1565                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1566                     }
1567                 }
1568                 a_valid = 1;
1569             }
1570         }
1571         if (a_valid) {
1572             bool result_good = 0;
1573             UV result;
1574             UV buv;
1575             bool buvok = SvUOK(svr);
1576         
1577             if (buvok)
1578                 buv = SvUVX(svr);
1579             else {
1580                 const IV biv = SvIVX(svr);
1581                 if (biv >= 0) {
1582                     buv = biv;
1583                     buvok = 1;
1584                 } else
1585                     buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1586             }
1587             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1588                else "IV" now, independent of how it came in.
1589                if a, b represents positive, A, B negative, a maps to -A etc
1590                a + b =>  (a + b)
1591                A + b => -(a - b)
1592                a + B =>  (a - b)
1593                A + B => -(a + b)
1594                all UV maths. negate result if A negative.
1595                add if signs same, subtract if signs differ. */
1596
1597             if (auvok ^ buvok) {
1598                 /* Signs differ.  */
1599                 if (auv >= buv) {
1600                     result = auv - buv;
1601                     /* Must get smaller */
1602                     if (result <= auv)
1603                         result_good = 1;
1604                 } else {
1605                     result = buv - auv;
1606                     if (result <= buv) {
1607                         /* result really should be -(auv-buv). as its negation
1608                            of true value, need to swap our result flag  */
1609                         auvok = !auvok;
1610                         result_good = 1;
1611                     }
1612                 }
1613             } else {
1614                 /* Signs same */
1615                 result = auv + buv;
1616                 if (result >= auv)
1617                     result_good = 1;
1618             }
1619             if (result_good) {
1620                 SP--;
1621                 if (auvok)
1622                     SETu( result );
1623                 else {
1624                     /* Negate result */
1625                     if (result <= (UV)IV_MIN)
1626                         SETi(result == (UV)IV_MIN
1627                                 ? IV_MIN : -(IV)result);
1628                     else {
1629                         /* result valid, but out of range for IV.  */
1630                         SETn( -(NV)result );
1631                     }
1632                 }
1633                 RETURN;
1634             } /* Overflow, drop through to NVs.  */
1635         }
1636     }
1637
1638 #else
1639     useleft = USE_LEFT(svl);
1640 #endif
1641
1642     {
1643         NV value = SvNV_nomg(svr);
1644         (void)POPs;
1645         if (!useleft) {
1646             /* left operand is undef, treat as zero. + 0.0 is identity. */
1647             SETn(value);
1648             RETURN;
1649         }
1650         SETn( value + SvNV_nomg(svl) );
1651         RETURN;
1652     }
1653 }
1654
1655
1656 /* also used for: pp_aelemfast_lex() */
1657
1658 PP(pp_aelemfast)
1659 {
1660     dSP;
1661     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
1662         ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
1663     const U32 lval = PL_op->op_flags & OPf_MOD;
1664     const I8 key   = (I8)PL_op->op_private;
1665     SV** svp;
1666     SV *sv;
1667
1668     assert(SvTYPE(av) == SVt_PVAV);
1669
1670     EXTEND(SP, 1);
1671
1672     /* inlined av_fetch() for simple cases ... */
1673     if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1674         sv = AvARRAY(av)[key];
1675         if (sv) {
1676             PUSHs(sv);
1677             RETURN;
1678         }
1679     }
1680
1681     /* ... else do it the hard way */
1682     svp = av_fetch(av, key, lval);
1683     sv = (svp ? *svp : &PL_sv_undef);
1684
1685     if (UNLIKELY(!svp && lval))
1686         DIE(aTHX_ PL_no_aelem, (int)key);
1687
1688     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
1689         mg_get(sv);
1690     PUSHs(sv);
1691     RETURN;
1692 }
1693
1694 PP(pp_join)
1695 {
1696     dSP; dMARK; dTARGET;
1697     MARK++;
1698     do_join(TARG, *MARK, MARK, SP);
1699     SP = MARK;
1700     SETs(TARG);
1701     RETURN;
1702 }
1703
1704 /* Oversized hot code. */
1705
1706 /* also used for: pp_say() */
1707
1708 PP(pp_print)
1709 {
1710     dSP; dMARK; dORIGMARK;
1711     PerlIO *fp;
1712     MAGIC *mg;
1713     GV * const gv
1714         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1715     IO *io = GvIO(gv);
1716
1717     if (io
1718         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1719     {
1720       had_magic:
1721         if (MARK == ORIGMARK) {
1722             /* If using default handle then we need to make space to
1723              * pass object as 1st arg, so move other args up ...
1724              */
1725             MEXTEND(SP, 1);
1726             ++MARK;
1727             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1728             ++SP;
1729         }
1730         return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
1731                                 mg,
1732                                 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1733                                  | (PL_op->op_type == OP_SAY
1734                                     ? TIED_METHOD_SAY : 0)), sp - mark);
1735     }
1736     if (!io) {
1737         if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
1738             && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1739             goto had_magic;
1740         report_evil_fh(gv);
1741         SETERRNO(EBADF,RMS_IFI);
1742         goto just_say_no;
1743     }
1744     else if (!(fp = IoOFP(io))) {
1745         if (IoIFP(io))
1746             report_wrongway_fh(gv, '<');
1747         else
1748             report_evil_fh(gv);
1749         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1750         goto just_say_no;
1751     }
1752     else {
1753         SV * const ofs = GvSV(PL_ofsgv); /* $, */
1754         MARK++;
1755         if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
1756             while (MARK <= SP) {
1757                 if (!do_print(*MARK, fp))
1758                     break;
1759                 MARK++;
1760                 if (MARK <= SP) {
1761                     /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1762                     if (!do_print(GvSV(PL_ofsgv), fp)) {
1763                         MARK--;
1764                         break;
1765                     }
1766                 }
1767             }
1768         }
1769         else {
1770             while (MARK <= SP) {
1771                 if (!do_print(*MARK, fp))
1772                     break;
1773                 MARK++;
1774             }
1775         }
1776         if (MARK <= SP)
1777             goto just_say_no;
1778         else {
1779             if (PL_op->op_type == OP_SAY) {
1780                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1781                     goto just_say_no;
1782             }
1783             else if (PL_ors_sv && SvOK(PL_ors_sv))
1784                 if (!do_print(PL_ors_sv, fp)) /* $\ */
1785                     goto just_say_no;
1786
1787             if (IoFLAGS(io) & IOf_FLUSH)
1788                 if (PerlIO_flush(fp) == EOF)
1789                     goto just_say_no;
1790         }
1791     }
1792     SP = ORIGMARK;
1793     XPUSHs(&PL_sv_yes);
1794     RETURN;
1795
1796   just_say_no:
1797     SP = ORIGMARK;
1798     XPUSHs(&PL_sv_undef);
1799     RETURN;
1800 }
1801
1802
1803 /* do the common parts of pp_padhv() and pp_rv2hv()
1804  * It assumes the caller has done EXTEND(SP, 1) or equivalent.
1805  * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
1806  * 'has_targ' indicates that the op has a target - this should
1807  * be a compile-time constant so that the code can constant-folded as
1808  * appropriate
1809  * */
1810
1811 PERL_STATIC_INLINE OP*
1812 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
1813 {
1814     bool is_tied;
1815     bool is_bool;
1816     MAGIC *mg;
1817     dSP;
1818     IV  i;
1819     SV *sv;
1820
1821     assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1822
1823     if (gimme == G_ARRAY) {
1824         hv_pushkv(hv, 3);
1825         return NORMAL;
1826     }
1827
1828     if (is_keys)
1829         /* 'keys %h' masquerading as '%h': reset iterator */
1830         (void)hv_iterinit(hv);
1831
1832     if (gimme == G_VOID)
1833         return NORMAL;
1834
1835     is_bool = (     PL_op->op_private & OPpTRUEBOOL
1836               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
1837                   && block_gimme() == G_VOID));
1838     is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
1839
1840     if (UNLIKELY(is_tied)) {
1841         if (is_keys && !is_bool) {
1842             i = 0;
1843             while (hv_iternext(hv))
1844                 i++;
1845             goto push_i;
1846         }
1847         else {
1848             sv = magic_scalarpack(hv, mg);
1849             goto push_sv;
1850         }
1851     }
1852     else {
1853         i = HvUSEDKEYS(hv);
1854         if (is_bool) {
1855             sv = i ? &PL_sv_yes : &PL_sv_zero;
1856           push_sv:
1857             PUSHs(sv);
1858         }
1859         else {
1860           push_i:
1861             if (has_targ) {
1862                 dTARGET;
1863                 PUSHi(i);
1864             }
1865             else
1866 #ifdef PERL_OP_PARENT
1867             if (is_keys) {
1868                 /* parent op should be an unused OP_KEYS whose targ we can
1869                  * use */
1870                 dTARG;
1871                 OP *k;
1872
1873                 assert(!OpHAS_SIBLING(PL_op));
1874                 k = PL_op->op_sibparent;
1875                 assert(k->op_type == OP_KEYS);
1876                 TARG = PAD_SV(k->op_targ);
1877                 PUSHi(i);
1878             }
1879             else
1880 #endif
1881                 mPUSHi(i);
1882         }
1883     }
1884
1885     PUTBACK;
1886     return NORMAL;
1887 }
1888
1889
1890 /* This is also called directly by pp_lvavref.  */
1891 PP(pp_padav)
1892 {
1893     dSP; dTARGET;
1894     U8 gimme;
1895     assert(SvTYPE(TARG) == SVt_PVAV);
1896     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1897         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1898             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1899     EXTEND(SP, 1);
1900
1901     if (PL_op->op_flags & OPf_REF) {
1902         PUSHs(TARG);
1903         RETURN;
1904     }
1905     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1906         const I32 flags = is_lvalue_sub();
1907         if (flags && !(flags & OPpENTERSUB_INARGS)) {
1908             if (GIMME_V == G_SCALAR)
1909                 /* diag_listed_as: Can't return %s to lvalue scalar context */
1910                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
1911             PUSHs(TARG);
1912             RETURN;
1913        }
1914     }
1915
1916     gimme = GIMME_V;
1917     if (gimme == G_ARRAY)
1918         return S_pushav(aTHX_ (AV*)TARG);
1919
1920     if (gimme == G_SCALAR) {
1921         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
1922         if (!maxarg)
1923             PUSHs(&PL_sv_zero);
1924         else if (PL_op->op_private & OPpTRUEBOOL)
1925             PUSHs(&PL_sv_yes);
1926         else
1927             mPUSHi(maxarg);
1928     }
1929     RETURN;
1930 }
1931
1932
1933 PP(pp_padhv)
1934 {
1935     dSP; dTARGET;
1936     U8 gimme;
1937
1938     assert(SvTYPE(TARG) == SVt_PVHV);
1939     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
1940         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
1941             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
1942
1943     EXTEND(SP, 1);
1944
1945     if (PL_op->op_flags & OPf_REF) {
1946         PUSHs(TARG);
1947         RETURN;
1948     }
1949     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
1950         const I32 flags = is_lvalue_sub();
1951         if (flags && !(flags & OPpENTERSUB_INARGS)) {
1952             if (GIMME_V == G_SCALAR)
1953                 /* diag_listed_as: Can't return %s to lvalue scalar context */
1954                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
1955             PUSHs(TARG);
1956             RETURN;
1957         }
1958     }
1959
1960     gimme = GIMME_V;
1961
1962     return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
1963                         cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
1964                         0 /* has_targ*/);
1965 }
1966
1967
1968 /* also used for: pp_rv2hv() */
1969 /* also called directly by pp_lvavref */
1970
1971 PP(pp_rv2av)
1972 {
1973     dSP; dTOPss;
1974     const U8 gimme = GIMME_V;
1975     static const char an_array[] = "an ARRAY";
1976     static const char a_hash[] = "a HASH";
1977     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
1978                           || PL_op->op_type == OP_LVAVREF;
1979     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
1980
1981     SvGETMAGIC(sv);
1982     if (SvROK(sv)) {
1983         if (UNLIKELY(SvAMAGIC(sv))) {
1984             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
1985         }
1986         sv = SvRV(sv);
1987         if (UNLIKELY(SvTYPE(sv) != type))
1988             /* diag_listed_as: Not an ARRAY reference */
1989             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
1990         else if (UNLIKELY(PL_op->op_flags & OPf_MOD
1991                 && PL_op->op_private & OPpLVAL_INTRO))
1992             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
1993     }
1994     else if (UNLIKELY(SvTYPE(sv) != type)) {
1995             GV *gv;
1996         
1997             if (!isGV_with_GP(sv)) {
1998                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
1999                                      type, &sp);
2000                 if (!gv)
2001                     RETURN;
2002             }
2003             else {
2004                 gv = MUTABLE_GV(sv);
2005             }
2006             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
2007             if (PL_op->op_private & OPpLVAL_INTRO)
2008                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
2009     }
2010     if (PL_op->op_flags & OPf_REF) {
2011                 SETs(sv);
2012                 RETURN;
2013     }
2014     else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
2015               const I32 flags = is_lvalue_sub();
2016               if (flags && !(flags & OPpENTERSUB_INARGS)) {
2017                 if (gimme != G_ARRAY)
2018                     goto croak_cant_return;
2019                 SETs(sv);
2020                 RETURN;
2021               }
2022     }
2023
2024     if (is_pp_rv2av) {
2025         AV *const av = MUTABLE_AV(sv);
2026
2027         if (gimme == G_ARRAY) {
2028             SP--;
2029             PUTBACK;
2030             return S_pushav(aTHX_ av);
2031         }
2032
2033         if (gimme == G_SCALAR) {
2034             const SSize_t maxarg = AvFILL(av) + 1;
2035             if (PL_op->op_private & OPpTRUEBOOL)
2036                 SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
2037             else {
2038                 dTARGET;
2039                 SETi(maxarg);
2040             }
2041         }
2042     }
2043     else {
2044         SP--; PUTBACK;
2045         return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
2046                         cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
2047                         1 /* has_targ*/);
2048     }
2049     RETURN;
2050
2051  croak_cant_return:
2052     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
2053                is_pp_rv2av ? "array" : "hash");
2054     RETURN;
2055 }
2056
2057 STATIC void
2058 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
2059 {
2060     PERL_ARGS_ASSERT_DO_ODDBALL;
2061
2062     if (*oddkey) {
2063         if (ckWARN(WARN_MISC)) {
2064             const char *err;
2065             if (oddkey == firstkey &&
2066                 SvROK(*oddkey) &&
2067                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
2068                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
2069             {
2070                 err = "Reference found where even-sized list expected";
2071             }
2072             else
2073                 err = "Odd number of elements in hash assignment";
2074             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
2075         }
2076
2077     }
2078 }
2079
2080
2081 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
2082  * are common to both the LHS and RHS of an aassign, and replace them
2083  * with copies. All these copies are made before the actual list assign is
2084  * done.
2085  *
2086  * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
2087  * element ($b) to the first LH element ($a), modifies $a; when the
2088  * second assignment is done, the second RH element now has the wrong
2089  * value. So we initially replace the RHS with ($b, mortalcopy($a)).
2090  * Note that we don't need to make a mortal copy of $b.
2091  *
2092  * The algorithm below works by, for every RHS element, mark the
2093  * corresponding LHS target element with SVf_BREAK. Then if the RHS
2094  * element is found with SVf_BREAK set, it means it would have been
2095  * modified, so make a copy.
2096  * Note that by scanning both LHS and RHS in lockstep, we avoid
2097  * unnecessary copies (like $b above) compared with a naive
2098  * "mark all LHS; copy all marked RHS; unmark all LHS".
2099  *
2100  * If the LHS element is a 'my' declaration' and has a refcount of 1, then
2101  * it can't be common and can be skipped.
2102  *
2103  * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
2104  * that we thought we didn't need to call S_aassign_copy_common(), but we
2105  * have anyway for sanity checking. If we find we need to copy, then panic.
2106  */
2107
2108 PERL_STATIC_INLINE void
2109 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
2110         SV **firstrelem, SV **lastrelem
2111 #ifdef DEBUGGING
2112         , bool fake
2113 #endif
2114 )
2115 {
2116     dVAR;
2117     SV **relem;
2118     SV **lelem;
2119     SSize_t lcount = lastlelem - firstlelem + 1;
2120     bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
2121     bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
2122     bool copy_all = FALSE;
2123
2124     assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
2125     assert(firstlelem < lastlelem); /* at least 2 LH elements */
2126     assert(firstrelem < lastrelem); /* at least 2 RH elements */
2127
2128
2129     lelem = firstlelem;
2130     /* we never have to copy the first RH element; it can't be corrupted
2131      * by assigning something to the corresponding first LH element.
2132      * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
2133      */
2134     relem = firstrelem + 1;
2135
2136     for (; relem <= lastrelem; relem++) {
2137         SV *svr;
2138
2139         /* mark next LH element */
2140
2141         if (--lcount >= 0) {
2142             SV *svl = *lelem++;
2143
2144             if (UNLIKELY(!svl)) {/* skip AV alias marker */
2145                 assert (lelem <= lastlelem);
2146                 svl = *lelem++;
2147                 lcount--;
2148             }
2149
2150             assert(svl);
2151             if (SvSMAGICAL(svl)) {
2152                 copy_all = TRUE;
2153             }
2154             if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
2155                 if (!marked)
2156                     return;
2157                 /* this LH element will consume all further args;
2158                  * no need to mark any further LH elements (if any).
2159                  * But we still need to scan any remaining RHS elements;
2160                  * set lcount negative to distinguish from  lcount == 0,
2161                  * so the loop condition continues being true
2162                  */
2163                 lcount = -1;
2164                 lelem--; /* no need to unmark this element */
2165             }
2166             else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
2167                 SvFLAGS(svl) |= SVf_BREAK;
2168                 marked = TRUE;
2169             }
2170             else if (!marked) {
2171                 /* don't check RH element if no SVf_BREAK flags set yet */
2172                 if (!lcount)
2173                     break;
2174                 continue;
2175             }
2176         }
2177
2178         /* see if corresponding RH element needs copying */
2179
2180         assert(marked);
2181         svr = *relem;
2182         assert(svr);
2183
2184         if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
2185             U32 brk = (SvFLAGS(svr) & SVf_BREAK);
2186
2187 #ifdef DEBUGGING
2188             if (fake) {
2189                 /* op_dump(PL_op); */
2190                 Perl_croak(aTHX_
2191                     "panic: aassign skipped needed copy of common RH elem %"
2192                         UVuf, (UV)(relem - firstrelem));
2193             }
2194 #endif
2195
2196             TAINT_NOT;  /* Each item is independent */
2197
2198             /* Dear TODO test in t/op/sort.t, I love you.
2199                (It's relying on a panic, not a "semi-panic" from newSVsv()
2200                and then an assertion failure below.)  */
2201             if (UNLIKELY(SvIS_FREED(svr))) {
2202                 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
2203                            (void*)svr);
2204             }
2205             /* avoid break flag while copying; otherwise COW etc
2206              * disabled... */
2207             SvFLAGS(svr) &= ~SVf_BREAK;
2208             /* Not newSVsv(), as it does not allow copy-on-write,
2209                resulting in wasteful copies.
2210                Also, we use SV_NOSTEAL in case the SV is used more than
2211                once, e.g.  (...) = (f())[0,0]
2212                Where the same SV appears twice on the RHS without a ref
2213                count bump.  (Although I suspect that the SV won't be
2214                stealable here anyway - DAPM).
2215                */
2216             *relem = sv_mortalcopy_flags(svr,
2217                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2218             /* ... but restore afterwards in case it's needed again,
2219              * e.g. ($a,$b,$c) = (1,$a,$a)
2220              */
2221             SvFLAGS(svr) |= brk;
2222         }
2223
2224         if (!lcount)
2225             break;
2226     }
2227
2228     if (!marked)
2229         return;
2230
2231     /*unmark LHS */
2232
2233     while (lelem > firstlelem) {
2234         SV * const svl = *(--lelem);
2235         if (svl)
2236             SvFLAGS(svl) &= ~SVf_BREAK;
2237     }
2238 }
2239
2240
2241
2242 PP(pp_aassign)
2243 {
2244     dVAR; dSP;
2245     SV **lastlelem = PL_stack_sp;
2246     SV **lastrelem = PL_stack_base + POPMARK;
2247     SV **firstrelem = PL_stack_base + POPMARK + 1;
2248     SV **firstlelem = lastrelem + 1;
2249
2250     SV **relem;
2251     SV **lelem;
2252     U8 gimme;
2253     /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
2254      * only need to save locally, not on the save stack */
2255     U16 old_delaymagic = PL_delaymagic;
2256 #ifdef DEBUGGING
2257     bool fake = 0;
2258 #endif
2259
2260     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
2261
2262     /* If there's a common identifier on both sides we have to take
2263      * special care that assigning the identifier on the left doesn't
2264      * clobber a value on the right that's used later in the list.
2265      */
2266
2267     /* at least 2 LH and RH elements, or commonality isn't an issue */
2268     if (firstlelem < lastlelem && firstrelem < lastrelem) {
2269         for (relem = firstrelem+1; relem <= lastrelem; relem++) {
2270             if (SvGMAGICAL(*relem))
2271                 goto do_scan;
2272         }
2273         for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2274             if (*lelem && SvSMAGICAL(*lelem))
2275                 goto do_scan;
2276         }
2277         if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
2278             if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
2279                 /* skip the scan if all scalars have a ref count of 1 */
2280                 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2281                     SV *sv = *lelem;
2282                     if (!sv || SvREFCNT(sv) == 1)
2283                         continue;
2284                     if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
2285                         goto do_scan;
2286                     break;
2287                 }
2288             }
2289             else {
2290             do_scan:
2291                 S_aassign_copy_common(aTHX_
2292                                       firstlelem, lastlelem, firstrelem, lastrelem
2293 #ifdef DEBUGGING
2294                     , fake
2295 #endif
2296                 );
2297             }
2298         }
2299     }
2300 #ifdef DEBUGGING
2301     else {
2302         /* on debugging builds, do the scan even if we've concluded we
2303          * don't need to, then panic if we find commonality. Note that the
2304          * scanner assumes at least 2 elements */
2305         if (firstlelem < lastlelem && firstrelem < lastrelem) {
2306             fake = 1;
2307             goto do_scan;
2308         }
2309     }
2310 #endif
2311
2312     gimme = GIMME_V;
2313     relem = firstrelem;
2314     lelem = firstlelem;
2315
2316     if (relem > lastrelem)
2317         goto no_relems;
2318
2319     /* first lelem loop while there are still relems */
2320     while (LIKELY(lelem <= lastlelem)) {
2321         bool alias = FALSE;
2322         SV *lsv = *lelem++;
2323
2324         TAINT_NOT; /* Each item stands on its own, taintwise. */
2325
2326         assert(relem <= lastrelem);
2327         if (UNLIKELY(!lsv)) {
2328             alias = TRUE;
2329             lsv = *lelem++;
2330             ASSUME(SvTYPE(lsv) == SVt_PVAV);
2331         }
2332
2333         switch (SvTYPE(lsv)) {
2334         case SVt_PVAV: {
2335             SV **svp;
2336             SSize_t i;
2337             SSize_t tmps_base;
2338             SSize_t nelems = lastrelem - relem + 1;
2339             AV *ary = MUTABLE_AV(lsv);
2340
2341             /* Assigning to an aggregate is tricky. First there is the
2342              * issue of commonality, e.g. @a = ($a[0]). Since the
2343              * stack isn't refcounted, clearing @a prior to storing
2344              * elements will free $a[0]. Similarly with
2345              *    sub FETCH { $status[$_[1]] } @status = @tied[0,1];
2346              *
2347              * The way to avoid these issues is to make the copy of each
2348              * SV (and we normally store a *copy* in the array) *before*
2349              * clearing the array. But this has a problem in that
2350              * if the code croaks during copying, the not-yet-stored copies
2351              * could leak. One way to avoid this is to make all the copies
2352              * mortal, but that's quite expensive.
2353              *
2354              * The current solution to these issues is to use a chunk
2355              * of the tmps stack as a temporary refcounted-stack. SVs
2356              * will be put on there during processing to avoid leaks,
2357              * but will be removed again before the end of this block,
2358              * so free_tmps() is never normally called. Also, the
2359              * sv_refcnt of the SVs doesn't have to be manipulated, since
2360              * the ownership of 1 reference count is transferred directly
2361              * from the tmps stack to the AV when the SV is stored.
2362              *
2363              * We disarm slots in the temps stack by storing PL_sv_undef
2364              * there: it doesn't matter if that SV's refcount is
2365              * repeatedly decremented during a croak. But usually this is
2366              * only an interim measure. By the end of this code block
2367              * we try where possible to not leave any PL_sv_undef's on the
2368              * tmps stack e.g. by shuffling newer entries down.
2369              *
2370              * There is one case where we don't copy: non-magical
2371              * SvTEMP(sv)'s with a ref count of 1. The only owner of these
2372              * is on the tmps stack, so its safe to directly steal the SV
2373              * rather than copying. This is common in things like function
2374              * returns, map etc, which all return a list of such SVs.
2375              *
2376              * Note however something like @a = (f())[0,0], where there is
2377              * a danger of the same SV being shared:  this avoided because
2378              * when the SV is stored as $a[0], its ref count gets bumped,
2379              * so the RC==1 test fails and the second element is copied
2380              * instead.
2381              *
2382              * We also use one slot in the tmps stack to hold an extra
2383              * ref to the array, to ensure it doesn't get prematurely
2384              * freed. Again, this is removed before the end of this block.
2385              *
2386              * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
2387              * @a = ($a[0]) case, but the current implementation uses the
2388              * same algorithm regardless, so ignores that flag. (It *is*
2389              * used in the hash branch below, however).
2390             */
2391
2392             /* Reserve slots for ary, plus the elems we're about to copy,
2393              * then protect ary and temporarily void the remaining slots
2394              * with &PL_sv_undef */
2395             EXTEND_MORTAL(nelems + 1);
2396             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
2397             tmps_base = PL_tmps_ix + 1;
2398             for (i = 0; i < nelems; i++)
2399                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2400             PL_tmps_ix += nelems;
2401
2402             /* Make a copy of each RHS elem and save on the tmps_stack
2403              * (or pass through where we can optimise away the copy) */
2404
2405             if (UNLIKELY(alias)) {
2406                 U32 lval = (gimme == G_ARRAY)
2407                                 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
2408                 for (svp = relem; svp <= lastrelem; svp++) {
2409                     SV *rsv = *svp;
2410
2411                     SvGETMAGIC(rsv);
2412                     if (!SvROK(rsv))
2413                         DIE(aTHX_ "Assigned value is not a reference");
2414                     if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
2415                    /* diag_listed_as: Assigned value is not %s reference */
2416                         DIE(aTHX_
2417                            "Assigned value is not a SCALAR reference");
2418                     if (lval)
2419                         *svp = rsv = sv_mortalcopy(rsv);
2420                     /* XXX else check for weak refs?  */
2421                     rsv = SvREFCNT_inc_NN(SvRV(rsv));
2422                     assert(tmps_base <= PL_tmps_max);
2423                     PL_tmps_stack[tmps_base++] = rsv;
2424                 }
2425             }
2426             else {
2427                 for (svp = relem; svp <= lastrelem; svp++) {
2428                     SV *rsv = *svp;
2429
2430                     if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2431                         /* can skip the copy */
2432                         SvREFCNT_inc_simple_void_NN(rsv);
2433                         SvTEMP_off(rsv);
2434                     }
2435                     else {
2436                         SV *nsv;
2437                         /* do get before newSV, in case it dies and leaks */
2438                         SvGETMAGIC(rsv);
2439                         nsv = newSV(0);
2440                         /* see comment in S_aassign_copy_common about
2441                          * SV_NOSTEAL */
2442                         sv_setsv_flags(nsv, rsv,
2443                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2444                         rsv = *svp = nsv;
2445                     }
2446
2447                     assert(tmps_base <= PL_tmps_max);
2448                     PL_tmps_stack[tmps_base++] = rsv;
2449                 }
2450             }
2451
2452             if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
2453                 av_clear(ary);
2454
2455             /* store in the array, the SVs that are in the tmps stack */
2456
2457             tmps_base -= nelems;
2458
2459             if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
2460                 /* for arrays we can't cheat with, use the official API */
2461                 av_extend(ary, nelems - 1);
2462                 for (i = 0; i < nelems; i++) {
2463                     SV **svp = &(PL_tmps_stack[tmps_base + i]);
2464                     SV *rsv = *svp;
2465                     /* A tied store won't take ownership of rsv, so keep
2466                      * the 1 refcnt on the tmps stack; otherwise disarm
2467                      * the tmps stack entry */
2468                     if (av_store(ary, i, rsv))
2469                         *svp = &PL_sv_undef;
2470                     /* av_store() may have added set magic to rsv */;
2471                     SvSETMAGIC(rsv);
2472                 }
2473                 /* disarm ary refcount: see comments below about leak */
2474                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2475             }
2476             else {
2477                 /* directly access/set the guts of the AV */
2478                 SSize_t fill = nelems - 1;
2479                 if (fill > AvMAX(ary))
2480                     av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
2481                                     &AvARRAY(ary));
2482                 AvFILLp(ary) = fill;
2483                 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
2484                 /* Quietly remove all the SVs from the tmps stack slots,
2485                  * since ary has now taken ownership of the refcnt.
2486                  * Also remove ary: which will now leak if we die before
2487                  * the SvREFCNT_dec_NN(ary) below */
2488                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2489                     Move(&PL_tmps_stack[tmps_base + nelems],
2490                          &PL_tmps_stack[tmps_base - 1],
2491                          PL_tmps_ix - (tmps_base + nelems) + 1,
2492                          SV*);
2493                 PL_tmps_ix -= (nelems + 1);
2494             }
2495
2496             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2497                 /* its assumed @ISA set magic can't die and leak ary */
2498                 SvSETMAGIC(MUTABLE_SV(ary));
2499             SvREFCNT_dec_NN(ary);
2500
2501             relem = lastrelem + 1;
2502             goto no_relems;
2503         }
2504
2505         case SVt_PVHV: {                                /* normal hash */
2506
2507             SV **svp;
2508             bool dirty_tmps;
2509             SSize_t i;
2510             SSize_t tmps_base;
2511             SSize_t nelems = lastrelem - relem + 1;
2512             HV *hash = MUTABLE_HV(lsv);
2513
2514             if (UNLIKELY(nelems & 1)) {
2515                 do_oddball(lastrelem, relem);
2516                 /* we have firstlelem to reuse, it's not needed any more */
2517                 *++lastrelem = &PL_sv_undef;
2518                 nelems++;
2519             }
2520
2521             /* See the SVt_PVAV branch above for a long description of
2522              * how the following all works. The main difference for hashes
2523              * is that we treat keys and values separately (and have
2524              * separate loops for them): as for arrays, values are always
2525              * copied (except for the SvTEMP optimisation), since they
2526              * need to be stored in the hash; while keys are only
2527              * processed where they might get prematurely freed or
2528              * whatever. */
2529
2530             /* tmps stack slots:
2531              * * reserve a slot for the hash keepalive;
2532              * * reserve slots for the hash values we're about to copy;
2533              * * preallocate for the keys we'll possibly copy or refcount bump
2534              *   later;
2535              * then protect hash and temporarily void the remaining
2536              * value slots with &PL_sv_undef */
2537             EXTEND_MORTAL(nelems + 1);
2538
2539              /* convert to number of key/value pairs */
2540              nelems >>= 1;
2541
2542             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
2543             tmps_base = PL_tmps_ix + 1;
2544             for (i = 0; i < nelems; i++)
2545                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2546             PL_tmps_ix += nelems;
2547
2548             /* Make a copy of each RHS hash value and save on the tmps_stack
2549              * (or pass through where we can optimise away the copy) */
2550
2551             for (svp = relem + 1; svp <= lastrelem; svp += 2) {
2552                 SV *rsv = *svp;
2553
2554                 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
2555                     /* can skip the copy */
2556                     SvREFCNT_inc_simple_void_NN(rsv);
2557                     SvTEMP_off(rsv);
2558                 }
2559                 else {
2560                     SV *nsv;
2561                     /* do get before newSV, in case it dies and leaks */
2562                     SvGETMAGIC(rsv);
2563                     nsv = newSV(0);
2564                     /* see comment in S_aassign_copy_common about
2565                      * SV_NOSTEAL */
2566                     sv_setsv_flags(nsv, rsv,
2567                             (SV_DO_COW_SVSETSV|SV_NOSTEAL));
2568                     rsv = *svp = nsv;
2569                 }
2570
2571                 assert(tmps_base <= PL_tmps_max);
2572                 PL_tmps_stack[tmps_base++] = rsv;
2573             }
2574             tmps_base -= nelems;
2575
2576
2577             /* possibly protect keys */
2578
2579             if (UNLIKELY(gimme == G_ARRAY)) {
2580                 /* handle e.g.
2581                 *     @a = ((%h = ($$r, 1)), $r = "x");
2582                 *     $_++ for %h = (1,2,3,4);
2583                 */
2584                 EXTEND_MORTAL(nelems);
2585                 for (svp = relem; svp <= lastrelem; svp += 2)
2586                     *svp = sv_mortalcopy_flags(*svp,
2587                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2588             }
2589             else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
2590                 /* for possible commonality, e.g.
2591                  *       %h = ($h{a},1)
2592                  * avoid premature freeing RHS keys by mortalising
2593                  * them.
2594                  * For a magic element, make a copy so that its magic is
2595                  * called *before* the hash is emptied (which may affect
2596                  * a tied value for example).
2597                  * In theory we should check for magic keys in all
2598                  * cases, not just under OPpASSIGN_COMMON_AGG, but in
2599                  * practice, !OPpASSIGN_COMMON_AGG implies only
2600                  * constants or padtmps on the RHS.
2601                  */
2602                 EXTEND_MORTAL(nelems);
2603                 for (svp = relem; svp <= lastrelem; svp += 2) {
2604                     SV *rsv = *svp;
2605                     if (UNLIKELY(SvGMAGICAL(rsv))) {
2606                         SSize_t n;
2607                         *svp = sv_mortalcopy_flags(*svp,
2608                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
2609                         /* allow other branch to continue pushing
2610                          * onto tmps stack without checking each time */
2611                         n = (lastrelem - relem) >> 1;
2612                         EXTEND_MORTAL(n);
2613                     }
2614                     else
2615                         PL_tmps_stack[++PL_tmps_ix] =
2616                                     SvREFCNT_inc_simple_NN(rsv);
2617                 }
2618             }
2619
2620             if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
2621                 hv_clear(hash);
2622
2623             /* now assign the keys and values to the hash */
2624
2625             dirty_tmps = FALSE;
2626
2627             if (UNLIKELY(gimme == G_ARRAY)) {
2628                 /* @a = (%h = (...)) etc */
2629                 SV **svp;
2630                 SV **topelem = relem;
2631
2632                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2633                     SV *key = *svp++;
2634                     SV *val = *svp;
2635                     /* remove duplicates from list we return */
2636                     if (!hv_exists_ent(hash, key, 0)) {
2637                         /* copy key back: possibly to an earlier
2638                          * stack location if we encountered dups earlier,
2639                          * The values will be updated later
2640                          */
2641                         *topelem = key;
2642                         topelem += 2;
2643                     }
2644                     /* A tied store won't take ownership of val, so keep
2645                      * the 1 refcnt on the tmps stack; otherwise disarm
2646                      * the tmps stack entry */
2647                     if (hv_store_ent(hash, key, val, 0))
2648                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2649                     else
2650                         dirty_tmps = TRUE;
2651                     /* hv_store_ent() may have added set magic to val */;
2652                     SvSETMAGIC(val);
2653                 }
2654                 if (topelem < svp) {
2655                     /* at this point we have removed the duplicate key/value
2656                      * pairs from the stack, but the remaining values may be
2657                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
2658                      * the (a 2), but the stack now probably contains
2659                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
2660                      * obliterates the earlier key. So refresh all values. */
2661                     lastrelem = topelem - 1;
2662                     while (relem < lastrelem) {
2663                         HE *he;
2664                         he = hv_fetch_ent(hash, *relem++, 0, 0);
2665                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
2666                     }
2667                 }
2668             }
2669             else {
2670                 SV **svp;
2671                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
2672                     SV *key = *svp++;
2673                     SV *val = *svp;
2674                     if (hv_store_ent(hash, key, val, 0))
2675                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
2676                     else
2677                         dirty_tmps = TRUE;
2678                     /* hv_store_ent() may have added set magic to val */;
2679                     SvSETMAGIC(val);
2680                 }
2681             }
2682
2683             if (dirty_tmps) {
2684                 /* there are still some 'live' recounts on the tmps stack
2685                  * - usually caused by storing into a tied hash. So let
2686                  * free_tmps() do the proper but slow job later.
2687                  * Just disarm hash refcount: see comments below about leak
2688                  */
2689                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
2690             }
2691             else {
2692                 /* Quietly remove all the SVs from the tmps stack slots,
2693                  * since hash has now taken ownership of the refcnt.
2694                  * Also remove hash: which will now leak if we die before
2695                  * the SvREFCNT_dec_NN(hash) below */
2696                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
2697                     Move(&PL_tmps_stack[tmps_base + nelems],
2698                          &PL_tmps_stack[tmps_base - 1],
2699                          PL_tmps_ix - (tmps_base + nelems) + 1,
2700                          SV*);
2701                 PL_tmps_ix -= (nelems + 1);
2702             }
2703
2704             SvREFCNT_dec_NN(hash);
2705
2706             relem = lastrelem + 1;
2707             goto no_relems;
2708         }
2709
2710         default:
2711             if (!SvIMMORTAL(lsv)) {
2712                 SV *ref;
2713
2714                 if (UNLIKELY(
2715                   SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
2716                   (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
2717                 ))
2718                     Perl_warner(aTHX_
2719                        packWARN(WARN_MISC),
2720                       "Useless assignment to a temporary"
2721                     );
2722
2723                 /* avoid freeing $$lsv if it might be needed for further
2724                  * elements, e.g. ($ref, $foo) = (1, $$ref) */
2725                 if (   SvROK(lsv)
2726                     && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
2727                     && lelem <= lastlelem
2728                 ) {
2729                     SSize_t ix;
2730                     SvREFCNT_inc_simple_void_NN(ref);
2731                     /* an unrolled sv_2mortal */
2732                     ix = ++PL_tmps_ix;
2733                     if (UNLIKELY(ix >= PL_tmps_max))
2734                         /* speculatively grow enough to cover other
2735                          * possible refs */
2736                          (void)tmps_grow_p(ix + (lastlelem - lelem));
2737                     PL_tmps_stack[ix] = ref;
2738                 }
2739
2740                 sv_setsv(lsv, *relem);
2741                 *relem = lsv;
2742                 SvSETMAGIC(lsv);
2743             }
2744             if (++relem > lastrelem)
2745                 goto no_relems;
2746             break;
2747         } /* switch */
2748     } /* while */
2749
2750
2751   no_relems:
2752
2753     /* simplified lelem loop for when there are no relems left */
2754     while (LIKELY(lelem <= lastlelem)) {
2755         SV *lsv = *lelem++;
2756
2757         TAINT_NOT; /* Each item stands on its own, taintwise. */
2758
2759         if (UNLIKELY(!lsv)) {
2760             lsv = *lelem++;
2761             ASSUME(SvTYPE(lsv) == SVt_PVAV);
2762         }
2763
2764         switch (SvTYPE(lsv)) {
2765         case SVt_PVAV:
2766             if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
2767                 av_clear((AV*)lsv);
2768                 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
2769                     SvSETMAGIC(lsv);
2770             }
2771             break;
2772
2773         case SVt_PVHV:
2774             if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
2775                 hv_clear((HV*)lsv);
2776             break;
2777
2778         default:
2779             if (!SvIMMORTAL(lsv)) {
2780                 sv_set_undef(lsv);
2781                 SvSETMAGIC(lsv);
2782                 *relem++ = lsv;
2783             }
2784             break;
2785         } /* switch */
2786     } /* while */
2787
2788     TAINT_NOT; /* result of list assign isn't tainted */
2789
2790     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
2791         /* Will be used to set PL_tainting below */
2792         Uid_t tmp_uid  = PerlProc_getuid();
2793         Uid_t tmp_euid = PerlProc_geteuid();
2794         Gid_t tmp_gid  = PerlProc_getgid();
2795         Gid_t tmp_egid = PerlProc_getegid();
2796
2797         /* XXX $> et al currently silently ignore failures */
2798         if (PL_delaymagic & DM_UID) {
2799 #ifdef HAS_SETRESUID
2800             PERL_UNUSED_RESULT(
2801                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
2802                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
2803                          (Uid_t)-1));
2804 #elif defined(HAS_SETREUID)
2805             PERL_UNUSED_RESULT(
2806                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
2807                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
2808 #else
2809 #    ifdef HAS_SETRUID
2810             if ((PL_delaymagic & DM_UID) == DM_RUID) {
2811                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
2812                 PL_delaymagic &= ~DM_RUID;
2813             }
2814 #    endif /* HAS_SETRUID */
2815 #    ifdef HAS_SETEUID
2816             if ((PL_delaymagic & DM_UID) == DM_EUID) {
2817                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
2818                 PL_delaymagic &= ~DM_EUID;
2819             }
2820 #    endif /* HAS_SETEUID */
2821             if (PL_delaymagic & DM_UID) {
2822                 if (PL_delaymagic_uid != PL_delaymagic_euid)
2823                     DIE(aTHX_ "No setreuid available");
2824                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
2825             }
2826 #endif /* HAS_SETRESUID */
2827
2828             tmp_uid  = PerlProc_getuid();
2829             tmp_euid = PerlProc_geteuid();
2830         }
2831         /* XXX $> et al currently silently ignore failures */
2832         if (PL_delaymagic & DM_GID) {
2833 #ifdef HAS_SETRESGID
2834             PERL_UNUSED_RESULT(
2835                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
2836                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
2837                           (Gid_t)-1));
2838 #elif defined(HAS_SETREGID)
2839             PERL_UNUSED_RESULT(
2840                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
2841                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
2842 #else
2843 #    ifdef HAS_SETRGID
2844             if ((PL_delaymagic & DM_GID) == DM_RGID) {
2845                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
2846                 PL_delaymagic &= ~DM_RGID;
2847             }
2848 #    endif /* HAS_SETRGID */
2849 #    ifdef HAS_SETEGID
2850             if ((PL_delaymagic & DM_GID) == DM_EGID) {
2851                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
2852                 PL_delaymagic &= ~DM_EGID;
2853             }
2854 #    endif /* HAS_SETEGID */
2855             if (PL_delaymagic & DM_GID) {
2856                 if (PL_delaymagic_gid != PL_delaymagic_egid)
2857                     DIE(aTHX_ "No setregid available");
2858                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
2859             }
2860 #endif /* HAS_SETRESGID */
2861
2862             tmp_gid  = PerlProc_getgid();
2863             tmp_egid = PerlProc_getegid();
2864         }
2865         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
2866 #ifdef NO_TAINT_SUPPORT
2867         PERL_UNUSED_VAR(tmp_uid);
2868         PERL_UNUSED_VAR(tmp_euid);
2869         PERL_UNUSED_VAR(tmp_gid);
2870         PERL_UNUSED_VAR(tmp_egid);
2871 #endif
2872     }
2873     PL_delaymagic = old_delaymagic;
2874
2875     if (gimme == G_VOID)
2876         SP = firstrelem - 1;
2877     else if (gimme == G_SCALAR) {
2878         SP = firstrelem;
2879         EXTEND(SP,1);
2880         if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
2881             SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
2882         else {
2883             dTARGET;
2884             SETi(firstlelem - firstrelem);
2885         }
2886     }
2887     else
2888         SP = relem - 1;
2889
2890     RETURN;
2891 }
2892
2893 PP(pp_qr)
2894 {
2895     dSP;
2896     PMOP * const pm = cPMOP;
2897     REGEXP * rx = PM_GETRE(pm);
2898     regexp *prog = ReANY(rx);
2899     SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
2900     SV * const rv = sv_newmortal();
2901     CV **cvp;
2902     CV *cv;
2903
2904     SvUPGRADE(rv, SVt_IV);
2905     /* For a subroutine describing itself as "This is a hacky workaround" I'm
2906        loathe to use it here, but it seems to be the right fix. Or close.
2907        The key part appears to be that it's essential for pp_qr to return a new
2908        object (SV), which implies that there needs to be an effective way to
2909        generate a new SV from the existing SV that is pre-compiled in the
2910        optree.  */
2911     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
2912     SvROK_on(rv);
2913
2914     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
2915     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
2916         *cvp = cv_clone(cv);
2917         SvREFCNT_dec_NN(cv);
2918     }
2919
2920     if (pkg) {
2921         HV *const stash = gv_stashsv(pkg, GV_ADD);
2922         SvREFCNT_dec_NN(pkg);
2923         (void)sv_bless(rv, stash);
2924     }
2925
2926     if (UNLIKELY(RXp_ISTAINTED(prog))) {
2927         SvTAINTED_on(rv);
2928         SvTAINTED_on(SvRV(rv));
2929     }
2930     XPUSHs(rv);
2931     RETURN;
2932 }
2933
2934 PP(pp_match)
2935 {
2936     dSP; dTARG;
2937     PMOP *pm = cPMOP;
2938     PMOP *dynpm = pm;
2939     const char *s;
2940     const char *strend;
2941     SSize_t curpos = 0; /* initial pos() or current $+[0] */
2942     I32 global;
2943     U8 r_flags = 0;
2944     const char *truebase;                       /* Start of string  */
2945     REGEXP *rx = PM_GETRE(pm);
2946     regexp *prog = ReANY(rx);
2947     bool rxtainted;
2948     const U8 gimme = GIMME_V;
2949     STRLEN len;
2950     const I32 oldsave = PL_savestack_ix;
2951     I32 had_zerolen = 0;
2952     MAGIC *mg = NULL;
2953
2954     if (PL_op->op_flags & OPf_STACKED)
2955         TARG = POPs;
2956     else {
2957         if (ARGTARG)
2958             GETTARGET;
2959         else {
2960             TARG = DEFSV;
2961         }
2962         EXTEND(SP,1);
2963     }
2964
2965     PUTBACK;                            /* EVAL blocks need stack_sp. */
2966     /* Skip get-magic if this is a qr// clone, because regcomp has
2967        already done it. */
2968     truebase = prog->mother_re
2969          ? SvPV_nomg_const(TARG, len)
2970          : SvPV_const(TARG, len);
2971     if (!truebase)
2972         DIE(aTHX_ "panic: pp_match");
2973     strend = truebase + len;
2974     rxtainted = (RXp_ISTAINTED(prog) ||
2975                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
2976     TAINT_NOT;
2977
2978     /* We need to know this in case we fail out early - pos() must be reset */
2979     global = dynpm->op_pmflags & PMf_GLOBAL;
2980
2981     /* PMdf_USED is set after a ?? matches once */
2982     if (
2983 #ifdef USE_ITHREADS
2984         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
2985 #else
2986         pm->op_pmflags & PMf_USED
2987 #endif
2988     ) {
2989         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
2990         goto nope;
2991     }
2992
2993     /* handle the empty pattern */
2994     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
2995         if (PL_curpm == PL_reg_curpm) {
2996             if (PL_curpm_under) {
2997                 if (PL_curpm_under == PL_reg_curpm) {
2998                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2999                 } else {
3000                     pm = PL_curpm_under;
3001                 }
3002             }
3003         } else {
3004             pm = PL_curpm;
3005         }
3006         rx = PM_GETRE(pm);
3007         prog = ReANY(rx);
3008     }
3009
3010     if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
3011         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
3012                                               UVuf " < %" IVdf ")\n",
3013                                               (UV)len, (IV)RXp_MINLEN(prog)));
3014         goto nope;
3015     }
3016
3017     /* get pos() if //g */
3018     if (global) {
3019         mg = mg_find_mglob(TARG);
3020         if (mg && mg->mg_len >= 0) {
3021             curpos = MgBYTEPOS(mg, TARG, truebase, len);
3022             /* last time pos() was set, it was zero-length match */
3023             if (mg->mg_flags & MGf_MINMATCH)
3024                 had_zerolen = 1;
3025         }
3026     }
3027
3028 #ifdef PERL_SAWAMPERSAND
3029     if (       RXp_NPARENS(prog)
3030             || PL_sawampersand
3031             || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3032             || (dynpm->op_pmflags & PMf_KEEPCOPY)
3033     )
3034 #endif
3035     {
3036         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
3037         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
3038          * only on the first iteration. Therefore we need to copy $' as well
3039          * as $&, to make the rest of the string available for captures in
3040          * subsequent iterations */
3041         if (! (global && gimme == G_ARRAY))
3042             r_flags |= REXEC_COPY_SKIP_POST;
3043     };
3044 #ifdef PERL_SAWAMPERSAND
3045     if (dynpm->op_pmflags & PMf_KEEPCOPY)
3046         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
3047         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
3048 #endif
3049
3050     s = truebase;
3051
3052   play_it_again:
3053     if (global)
3054         s = truebase + curpos;
3055
3056     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
3057                      had_zerolen, TARG, NULL, r_flags))
3058         goto nope;
3059
3060     PL_curpm = pm;
3061     if (dynpm->op_pmflags & PMf_ONCE)
3062 #ifdef USE_ITHREADS
3063         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
3064 #else
3065         dynpm->op_pmflags |= PMf_USED;
3066 #endif
3067
3068     if (rxtainted)
3069         RXp_MATCH_TAINTED_on(prog);
3070     TAINT_IF(RXp_MATCH_TAINTED(prog));
3071
3072     /* update pos */
3073
3074     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
3075         if (!mg)
3076             mg = sv_magicext_mglob(TARG);
3077         MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
3078         if (RXp_ZERO_LEN(prog))
3079             mg->mg_flags |= MGf_MINMATCH;
3080         else
3081             mg->mg_flags &= ~MGf_MINMATCH;
3082     }
3083
3084     if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
3085         LEAVE_SCOPE(oldsave);
3086         RETPUSHYES;
3087     }
3088
3089     /* push captures on stack */
3090
3091     {
3092         const I32 nparens = RXp_NPARENS(prog);
3093         I32 i = (global && !nparens) ? 1 : 0;
3094
3095         SPAGAIN;                        /* EVAL blocks could move the stack. */
3096         EXTEND(SP, nparens + i);
3097         EXTEND_MORTAL(nparens + i);
3098         for (i = !i; i <= nparens; i++) {
3099             PUSHs(sv_newmortal());
3100             if (LIKELY((RXp_OFFS(prog)[i].start != -1)
3101                      && RXp_OFFS(prog)[i].end   != -1 ))
3102             {
3103                 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
3104                 const char * const s = RXp_OFFS(prog)[i].start + truebase;
3105                 if (UNLIKELY(  RXp_OFFS(prog)[i].end   < 0
3106                             || RXp_OFFS(prog)[i].start < 0
3107                             || len < 0
3108                             || len > strend - s)
3109                 )
3110                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
3111                         "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
3112                         (long) i, (long) RXp_OFFS(prog)[i].start,
3113                         (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
3114                 sv_setpvn(*SP, s, len);
3115                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
3116                     SvUTF8_on(*SP);
3117             }
3118         }
3119         if (global) {
3120             curpos = (UV)RXp_OFFS(prog)[0].end;
3121             had_zerolen = RXp_ZERO_LEN(prog);
3122             PUTBACK;                    /* EVAL blocks may use stack */
3123             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
3124             goto play_it_again;
3125         }
3126         LEAVE_SCOPE(oldsave);
3127         RETURN;
3128     }
3129     NOT_REACHED; /* NOTREACHED */
3130
3131   nope:
3132     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
3133         if (!mg)
3134             mg = mg_find_mglob(TARG);
3135         if (mg)
3136             mg->mg_len = -1;
3137     }
3138     LEAVE_SCOPE(oldsave);
3139     if (gimme == G_ARRAY)
3140         RETURN;
3141     RETPUSHNO;
3142 }
3143
3144 OP *
3145 Perl_do_readline(pTHX)
3146 {
3147     dSP; dTARGETSTACKED;
3148     SV *sv;
3149     STRLEN tmplen = 0;
3150     STRLEN offset;
3151     PerlIO *fp;
3152     IO * const io = GvIO(PL_last_in_gv);
3153     const I32 type = PL_op->op_type;
3154     const U8 gimme = GIMME_V;
3155
3156     if (io) {
3157         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
3158         if (mg) {
3159             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
3160             if (gimme == G_SCALAR) {
3161                 SPAGAIN;
3162                 SvSetSV_nosteal(TARG, TOPs);
3163                 SETTARG;
3164             }
3165             return NORMAL;
3166         }
3167     }
3168     fp = NULL;
3169     if (io) {
3170         fp = IoIFP(io);
3171         if (!fp) {
3172             if (IoFLAGS(io) & IOf_ARGV) {
3173                 if (IoFLAGS(io) & IOf_START) {
3174                     IoLINES(io) = 0;
3175                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
3176                         IoFLAGS(io) &= ~IOf_START;
3177                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
3178                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
3179                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
3180                         SvSETMAGIC(GvSV(PL_last_in_gv));
3181                         fp = IoIFP(io);
3182                         goto have_fp;
3183                     }
3184                 }
3185                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3186                 if (!fp) { /* Note: fp != IoIFP(io) */
3187                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
3188                 }
3189             }
3190             else if (type == OP_GLOB)
3191                 fp = Perl_start_glob(aTHX_ POPs, io);
3192         }
3193         else if (type == OP_GLOB)
3194             SP--;
3195         else if (IoTYPE(io) == IoTYPE_WRONLY) {
3196             report_wrongway_fh(PL_last_in_gv, '>');
3197         }
3198     }
3199     if (!fp) {
3200         if ((!io || !(IoFLAGS(io) & IOf_START))
3201             && ckWARN(WARN_CLOSED)
3202             && type != OP_GLOB)
3203         {
3204             report_evil_fh(PL_last_in_gv);
3205         }
3206         if (gimme == G_SCALAR) {
3207             /* undef TARG, and push that undefined value */
3208             if (type != OP_RCATLINE) {
3209                 sv_set_undef(TARG);
3210             }
3211             PUSHTARG;
3212         }
3213         RETURN;
3214     }
3215   have_fp:
3216     if (gimme == G_SCALAR) {
3217         sv = TARG;
3218         if (type == OP_RCATLINE && SvGMAGICAL(sv))
3219             mg_get(sv);
3220         if (SvROK(sv)) {
3221             if (type == OP_RCATLINE)
3222                 SvPV_force_nomg_nolen(sv);
3223             else
3224                 sv_unref(sv);
3225         }
3226         else if (isGV_with_GP(sv)) {
3227             SvPV_force_nomg_nolen(sv);
3228         }
3229         SvUPGRADE(sv, SVt_PV);
3230         tmplen = SvLEN(sv);     /* remember if already alloced */
3231         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
3232             /* try short-buffering it. Please update t/op/readline.t
3233              * if you change the growth length.
3234              */
3235             Sv_Grow(sv, 80);
3236         }
3237         offset = 0;
3238         if (type == OP_RCATLINE && SvOK(sv)) {
3239             if (!SvPOK(sv)) {
3240                 SvPV_force_nomg_nolen(sv);
3241             }
3242             offset = SvCUR(sv);
3243         }
3244     }
3245     else {
3246         sv = sv_2mortal(newSV(80));
3247         offset = 0;
3248     }
3249
3250     /* This should not be marked tainted if the fp is marked clean */
3251 #define MAYBE_TAINT_LINE(io, sv) \
3252     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
3253         TAINT;                          \
3254         SvTAINTED_on(sv);               \
3255     }
3256
3257 /* delay EOF state for a snarfed empty file */
3258 #define SNARF_EOF(gimme,rs,io,sv) \
3259     (gimme != G_SCALAR || SvCUR(sv)                                     \
3260      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
3261
3262     for (;;) {
3263         PUTBACK;
3264         if (!sv_gets(sv, fp, offset)
3265             && (type == OP_GLOB
3266                 || SNARF_EOF(gimme, PL_rs, io, sv)
3267                 || PerlIO_error(fp)))
3268         {
3269             PerlIO_clearerr(fp);
3270             if (IoFLAGS(io) & IOf_ARGV) {
3271                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
3272                 if (fp)
3273                     continue;
3274                 (void)do_close(PL_last_in_gv, FALSE);
3275             }
3276             else if (type == OP_GLOB) {
3277                 if (!do_close(PL_last_in_gv, FALSE)) {
3278                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
3279                                    "glob failed (child exited with status %d%s)",
3280                                    (int)(STATUS_CURRENT >> 8),
3281                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
3282                 }
3283             }
3284             if (gimme == G_SCALAR) {
3285                 if (type != OP_RCATLINE) {
3286                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
3287                     SvOK_off(TARG);
3288                 }
3289                 SPAGAIN;
3290                 PUSHTARG;
3291             }
3292             MAYBE_TAINT_LINE(io, sv);
3293             RETURN;
3294         }
3295         MAYBE_TAINT_LINE(io, sv);
3296         IoLINES(io)++;
3297         IoFLAGS(io) |= IOf_NOLINE;
3298         SvSETMAGIC(sv);
3299         SPAGAIN;
3300         XPUSHs(sv);
3301         if (type == OP_GLOB) {
3302             const char *t1;
3303             Stat_t statbuf;
3304
3305             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
3306                 char * const tmps = SvEND(sv) - 1;
3307                 if (*tmps == *SvPVX_const(PL_rs)) {
3308                     *tmps = '\0';
3309                     SvCUR_set(sv, SvCUR(sv) - 1);
3310                 }
3311             }
3312             for (t1 = SvPVX_const(sv); *t1; t1++)
3313 #ifdef __VMS
3314                 if (strchr("*%?", *t1))
3315 #else
3316                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
3317 #endif
3318                         break;
3319             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
3320                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
3321                 continue;
3322             }
3323         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
3324              if (ckWARN(WARN_UTF8)) {
3325                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
3326                 const STRLEN len = SvCUR(sv) - offset;
3327                 const U8 *f;
3328
3329                 if (!is_utf8_string_loc(s, len, &f))
3330                     /* Emulate :encoding(utf8) warning in the same case. */
3331                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
3332                                 "utf8 \"\\x%02X\" does not map to Unicode",
3333                                 f < (U8*)SvEND(sv) ? *f : 0);
3334              }
3335         }
3336         if (gimme == G_ARRAY) {
3337             if (SvLEN(sv) - SvCUR(sv) > 20) {
3338                 SvPV_shrink_to_cur(sv);
3339             }
3340             sv = sv_2mortal(newSV(80));
3341             continue;
3342         }
3343         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
3344             /* try to reclaim a bit of scalar space (only on 1st alloc) */
3345             const STRLEN new_len
3346                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
3347             SvPV_renew(sv, new_len);
3348         }
3349         RETURN;
3350     }
3351 }
3352
3353 PP(pp_helem)
3354 {
3355     dSP;
3356     HE* he;
3357     SV **svp;
3358     SV * const keysv = POPs;
3359     HV * const hv = MUTABLE_HV(POPs);
3360     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3361     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3362     SV *sv;
3363     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3364     bool preeminent = TRUE;
3365
3366     if (SvTYPE(hv) != SVt_PVHV)
3367         RETPUSHUNDEF;
3368
3369     if (localizing) {
3370         MAGIC *mg;
3371         HV *stash;
3372
3373         /* If we can determine whether the element exist,
3374          * Try to preserve the existenceness of a tied hash
3375          * element by using EXISTS and DELETE if possible.
3376          * Fallback to FETCH and STORE otherwise. */
3377         if (SvCANEXISTDELETE(hv))
3378             preeminent = hv_exists_ent(hv, keysv, 0);
3379     }
3380
3381     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3382     svp = he ? &HeVAL(he) : NULL;
3383     if (lval) {
3384         if (!svp || !*svp || *svp == &PL_sv_undef) {
3385             SV* lv;
3386             SV* key2;
3387             if (!defer) {
3388                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3389             }
3390             lv = sv_newmortal();
3391             sv_upgrade(lv, SVt_PVLV);
3392             LvTYPE(lv) = 'y';
3393             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
3394             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
3395             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3396             LvTARGLEN(lv) = 1;
3397             PUSHs(lv);
3398             RETURN;
3399         }
3400         if (localizing) {
3401             if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
3402                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
3403             else if (preeminent)
3404                 save_helem_flags(hv, keysv, svp,
3405                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
3406             else
3407                 SAVEHDELETE(hv, keysv);
3408         }
3409         else if (PL_op->op_private & OPpDEREF) {
3410             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3411             RETURN;
3412         }
3413     }
3414     sv = (svp && *svp ? *svp : &PL_sv_undef);
3415     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
3416      * was to make C<local $tied{foo} = $tied{foo}> possible.
3417      * However, it seems no longer to be needed for that purpose, and
3418      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
3419      * would loop endlessly since the pos magic is getting set on the
3420      * mortal copy and lost. However, the copy has the effect of
3421      * triggering the get magic, and losing it altogether made things like
3422      * c<$tied{foo};> in void context no longer do get magic, which some
3423      * code relied on. Also, delayed triggering of magic on @+ and friends
3424      * meant the original regex may be out of scope by now. So as a
3425      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
3426      * being called too many times). */
3427     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
3428         mg_get(sv);
3429     PUSHs(sv);
3430     RETURN;
3431 }
3432
3433
3434 /* a stripped-down version of Perl_softref2xv() for use by
3435  * pp_multideref(), which doesn't use PL_op->op_flags */
3436
3437 STATIC GV *
3438 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
3439                 const svtype type)
3440 {
3441     if (PL_op->op_private & HINT_STRICT_REFS) {
3442         if (SvOK(sv))
3443             Perl_die(aTHX_ PL_no_symref_sv, sv,
3444                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
3445         else
3446             Perl_die(aTHX_ PL_no_usym, what);
3447     }
3448     if (!SvOK(sv))
3449         Perl_die(aTHX_ PL_no_usym, what);
3450     return gv_fetchsv_nomg(sv, GV_ADD, type);
3451 }
3452
3453
3454 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
3455  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
3456  *
3457  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
3458  * Each of these either contains a set of actions, or an argument, such as
3459  * an IV to use as an array index, or a lexical var to retrieve.
3460  * Several actions re stored per UV; we keep shifting new actions off the
3461  * one UV, and only reload when it becomes zero.
3462  */
3463
3464 PP(pp_multideref)
3465 {
3466     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
3467     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
3468     UV actions = items->uv;
3469
3470     assert(actions);
3471     /* this tells find_uninit_var() where we're up to */
3472     PL_multideref_pc = items;
3473
3474     while (1) {
3475         /* there are three main classes of action; the first retrieve
3476          * the initial AV or HV from a variable or the stack; the second
3477          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
3478          * the third an unrolled (/DREFHV, rv2hv, helem).
3479          */
3480         switch (actions & MDEREF_ACTION_MASK) {
3481
3482         case MDEREF_reload:
3483             actions = (++items)->uv;
3484             continue;
3485
3486         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
3487             sv = PAD_SVl((++items)->pad_offset);
3488             goto do_AV_aelem;
3489
3490         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
3491             sv = UNOP_AUX_item_sv(++items);
3492             assert(isGV_with_GP(sv));
3493             sv = (SV*)GvAVn((GV*)sv);
3494             goto do_AV_aelem;
3495
3496         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
3497             {
3498                 dSP;
3499                 sv = POPs;
3500                 PUTBACK;
3501                 goto do_AV_rv2av_aelem;
3502             }
3503
3504         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
3505             sv = UNOP_AUX_item_sv(++items);
3506             assert(isGV_with_GP(sv));
3507             sv = GvSVn((GV*)sv);
3508             goto do_AV_vivify_rv2av_aelem;
3509
3510         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
3511             sv = PAD_SVl((++items)->pad_offset);
3512             /* FALLTHROUGH */
3513
3514         do_AV_vivify_rv2av_aelem:
3515         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
3516             /* this is the OPpDEREF action normally found at the end of
3517              * ops like aelem, helem, rv2sv */
3518             sv = vivify_ref(sv, OPpDEREF_AV);
3519             /* FALLTHROUGH */
3520
3521         do_AV_rv2av_aelem:
3522             /* this is basically a copy of pp_rv2av when it just has the
3523              * sKR/1 flags */
3524             SvGETMAGIC(sv);
3525             if (LIKELY(SvROK(sv))) {
3526                 if (UNLIKELY(SvAMAGIC(sv))) {
3527                     sv = amagic_deref_call(sv, to_av_amg);
3528                 }
3529                 sv = SvRV(sv);
3530                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
3531                     DIE(aTHX_ "Not an ARRAY reference");
3532             }
3533             else if (SvTYPE(sv) != SVt_PVAV) {
3534                 if (!isGV_with_GP(sv))
3535                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
3536                 sv = MUTABLE_SV(GvAVn((GV*)sv));
3537             }
3538             /* FALLTHROUGH */
3539
3540         do_AV_aelem:
3541             {
3542                 /* retrieve the key; this may be either a lexical or package
3543                  * var (whose index/ptr is stored as an item) or a signed
3544                  * integer constant stored as an item.
3545                  */
3546                 SV *elemsv;
3547                 IV elem = 0; /* to shut up stupid compiler warnings */
3548
3549
3550                 assert(SvTYPE(sv) == SVt_PVAV);
3551
3552                 switch (actions & MDEREF_INDEX_MASK) {
3553                 case MDEREF_INDEX_none:
3554                     goto finish;
3555                 case MDEREF_INDEX_const:
3556                     elem  = (++items)->iv;
3557                     break;
3558                 case MDEREF_INDEX_padsv:
3559                     elemsv = PAD_SVl((++items)->pad_offset);
3560                     goto check_elem;
3561                 case MDEREF_INDEX_gvsv:
3562                     elemsv = UNOP_AUX_item_sv(++items);
3563                     assert(isGV_with_GP(elemsv));
3564                     elemsv = GvSVn((GV*)elemsv);
3565                 check_elem:
3566                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
3567                                             && ckWARN(WARN_MISC)))
3568                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3569                                 "Use of reference \"%" SVf "\" as array index",
3570                                 SVfARG(elemsv));
3571                     /* the only time that S_find_uninit_var() needs this
3572                      * is to determine which index value triggered the
3573                      * undef warning. So just update it here. Note that
3574                      * since we don't save and restore this var (e.g. for
3575                      * tie or overload execution), its value will be
3576                      * meaningless apart from just here */
3577                     PL_multideref_pc = items;
3578                     elem = SvIV(elemsv);
3579                     break;
3580                 }
3581
3582
3583                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
3584
3585                 if (!(actions & MDEREF_FLAG_last)) {
3586                     SV** svp = av_fetch((AV*)sv, elem, 1);
3587                     if (!svp || ! (sv=*svp))
3588                         DIE(aTHX_ PL_no_aelem, elem);
3589                     break;
3590                 }
3591
3592                 if (PL_op->op_private &
3593                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3594                 {
3595                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3596                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
3597                     }
3598                     else {
3599                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3600                         sv = av_delete((AV*)sv, elem, discard);
3601                         if (discard)
3602                             return NORMAL;
3603                         if (!sv)
3604                             sv = &PL_sv_undef;
3605                     }
3606                 }
3607                 else {
3608                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3609                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3610                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3611                     bool preeminent = TRUE;
3612                     AV *const av = (AV*)sv;
3613                     SV** svp;
3614
3615                     if (UNLIKELY(localizing)) {
3616                         MAGIC *mg;
3617                         HV *stash;
3618
3619                         /* If we can determine whether the element exist,
3620                          * Try to preserve the existenceness of a tied array
3621                          * element by using EXISTS and DELETE if possible.
3622                          * Fallback to FETCH and STORE otherwise. */
3623                         if (SvCANEXISTDELETE(av))
3624                             preeminent = av_exists(av, elem);
3625                     }
3626
3627                     svp = av_fetch(av, elem, lval && !defer);
3628
3629                     if (lval) {
3630                         if (!svp || !(sv = *svp)) {
3631                             IV len;
3632                             if (!defer)
3633                                 DIE(aTHX_ PL_no_aelem, elem);
3634                             len = av_tindex(av);
3635                             sv = sv_2mortal(newSVavdefelem(av,
3636                             /* Resolve a negative index now, unless it points
3637                              * before the beginning of the array, in which
3638                              * case record it for error reporting in
3639                              * magic_setdefelem. */
3640                                 elem < 0 && len + elem >= 0
3641                                     ? len + elem : elem, 1));
3642                         }
3643                         else {
3644                             if (UNLIKELY(localizing)) {
3645                                 if (preeminent) {
3646                                     save_aelem(av, elem, svp);
3647                                     sv = *svp; /* may have changed */
3648                                 }
3649                                 else
3650                                     SAVEADELETE(av, elem);
3651                             }
3652                         }
3653                     }
3654                     else {
3655                         sv = (svp ? *svp : &PL_sv_undef);
3656                         /* see note in pp_helem() */
3657                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3658                             mg_get(sv);
3659                     }
3660                 }
3661
3662             }
3663           finish:
3664             {
3665                 dSP;
3666                 XPUSHs(sv);
3667                 RETURN;
3668             }
3669             /* NOTREACHED */
3670
3671
3672
3673
3674         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
3675             sv = PAD_SVl((++items)->pad_offset);
3676             goto do_HV_helem;
3677
3678         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
3679             sv = UNOP_AUX_item_sv(++items);
3680             assert(isGV_with_GP(sv));
3681             sv = (SV*)GvHVn((GV*)sv);
3682             goto do_HV_helem;
3683
3684         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
3685             {
3686                 dSP;
3687                 sv = POPs;
3688                 PUTBACK;
3689                 goto do_HV_rv2hv_helem;
3690             }
3691
3692         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
3693             sv = UNOP_AUX_item_sv(++items);
3694             assert(isGV_with_GP(sv));
3695             sv = GvSVn((GV*)sv);
3696             goto do_HV_vivify_rv2hv_helem;
3697
3698         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
3699             sv = PAD_SVl((++items)->pad_offset);
3700             /* FALLTHROUGH */
3701
3702         do_HV_vivify_rv2hv_helem:
3703         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
3704             /* this is the OPpDEREF action normally found at the end of
3705              * ops like aelem, helem, rv2sv */
3706             sv = vivify_ref(sv, OPpDEREF_HV);
3707             /* FALLTHROUGH */
3708
3709         do_HV_rv2hv_helem:
3710             /* this is basically a copy of pp_rv2hv when it just has the
3711              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3712
3713             SvGETMAGIC(sv);
3714             if (LIKELY(SvROK(sv))) {
3715                 if (UNLIKELY(SvAMAGIC(sv))) {
3716                     sv = amagic_deref_call(sv, to_hv_amg);
3717                 }
3718                 sv = SvRV(sv);
3719                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3720                     DIE(aTHX_ "Not a HASH reference");
3721             }
3722             else if (SvTYPE(sv) != SVt_PVHV) {
3723                 if (!isGV_with_GP(sv))
3724                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3725                 sv = MUTABLE_SV(GvHVn((GV*)sv));
3726             }
3727             /* FALLTHROUGH */
3728
3729         do_HV_helem:
3730             {
3731                 /* retrieve the key; this may be either a lexical / package
3732                  * var or a string constant, whose index/ptr is stored as an
3733                  * item
3734                  */
3735                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3736
3737                 assert(SvTYPE(sv) == SVt_PVHV);
3738
3739                 switch (actions & MDEREF_INDEX_MASK) {
3740                 case MDEREF_INDEX_none:
3741                     goto finish;
3742
3743                 case MDEREF_INDEX_const:
3744                     keysv = UNOP_AUX_item_sv(++items);
3745                     break;
3746
3747                 case MDEREF_INDEX_padsv:
3748                     keysv = PAD_SVl((++items)->pad_offset);
3749                     break;
3750
3751                 case MDEREF_INDEX_gvsv:
3752                     keysv = UNOP_AUX_item_sv(++items);
3753                     keysv = GvSVn((GV*)keysv);
3754                     break;
3755                 }
3756
3757                 /* see comment above about setting this var */
3758                 PL_multideref_pc = items;
3759
3760
3761                 /* ensure that candidate CONSTs have been HEKified */
3762                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3763                        || SvTYPE(keysv) >= SVt_PVMG
3764                        || !SvOK(keysv)
3765                        || SvROK(keysv)
3766                        || SvIsCOW_shared_hash(keysv));
3767
3768                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3769
3770                 if (!(actions & MDEREF_FLAG_last)) {
3771                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3772                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3773                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3774                     break;
3775                 }
3776
3777                 if (PL_op->op_private &
3778                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3779                 {
3780                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3781                         sv = hv_exists_ent((HV*)sv, keysv, 0)
3782                                                 ? &PL_sv_yes : &PL_sv_no;
3783                     }
3784                     else {
3785                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3786                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3787                         if (discard)
3788                             return NORMAL;
3789                         if (!sv)
3790                             sv = &PL_sv_undef;
3791                     }
3792                 }
3793                 else {
3794                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3795                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3796                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3797                     bool preeminent = TRUE;
3798                     SV **svp;
3799                     HV * const hv = (HV*)sv;
3800                     HE* he;
3801
3802                     if (UNLIKELY(localizing)) {
3803                         MAGIC *mg;
3804                         HV *stash;
3805
3806                         /* If we can determine whether the element exist,
3807                          * Try to preserve the existenceness of a tied hash
3808                          * element by using EXISTS and DELETE if possible.
3809                          * Fallback to FETCH and STORE otherwise. */
3810                         if (SvCANEXISTDELETE(hv))
3811                             preeminent = hv_exists_ent(hv, keysv, 0);
3812                     }
3813
3814                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3815                     svp = he ? &HeVAL(he) : NULL;
3816
3817
3818                     if (lval) {
3819                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
3820                             SV* lv;
3821                             SV* key2;
3822                             if (!defer)
3823                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3824                             lv = sv_newmortal();
3825                             sv_upgrade(lv, SVt_PVLV);
3826                             LvTYPE(lv) = 'y';
3827                             sv_magic(lv, key2 = newSVsv(keysv),
3828                                                 PERL_MAGIC_defelem, NULL, 0);
3829                             /* sv_magic() increments refcount */
3830                             SvREFCNT_dec_NN(key2);
3831                             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3832                             LvTARGLEN(lv) = 1;
3833                             sv = lv;
3834                         }
3835                         else {
3836                             if (localizing) {
3837                                 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
3838                                     save_gp(MUTABLE_GV(sv),
3839                                         !(PL_op->op_flags & OPf_SPECIAL));
3840                                 else if (preeminent) {
3841                                     save_helem_flags(hv, keysv, svp,
3842                                          (PL_op->op_flags & OPf_SPECIAL)
3843                                             ? 0 : SAVEf_SETMAGIC);
3844                                     sv = *svp; /* may have changed */
3845                                 }
3846                                 else
3847                                     SAVEHDELETE(hv, keysv);
3848                             }
3849                         }
3850                     }
3851                     else {
3852                         sv = (svp && *svp ? *svp : &PL_sv_undef);
3853                         /* see note in pp_helem() */
3854                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
3855                             mg_get(sv);
3856                     }
3857                 }
3858                 goto finish;
3859             }
3860
3861         } /* switch */
3862
3863         actions >>= MDEREF_SHIFT;
3864     } /* while */
3865     /* NOTREACHED */
3866 }
3867
3868
3869 PP(pp_iter)
3870 {
3871     PERL_CONTEXT *cx;
3872     SV *oldsv;
3873     SV **itersvp;
3874
3875     SV *sv;
3876     AV *av;
3877     IV ix;
3878     IV inc;
3879
3880     cx = CX_CUR();
3881     itersvp = CxITERVAR(cx);
3882     assert(itersvp);
3883
3884     switch (CxTYPE(cx)) {
3885
3886     case CXt_LOOP_LAZYSV: /* string increment */
3887     {
3888         SV* cur = cx->blk_loop.state_u.lazysv.cur;
3889         SV *end = cx->blk_loop.state_u.lazysv.end;
3890         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
3891            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
3892         STRLEN maxlen = 0;
3893         const char *max = SvPV_const(end, maxlen);
3894         if (DO_UTF8(end) && IN_UNI_8_BIT)
3895             maxlen = sv_len_utf8_nomg(end);
3896         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
3897             goto retno;
3898
3899         oldsv = *itersvp;
3900         /* NB: on the first iteration, oldsv will have a ref count of at
3901          * least 2 (one extra from blk_loop.itersave), so the GV or pad
3902          * slot will get localised; on subsequent iterations the RC==1
3903          * optimisation may kick in and the SV will be reused. */
3904          if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3905             /* safe to reuse old SV */
3906             sv_setsv(oldsv, cur);
3907         }
3908         else
3909         {
3910             /* we need a fresh SV every time so that loop body sees a
3911              * completely new SV for closures/references to work as
3912              * they used to */
3913             *itersvp = newSVsv(cur);
3914             SvREFCNT_dec(oldsv);
3915         }
3916         if (strEQ(SvPVX_const(cur), max))
3917             sv_setiv(cur, 0); /* terminate next time */
3918         else
3919             sv_inc(cur);
3920         break;
3921     }
3922
3923     case CXt_LOOP_LAZYIV: /* integer increment */
3924     {
3925         IV cur = cx->blk_loop.state_u.lazyiv.cur;
3926         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
3927             goto retno;
3928
3929         oldsv = *itersvp;
3930         /* see NB comment above */
3931         if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3932             /* safe to reuse old SV */
3933
3934             if (    (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
3935                  == SVt_IV)
3936             {
3937                 /* Cheap SvIOK_only().
3938                  * Assert that flags which SvIOK_only() would test or
3939                  * clear can't be set, because we're SVt_IV */
3940                 assert(!(SvFLAGS(oldsv) &
3941                     (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
3942                 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
3943                 /* SvIV_set() where sv_any points to head */
3944                 oldsv->sv_u.svu_iv = cur;
3945
3946             }
3947             else
3948                 sv_setiv(oldsv, cur);
3949         }
3950         else
3951         {
3952             /* we need a fresh SV every time so that loop body sees a
3953              * completely new SV for closures/references to work as they
3954              * used to */
3955             *itersvp = newSViv(cur);
3956             SvREFCNT_dec(oldsv);
3957         }
3958
3959         if (UNLIKELY(cur == IV_MAX)) {
3960             /* Handle end of range at IV_MAX */
3961             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
3962         } else
3963             ++cx->blk_loop.state_u.lazyiv.cur;
3964         break;
3965     }
3966
3967     case CXt_LOOP_LIST: /* for (1,2,3) */
3968
3969         assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
3970         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3971         ix = (cx->blk_loop.state_u.stack.ix += inc);
3972         if (UNLIKELY(inc > 0
3973                         ? ix > cx->blk_oldsp
3974                         : ix <= cx->blk_loop.state_u.stack.basesp)
3975         )
3976             goto retno;
3977
3978         sv = PL_stack_base[ix];
3979         av = NULL;
3980         goto loop_ary_common;
3981
3982     case CXt_LOOP_ARY: /* for (@ary) */
3983
3984         av = cx->blk_loop.state_u.ary.ary;
3985         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3986         ix = (cx->blk_loop.state_u.ary.ix += inc);
3987         if (UNLIKELY(inc > 0
3988                         ? ix > AvFILL(av)
3989                         : ix < 0)
3990         )
3991             goto retno;
3992
3993         if (UNLIKELY(SvRMAGICAL(av))) {
3994             SV * const * const svp = av_fetch(av, ix, FALSE);
3995             sv = svp ? *svp : NULL;
3996         }
3997         else {
3998             sv = AvARRAY(av)[ix];
3999         }
4000
4001       loop_ary_common:
4002
4003         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
4004             SvSetMagicSV(*itersvp, sv);
4005             break;
4006         }
4007
4008         if (LIKELY(sv)) {
4009             if (UNLIKELY(SvIS_FREED(sv))) {
4010                 *itersvp = NULL;
4011                 Perl_croak(aTHX_ "Use of freed value in iteration");
4012             }
4013             if (SvPADTMP(sv)) {
4014                 sv = newSVsv(sv);
4015             }
4016             else {
4017                 SvTEMP_off(sv);
4018                 SvREFCNT_inc_simple_void_NN(sv);
4019             }
4020         }
4021         else if (av) {
4022             sv = newSVavdefelem(av, ix, 0);
4023         }
4024         else
4025             sv = &PL_sv_undef;
4026
4027         oldsv = *itersvp;
4028         *itersvp = sv;
4029         SvREFCNT_dec(oldsv);
4030         break;
4031
4032     default:
4033         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
4034     }
4035
4036     /* Bypass pushing &PL_sv_yes and calling pp_and(); instead
4037      * jump straight to the AND op's op_other */
4038     assert(PL_op->op_next->op_type == OP_AND);
4039     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
4040     return cLOGOPx(PL_op->op_next)->op_other;
4041
4042   retno:
4043     /* Bypass pushing &PL_sv_no and calling pp_and(); instead
4044      * jump straight to the AND op's op_next */
4045     assert(PL_op->op_next->op_type == OP_AND);
4046     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
4047     /* pp_enteriter should have pre-extended the stack */
4048     EXTEND_SKIP(PL_stack_sp, 1);
4049     /* we only need this for the rare case where the OP_AND isn't
4050      * in void context, e.g. $x = do { for (..) {...} };
4051      * but its cheaper to just push it rather than testing first
4052      */
4053     *++PL_stack_sp = &PL_sv_no;
4054     return PL_op->op_next->op_next;
4055 }
4056
4057
4058 /*
4059 A description of how taint works in pattern matching and substitution.
4060
4061 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
4062 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
4063
4064 While the pattern is being assembled/concatenated and then compiled,
4065 PL_tainted will get set (via TAINT_set) if any component of the pattern
4066 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
4067 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
4068 TAINT_get).  It will also be set if any component of the pattern matches
4069 based on locale-dependent behavior.
4070
4071 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
4072 the pattern is marked as tainted. This means that subsequent usage, such
4073 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
4074 on the new pattern too.
4075
4076 RXf_TAINTED_SEEN is used post-execution by the get magic code
4077 of $1 et al to indicate whether the returned value should be tainted.
4078 It is the responsibility of the caller of the pattern (i.e. pp_match,
4079 pp_subst etc) to set this flag for any other circumstances where $1 needs
4080 to be tainted.
4081
4082 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
4083
4084 There are three possible sources of taint
4085     * the source string
4086     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
4087     * the replacement string (or expression under /e)
4088     
4089 There are four destinations of taint and they are affected by the sources
4090 according to the rules below:
4091
4092     * the return value (not including /r):
4093         tainted by the source string and pattern, but only for the
4094         number-of-iterations case; boolean returns aren't tainted;
4095     * the modified string (or modified copy under /r):
4096         tainted by the source string, pattern, and replacement strings;
4097     * $1 et al:
4098         tainted by the pattern, and under 'use re "taint"', by the source
4099         string too;
4100     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
4101         should always be unset before executing subsequent code.
4102
4103 The overall action of pp_subst is:
4104
4105     * at the start, set bits in rxtainted indicating the taint status of
4106         the various sources.
4107
4108     * After each pattern execution, update the SUBST_TAINT_PAT bit in
4109         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
4110         pattern has subsequently become tainted via locale ops.
4111
4112     * If control is being passed to pp_substcont to execute a /e block,
4113         save rxtainted in the CXt_SUBST block, for future use by
4114         pp_substcont.
4115
4116     * Whenever control is being returned to perl code (either by falling
4117         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
4118         use the flag bits in rxtainted to make all the appropriate types of
4119         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
4120         et al will appear tainted.
4121
4122 pp_match is just a simpler version of the above.
4123
4124 */
4125
4126 PP(pp_subst)
4127 {
4128     dSP; dTARG;
4129     PMOP *pm = cPMOP;
4130     PMOP *rpm = pm;
4131     char *s;
4132     char *strend;
4133     const char *c;
4134     STRLEN clen;
4135     SSize_t iters = 0;
4136     SSize_t maxiters;
4137     bool once;
4138     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
4139                         See "how taint works" above */
4140     char *orig;
4141     U8 r_flags;
4142     REGEXP *rx = PM_GETRE(pm);
4143     regexp *prog = ReANY(rx);
4144     STRLEN len;
4145     int force_on_match = 0;
4146     const I32 oldsave = PL_savestack_ix;
4147     STRLEN slen;
4148     bool doutf8 = FALSE; /* whether replacement is in utf8 */
4149 #ifdef PERL_ANY_COW
4150     bool was_cow;
4151 #endif
4152     SV *nsv = NULL;
4153     /* known replacement string? */
4154     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
4155
4156     PERL_ASYNC_CHECK();
4157
4158     if (PL_op->op_flags & OPf_STACKED)
4159         TARG = POPs;
4160     else {
4161         if (ARGTARG)
4162             GETTARGET;
4163         else {
4164             TARG = DEFSV;
4165         }
4166         EXTEND(SP,1);
4167     }
4168
4169     SvGETMAGIC(TARG); /* must come before cow check */
4170 #ifdef PERL_ANY_COW
4171     /* note that a string might get converted to COW during matching */
4172     was_cow = cBOOL(SvIsCOW(TARG));
4173 #endif
4174     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4175 #ifndef PERL_ANY_COW
4176         if (SvIsCOW(TARG))
4177             sv_force_normal_flags(TARG,0);
4178 #endif
4179         if ((SvREADONLY(TARG)
4180                 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
4181                       || SvTYPE(TARG) > SVt_PVLV)
4182                      && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
4183             Perl_croak_no_modify();
4184     }
4185     PUTBACK;
4186
4187     orig = SvPV_nomg(TARG, len);
4188     /* note we don't (yet) force the var into being a string; if we fail
4189      * to match, we leave as-is; on successful match however, we *will*
4190      * coerce into a string, then repeat the match */
4191     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
4192         force_on_match = 1;
4193
4194     /* only replace once? */
4195     once = !(rpm->op_pmflags & PMf_GLOBAL);
4196
4197     /* See "how taint works" above */
4198     if (TAINTING_get) {
4199         rxtainted  = (
4200             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
4201           | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
4202           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
4203           | ((  (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4204              || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0));
4205         TAINT_NOT;
4206     }
4207
4208   force_it:
4209     if (!pm || !orig)
4210         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
4211
4212     strend = orig + len;
4213     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
4214     maxiters = 2 * slen + 10;   /* We can match twice at each
4215                                    position, once with zero-length,
4216                                    second time with non-zero. */
4217
4218     /* handle the empty pattern */
4219     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
4220         if (PL_curpm == PL_reg_curpm) {
4221             if (PL_curpm_under) {
4222                 if (PL_curpm_under == PL_reg_curpm) {
4223                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
4224                 } else {
4225                     pm = PL_curpm_under;
4226                 }
4227             }
4228         } else {
4229             pm = PL_curpm;
4230         }
4231         rx = PM_GETRE(pm);
4232         prog = ReANY(rx);
4233     }
4234
4235 #ifdef PERL_SAWAMPERSAND
4236     r_flags = (    RXp_NPARENS(prog)
4237                 || PL_sawampersand
4238                 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
4239                 || (rpm->op_pmflags & PMf_KEEPCOPY)
4240               )
4241           ? REXEC_COPY_STR
4242           : 0;
4243 #else
4244     r_flags = REXEC_COPY_STR;
4245 #endif
4246
4247     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
4248     {
4249         SPAGAIN;
4250         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
4251         LEAVE_SCOPE(oldsave);
4252         RETURN;
4253     }
4254     PL_curpm = pm;
4255
4256     /* known replacement string? */
4257     if (dstr) {
4258         /* replacement needing upgrading? */
4259         if (DO_UTF8(TARG) && !doutf8) {
4260              nsv = sv_newmortal();
4261              SvSetSV(nsv, dstr);
4262              sv_utf8_upgrade(nsv);
4263              c = SvPV_const(nsv, clen);
4264              doutf8 = TRUE;
4265         }
4266         else {
4267             c = SvPV_const(dstr, clen);
4268             doutf8 = DO_UTF8(dstr);
4269         }
4270
4271         if (UNLIKELY(TAINT_get))
4272             rxtainted |= SUBST_TAINT_REPL;
4273     }
4274     else {
4275         c = NULL;
4276         doutf8 = FALSE;
4277     }
4278     
4279     /* can do inplace substitution? */
4280     if (c
4281 #ifdef PERL_ANY_COW
4282         && !was_cow
4283 #endif
4284         && (I32)clen <= RXp_MINLENRET(prog)
4285         && (  once
4286            || !(r_flags & REXEC_COPY_STR)
4287            || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
4288            )
4289         && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
4290         && (!doutf8 || SvUTF8(TARG))
4291         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4292     {
4293
4294 #ifdef PERL_ANY_COW
4295         /* string might have got converted to COW since we set was_cow */
4296         if (SvIsCOW(TARG)) {
4297           if (!force_on_match)
4298             goto have_a_cow;
4299           assert(SvVOK(TARG));
4300         }
4301 #endif
4302         if (force_on_match) {
4303             /* redo the first match, this time with the orig var
4304              * forced into being a string */
4305             force_on_match = 0;
4306             orig = SvPV_force_nomg(TARG, len);
4307             goto force_it;
4308         }
4309
4310         if (once) {
4311             char *d, *m;
4312             if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4313                 rxtainted |= SUBST_TAINT_PAT;
4314             m = orig + RXp_OFFS(prog)[0].start;
4315             d = orig + RXp_OFFS(prog)[0].end;
4316             s = orig;
4317             if (m - s > strend - d) {  /* faster to shorten from end */
4318                 I32 i;
4319                 if (clen) {
4320                     Copy(c, m, clen, char);
4321                     m += clen;
4322                 }
4323                 i = strend - d;
4324                 if (i > 0) {
4325                     Move(d, m, i, char);
4326                     m += i;
4327                 }
4328                 *m = '\0';
4329                 SvCUR_set(TARG, m - s);
4330             }
4331             else {      /* faster from front */
4332                 I32 i = m - s;
4333                 d -= clen;
4334                 if (i > 0)
4335                     Move(s, d - i, i, char);
4336                 sv_chop(TARG, d-i);
4337                 if