pp_hot.c

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