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