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