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