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