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 PP(pp_concat)
 257 {
 258   dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
 259   {
 260     dPOPTOPssrl;
 261     bool lbyte;
 262     STRLEN rlen;
 263     const char *rpv = NULL;
 264     bool rbyte = FALSE;
 265     bool rcopied = FALSE;
 266
 267     if (TARG == right && right != left) { /* $r = $l.$r */
 268         rpv = SvPV_nomg_const(right, rlen);
 269         rbyte = !DO_UTF8(right);
 270         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 271         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 272         rcopied = TRUE;
 273     }
 274
 275     if (TARG != left) { /* not $l .= $r */
 276         STRLEN llen;
 277         const char* const lpv = SvPV_nomg_const(left, llen);
 278         lbyte = !DO_UTF8(left);
 279         sv_setpvn(TARG, lpv, llen);
 280         if (!lbyte)
 281             SvUTF8_on(TARG);
 282         else
 283             SvUTF8_off(TARG);
 284     }
 285     else { /* $l .= $r   and   left == TARG */
 286         if (!SvOK(left)) {
 287             if ((left == right                          /* $l .= $l */
 288                  || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
 289                 && ckWARN(WARN_UNINITIALIZED)
 290                 )
 291                 report_uninit(left);
 292             SvPVCLEAR(left);
 293         }
 294         else {
 295             SvPV_force_nomg_nolen(left);
 296         }
 297         lbyte = !DO_UTF8(left);
 298         if (IN_BYTES)
 299             SvUTF8_off(left);
 300     }
 301
 302     if (!rcopied) {
 303         rpv = SvPV_nomg_const(right, rlen);
 304         rbyte = !DO_UTF8(right);
 305     }
 306     if (lbyte != rbyte) {
 307         if (lbyte)
 308             sv_utf8_upgrade_nomg(TARG);
 309         else {
 310             if (!rcopied)
 311                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 312             sv_utf8_upgrade_nomg(right);
 313             rpv = SvPV_nomg_const(right, rlen);
 314         }
 315     }
 316     sv_catpvn_nomg(TARG, rpv, rlen);
 317
 318     SETTARG;
 319     RETURN;
 320   }
 321 }
 322
 323
 324 /* pp_multiconcat()
 325
 326 Concatenate one or more args, possibly interleaved with constant string
 327 segments. The result may be assigned to, or appended to, a variable or
 328 expression.
 329
 330 Several op_flags and/or op_private bits indicate what the target is, and
 331 whether it's appended to. Valid permutations are:
 332
 333     -                                  (PADTMP) = (A.B.C....)
 334     OPpTARGET_MY                       $lex     = (A.B.C....)
 335     OPpTARGET_MY,OPpLVAL_INTRO         my $lex  = (A.B.C....)
 336     OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex    .= (A.B.C....)
 337     OPf_STACKED                        expr     = (A.B.C....)
 338     OPf_STACKED,OPpMULTICONCAT_APPEND  expr    .= (A.B.C....)
 339
 340 Other combinations like (A.B).(C.D) are not optimised into a multiconcat
 341 op, as it's too hard to get the correct ordering of ties, overload etc.
 342
 343 In addition:
 344
 345     OPpMULTICONCAT_FAKE:       not a real concat, instead an optimised
 346                                sprintf "...%s...". Don't call '.'
 347                                overloading: only use '""' overloading.
 348
 349     OPpMULTICONCAT_STRINGIFY:  (for Deparse's benefit) the RHS was of the
 350                                form "...$a...$b..." rather than
 351                                "..." . $a . "..." . $b . "..."
 352
 353 An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
 354 defined with PERL_MULTICONCAT_IX_FOO constants, where:
 355
 356
 357     FOO       index description
 358     --------  ----- ----------------------------------
 359     NARGS     0     number of arguments
 360     PLAIN_PV  1     non-utf8 constant string
 361     PLAIN_LEN 2     non-utf8 constant string length
 362     UTF8_PV   3     utf8 constant string
 363     UTF8_LEN  4     utf8 constant string length
 364     LENGTHS   5     first of nargs+1 const segment lengths
 365
 366 The idea is that a general string concatenation will have a fixed (known
 367 at compile time) number of variable args, interspersed with constant
 368 strings, e.g. "a=$a b=$b\n"
 369
 370 All the constant string segments "a=", " b=" and "\n" are stored as a
 371 single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along
 372 with a series of segment lengths: e.g. 2,3,1. In the case where the
 373 constant string is plain but has a different utf8 representation, both
 374 variants are stored, and two sets of (nargs+1) segments lengths are stored
 375 in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS.
 376
 377 A segment length of -1 indicates that there is no constant string at that
 378 point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which
 379 have differing overloading behaviour.
 380
 381 */
 382
 383 PP(pp_multiconcat)
 384 {
 385     dSP;
 386     SV *targ;                /* The SV to be assigned or appended to */
 387     SV *dsv;                 /* the SV to concat args to (often == targ) */
 388     char *dsv_pv;            /* where within SvPVX(dsv) we're writing to */
 389     STRLEN targ_len;         /* SvCUR(targ) */
 390     SV **toparg;             /* the highest arg position on the stack */
 391     UNOP_AUX_item *aux;      /* PL_op->op_aux buffer */
 392     UNOP_AUX_item *const_lens; /* the segment length array part of aux */
 393     const char *const_pv;    /* the current segment of the const string buf */
 394     UV nargs;                /* how many args were expected */
 395     UV stack_adj;            /* how much to adjust SP on return */
 396     STRLEN grow;             /* final size of destination string (dsv) */
 397     UV targ_count;           /* how many times targ has appeared on the RHS */
 398     bool is_append;          /* OPpMULTICONCAT_APPEND flag is set */
 399     bool slow_concat;        /* args too complex for quick concat */
 400     U32  dst_utf8;           /* the result will be utf8 (indicate this with
 401                                 SVf_UTF8 in a U32, rather than using bool,
 402                                 for ease of testing and setting) */
 403     /* for each arg, holds the result of an SvPV() call */
 404     struct multiconcat_svpv {
 405         char          *pv;
 406         SSize_t       len;
 407     }
 408         *targ_chain,         /* chain of slots where targ has appeared on RHS */
 409         *svpv_p,             /* ptr for looping through svpv_buf */
 410         *svpv_base,          /* first slot (may be greater than svpv_buf), */
 411         *svpv_end,           /* and slot after highest result so far, of: */
 412         svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */
 413
 414     aux   = cUNOP_AUXx(PL_op)->op_aux;
 415     stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].uv;
 416     is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND);
 417
 418     /* get targ from the stack or pad */
 419
 420     if (PL_op->op_flags & OPf_STACKED) {
 421         if (is_append) {
 422             /* for 'expr .= ...', expr is the bottom item on the stack */
 423             targ = SP[-nargs];
 424             stack_adj++;
 425         }
 426         else
 427             /* for 'expr = ...', expr is the top item on the stack */
 428             targ = POPs;
 429     }
 430     else {
 431         SV **svp = &(PAD_SVl(PL_op->op_targ));
 432         targ = *svp;
 433         if (PL_op->op_private & OPpLVAL_INTRO) {
 434             assert(PL_op->op_private & OPpTARGET_MY);
 435             save_clearsv(svp);
 436         }
 437         if (!nargs)
 438             /* $lex .= "const" doesn't cause anything to be pushed */
 439             EXTEND(SP,1);
 440     }
 441
 442     toparg = SP;
 443     SP -= (nargs - 1);
 444     dsv           = targ; /* Set the destination for all concats. This is
 445                              initially targ; later on, dsv may be switched
 446                              to point to a TEMP SV if overloading is
 447                              encountered.  */
 448     grow          = 1;    /* allow for '\0' at minimum */
 449     targ_count    = 0;
 450     targ_chain    = NULL;
 451     targ_len      = 0;
 452     svpv_end      = svpv_buf;
 453                     /* only utf8 variants of the const strings? */
 454     dst_utf8      = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8;
 455
 456
 457     /* --------------------------------------------------------------
 458      * Phase 1:
 459      *
 460      * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8
 461      * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths.
 462      *
 463      * utf8 is indicated by storing a negative length.
 464      *
 465      * Where an arg is actually targ, the stringification is deferred:
 466      * the length is set to 0, and the slot is added to targ_chain.
 467      *
 468      * If an overloaded arg is found, the loop is abandoned at that point,
 469      * and dsv is set to an SvTEMP SV where the results-so-far will be
 470      * accumulated.
 471      */
 472
 473     for (; SP <= toparg; SP++, svpv_end++) {
 474         bool simple_flags;
 475         U32 utf8;
 476         STRLEN len;
 477         SV *sv;
 478
 479         assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
 480
 481         sv = *SP;
 482         simple_flags = (SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK;
 483
 484         /* this if/else chain is arranged so that common/simple cases
 485          * take few conditionals */
 486
 487         if (LIKELY(simple_flags && (sv != targ))) {
 488             /* common case: sv is a simple PV and not the targ */
 489             svpv_end->pv  = SvPVX(sv);
 490             len           = SvCUR(sv);
 491         }
 492         else if (simple_flags) {
 493             /* sv is targ (but can't be magic or overloaded).
 494              * Delay storing PV pointer; instead, add slot to targ_chain
 495              * so it can be populated later, after targ has been grown and
 496              * we know its final SvPVX() address.
 497              */
 498           targ_on_rhs:
 499             svpv_end->len = 0; /* zerojng here means we can skip
 500                                   updating later if targ_len == 0 */
 501             svpv_end->pv  = (char*)targ_chain;
 502             targ_chain    = svpv_end;
 503             targ_count++;
 504             continue;
 505         }
 506         else {
 507             if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK))) {
 508                 /* its got magic, is tied, and/or is overloaded */
 509                 SvGETMAGIC(sv);
 510
 511                 if (UNLIKELY(SvAMAGIC(sv))
 512                     && !(PL_op->op_private & OPpMULTICONCAT_FAKE))
 513                 {
 514                     /* One of the RHS args is overloaded. Abandon stringifying
 515                      * the args at this point, then in the concat loop later
 516                      * on, concat the plain args stringified so far into a
 517                      * TEMP SV. At the end of this function the remaining
 518                      * args (including the current one) will be handled
 519                      * specially, using overload calls.
 520                      * FAKE implies an optimised sprintf which doesn't use
 521                      * concat overloading, only "" overloading.
 522                      */
 523                   setup_overload:
 524                     dsv = newSVpvn_flags("", 0, SVs_TEMP);
 525
 526                     if (targ_chain) {
 527                         /* Get the string value of targ and populate any
 528                          * RHS slots which use it */
 529                         char *pv = SvPV_nomg(targ, len);
 530                         dst_utf8 |= (SvFLAGS(targ) & SVf_UTF8);
 531                         grow += len * targ_count;
 532                         do {
 533                             struct multiconcat_svpv *p = targ_chain;
 534                             targ_chain = (struct multiconcat_svpv *)(p->pv);
 535                             p->pv  = pv;
 536                             p->len = len;
 537                         } while (targ_chain);
 538                     }
 539                     else if (is_append)
 540                         SvGETMAGIC(targ);
 541
 542                     goto phase3;
 543                 }
 544
 545                 if (SvFLAGS(sv) & SVs_RMG) {
 546                     /* probably tied; copy it to guarantee separate values
 547                      * each time it's used, e.g. "-$tied-$tied-$tied-",
 548                      * since FETCH() isn't necessarily idempotent */
 549                     SV *nsv = newSV(0);
 550                     sv_setsv_flags(nsv, sv, SV_NOSTEAL);
 551                     sv_2mortal(nsv);
 552                     if (   sv == targ
 553                         && is_append
 554                         && nargs == 1
 555                         /* no const string segments */
 556                         && aux[PERL_MULTICONCAT_IX_LENGTHS].size   == -1
 557                         && aux[PERL_MULTICONCAT_IX_LENGTHS+1].size == -1)
 558                     {
 559                         /* special-case $tied .= $tied.
 560                          *
 561                          * For something like
 562                          *    sub FETCH { $i++ }
 563                          * then
 564                          *    $tied .= $tied . $tied . $tied;
 565                          * will STORE "4123"
 566                          * while
 567                          *    $tied .= $tied
 568                          * will STORE "12"
 569                          *
 570                          * i.e. for a single mutator concat, the LHS is
 571                          * retrieved first; in all other cases it is
 572                          * retrieved last. Whether this is sane behaviour
 573                          * is open to debate; but for now, multiconcat (as
 574                          * it is an optimisation) tries to reproduce
 575                          * existing behaviour.
 576                          */
 577                         sv_catsv(nsv, sv);
 578                         sv_setsv(sv,nsv);
 579                         SP++;
 580                         goto phase7; /* just return targ as-is */
 581                     }
 582
 583                     sv = nsv;
 584                 }
 585             }
 586
 587             if (sv == targ) {
 588                 /* must warn for each RH usage of targ, except that
 589                  * we will later get one warning when doing
 590                  * SvPV_force(targ), *except* on '.=' */
 591                 if (   !SvOK(sv)
 592                     && (targ_chain || is_append)
 593                     && ckWARN(WARN_UNINITIALIZED)
 594                 )
 595                     report_uninit(sv);
 596                 goto targ_on_rhs;
 597             }
 598
 599             /* stringify general SV */
 600             svpv_end->pv = sv_2pv_flags(sv, &len, 0);
 601         }
 602
 603         utf8 = (SvFLAGS(sv) & SVf_UTF8);
 604         dst_utf8   |= utf8;
 605         ASSUME(len < SSize_t_MAX);
 606         svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len;
 607         grow += len;
 608     }
 609
 610     /* --------------------------------------------------------------
 611      * Phase 2:
 612      *
 613      * Stringify targ:
 614      *
 615      * if targ appears on the RHS or is appended to, force stringify it;
 616      * otherwise set it to "". Then set targ_len.
 617      */
 618
 619     if (is_append) {
 620         if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK))) {
 621             SvGETMAGIC(targ); /* must do before SvAMAGIC() check */
 622             if (UNLIKELY(SvAMAGIC(targ))) {
 623                 /* $overloaded .= ....;
 624                  * accumulate RHS in a temp SV rather than targ,
 625                  * then append tmp to targ at the end using overload
 626                  */
 627                 assert(!targ_chain);
 628                 dsv = newSVpvn_flags("", 0, SVs_TEMP);
 629                 goto phase3;
 630             }
 631         }
 632
 633         if (SvOK(targ)) {
 634             U32 targ_utf8;
 635           stringify_targ:
 636             SvPV_force_nomg_nolen(targ);
 637             targ_utf8 = SvFLAGS(targ) & SVf_UTF8;
 638             if (UNLIKELY(dst_utf8 & ~targ_utf8)) {
 639                  if (LIKELY(!IN_BYTES))
 640                     sv_utf8_upgrade_nomg(targ);
 641             }
 642             else
 643                 dst_utf8 |= targ_utf8;
 644
 645             targ_len = SvCUR(targ);
 646             grow += targ_len * (targ_count + is_append);
 647             goto phase3;
 648         }
 649     }
 650     else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
 651         /* Assigning to some weird LHS type. Don't force the LHS to be an
 652          * empty string; instead, do things 'long hand' by using the
 653          * overload code path, which concats to a TEMP sv and does
 654          * sv_catsv() calls rather than COPY()s. This ensures that even
 655          * bizarre code like this doesn't break or crash:
 656          *    *F = *F . *F.
 657          * (which makes the 'F' typeglob an alias to the
 658          * '*main::F*main::F' typeglob).
 659          */
 660         goto setup_overload;
 661     }
 662     else if (targ_chain) {
 663         /* targ was found on RHS.
 664          * We don't need the SvGETMAGIC() call and SvAMAGIC() test as
 665          * both were already done earlier in the SvPV() loop; other
 666          * than that we can share the same code with the append
 667          * branch below.
 668          * Note that this goto jumps directly into the SvOK() branch
 669          * even if targ isn't SvOK(), to force an 'uninitialised'
 670          * warning; e.g.
 671          *   $undef .= ....           targ only on LHS: don't warn
 672          *   $undef .= $undef ....    targ on RHS too:  warn
 673          */
 674         assert(!SvAMAGIC(targ));
 675         goto stringify_targ;
 676     }
 677
 678
 679     /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
 680      * those will be done later. */
 681     assert(targ == dsv);
 682     SV_CHECK_THINKFIRST_COW_DROP(targ);
 683     SvUPGRADE(targ, SVt_PV);
 684     SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
 685     SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8);
 686
 687   phase3:
 688
 689     /* --------------------------------------------------------------
 690      * Phase 3:
 691      *
 692      * UTF-8 tweaks and grow dsv:
 693      *
 694      * Now that we know the length and utf8-ness of both the targ and
 695      * args, grow dsv to the size needed to accumulate all the args, based
 696      * on whether targ appears on the RHS, whether we're appending, and
 697      * whether any non-utf8 args expand in size if converted to utf8.
 698      *
 699      * For the latter, if dst_utf8 we scan non-utf8 args looking for
 700      * variant chars, and adjust the svpv->len value of those args to the
 701      * utf8 size and negate it to flag them. At the same time we un-negate
 702      * the lens of any utf8 args since after this phase we no longer care
 703      * whether an arg is utf8 or not.
 704      *
 705      * Finally, initialise const_lens and const_pv based on utf8ness.
 706      * Note that there are 3 permutations:
 707      *
 708      * * If the constant string is invariant whether utf8 or not (e.g. "abc"),
 709      *   then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as
 710      *        aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of
 711      *   segment lengths.
 712      *
 713      * * If the string is fully utf8, e.g. "\x{100}", then
 714      *   aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is
 715      *   one set of segment lengths.
 716      *
 717      * * If the string has different plain and utf8 representations
 718      *   (e.g. "\x80"), then then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
 719      *   holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
 720      *   holds the utf8 rep, and there are 2 sets of segment lengths,
 721      *   with the utf8 set following after the plain set.
 722      *
 723      * On entry to this section the (pv,len) pairs in svpv_buf have the
 724      * following meanings:
 725      *    (pv,  len) a plain string
 726      *    (pv, -len) a utf8 string
 727      *    (NULL,  0) left-most targ \ linked together R-to-L
 728      *    (next,  0) other targ     / in targ_chain
 729      */
 730
 731     /* turn off utf8 handling if 'use bytes' is in scope */
 732     if (UNLIKELY(dst_utf8 && IN_BYTES)) {
 733         dst_utf8 = 0;
 734         SvUTF8_off(dsv);
 735         /* undo all the negative lengths which flag utf8-ness */
 736         for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
 737             SSize_t len = svpv_p->len;
 738             if (len < 0)
 739                 svpv_p->len = -len;
 740         }
 741     }
 742
 743     /* grow += total of lengths of constant string segments */
 744     {
 745         SSize_t len;
 746         len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN
 747                            : PERL_MULTICONCAT_IX_PLAIN_LEN].size;
 748         slow_concat = cBOOL(len);
 749         grow += len;
 750     }
 751
 752     const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
 753
 754     if (dst_utf8) {
 755         const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
 756         if (   aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv
 757             && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv)
 758             /* separate sets of lengths for plain and utf8 */
 759             const_lens += nargs + 1;
 760
 761         /* If the result is utf8 but some of the args aren't,
 762          * calculate how much extra growth is needed for all the chars
 763          * which will expand to two utf8 bytes.
 764          * Also, if the growth is non-zero, negate the length to indicate
 765          * that this this is a variant string. Conversely, un-negate the
 766          * length on utf8 args (which was only needed to flag non-utf8
 767          * args in this loop */
 768         for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
 769             char *p;
 770             SSize_t len, l, extra;
 771
 772             len = svpv_p->len;
 773             if (len <= 0) {
 774                 svpv_p->len = -len;
 775                 continue;
 776             }
 777
 778             p = svpv_p->pv;
 779             extra = 0;
 780             l = len;
 781             while (l--)
 782                 extra += !UTF8_IS_INVARIANT(*p++);
 783             if (UNLIKELY(extra)) {
 784                 grow       += extra;
 785                               /* -ve len indicates special handling */
 786                 svpv_p->len = -(len + extra);
 787                 slow_concat = TRUE;
 788             }
 789         }
 790     }
 791     else
 792         const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
 793
 794     /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
 795      * already have been dropped */
 796     assert(!SvIsCOW(dsv));
 797     dsv_pv = (SvLEN(dsv) < (grow) ? sv_grow(dsv,grow) : SvPVX(dsv));
 798
 799
 800     /* --------------------------------------------------------------
 801      * Phase 4:
 802      *
 803      * Now that dsv (which is probably targ) has been grown, we know the
 804      * final address of the targ PVX, if needed. Preserve / move targ
 805      * contents if appending or if targ appears on RHS.
 806      *
 807      * Also update svpv_buf slots in targ_chain.
 808      *
 809      * Don't bother with any of this if the target length is zero:
 810      * targ_len is set to zero unless we're appending or targ appears on
 811      * RHS.  And even if it is, we can optimise by skipping this chunk of
 812      * code for zero targ_len. In the latter case, we don't need to update
 813      * the slots in targ_chain with the (zero length) target string, since
 814      * we set the len in such slots to 0 earlier, and since the Copy() is
 815      * skipped on zero length, it doesn't matter what svpv_p->pv contains.
 816      *
 817      * On entry to this section the (pv,len) pairs in svpv_buf have the
 818      * following meanings:
 819      *    (pv,  len)         a pure-plain or utf8 string
 820      *    (pv, -(len+extra)) a plain string which will expand by 'extra'
 821      *                         bytes when converted to utf8
 822      *    (NULL,  0)         left-most targ \ linked together R-to-L
 823      *    (next,  0)         other targ     / in targ_chain
 824      *
 825      * On exit, the targ contents will have been moved to the
 826      * earliest place they are needed (e.g. $x = "abc$x" will shift them
 827      * 3 bytes, while $x .= ... will leave them at the beginning);
 828      * and dst_pv will point to the location within SvPVX(dsv) where the
 829      * next arg should be copied.
 830      */
 831
 832     svpv_base = svpv_buf;
 833
 834     if (targ_len) {
 835         struct multiconcat_svpv *tc_stop;
 836         char *targ_pv = dsv_pv;
 837
 838         assert(targ == dsv);
 839         assert(is_append || targ_count);
 840
 841         if (is_append) {
 842             dsv_pv += targ_len;
 843             tc_stop = NULL;
 844         }
 845         else {
 846             /* The targ appears on RHS, e.g. '$t = $a . $t . $t'.
 847              * Move the current contents of targ to the first
 848              * position where it's needed, and use that as the src buffer
 849              * for any further uses (such as the second RHS $t above).
 850              * In calculating the first position, we need to sum the
 851              * lengths of all consts and args before that.
 852              */
 853
 854             UNOP_AUX_item *lens = const_lens;
 855                                 /* length of first const string segment */
 856             STRLEN offset       = lens->size > 0 ? lens->size : 0;
 857
 858             assert(targ_chain);
 859             svpv_p = svpv_base;
 860
 861             for (;;) {
 862                 SSize_t len;
 863                 if (!svpv_p->pv)
 864                     break; /* the first targ argument */
 865                 /* add lengths of the next arg and const string segment */
 866                 len = svpv_p->len;
 867                 if (len < 0)  /* variant args have this */
 868                     len = -len;
 869                 offset += (STRLEN)len;
 870                 len = (++lens)->size;
 871                 offset += (len >= 0) ? (STRLEN)len : 0;
 872                 if (!offset) {
 873                     /* all args and consts so far are empty; update
 874                      * the start position for the concat later */
 875                     svpv_base++;
 876                     const_lens++;
 877                 }
 878                 svpv_p++;
 879                 assert(svpv_p < svpv_end);
 880             }
 881
 882             if (offset) {
 883                 targ_pv += offset;
 884                 Move(dsv_pv, targ_pv, targ_len, char);
 885                 /* a negative length implies don't Copy(), but do increment */
 886                 svpv_p->len = -targ_len;
 887                 slow_concat = TRUE;
 888             }
 889             else {
 890                 /* skip the first targ copy */
 891                 svpv_base++;
 892                 const_lens++;
 893                 dsv_pv += targ_len;
 894             }
 895
 896             /* Don't populate the first targ slot in the loop below; it's
 897              * either not used because we advanced svpv_base beyond it, or
 898              * we already stored the special -targ_len value in it
 899              */
 900             tc_stop = svpv_p;
 901         }
 902
 903         /* populate slots in svpv_buf representing targ on RHS */
 904         while (targ_chain != tc_stop) {
 905             struct multiconcat_svpv *p = targ_chain;
 906             targ_chain = (struct multiconcat_svpv *)(p->pv);
 907             p->pv  = targ_pv;
 908             p->len = (SSize_t)targ_len;
 909         }
 910     }
 911
 912
 913     /* --------------------------------------------------------------
 914      * Phase 5:
 915      *
 916      * Append all the args in svpv_buf, plus the const strings, to dsv.
 917      *
 918      * On entry to this section the (pv,len) pairs in svpv_buf have the
 919      * following meanings:
 920      *    (pv,  len)         a pure-plain or utf8 string (which may be targ)
 921      *    (pv, -(len+extra)) a plain string which will expand by 'extra'
 922      *                         bytes when converted to utf8
 923      *    (0,  -len)         left-most targ, whose content has already
 924      *                         been copied. Just advance dsv_pv by len.
 925      */
 926
 927     /* If there are no constant strings and no special case args
 928      * (svpv_p->len < 0), use a simpler, more efficient concat loop
 929      */
 930     if (!slow_concat) {
 931         for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) {
 932             SSize_t len = svpv_p->len;
 933             if (!len)
 934                 continue;
 935             Copy(svpv_p->pv, dsv_pv, len, char);
 936             dsv_pv += len;
 937         }
 938         const_lens += (svpv_end - svpv_base + 1);
 939     }
 940     else {
 941         /* Note that we iterate the loop nargs+1 times: to append nargs
 942          * arguments and nargs+1 constant strings. For example, "-$a-$b-"
 943          */
 944         svpv_p = svpv_base - 1;
 945
 946         for (;;) {
 947             SSize_t len = (const_lens++)->size;
 948
 949             /* append next const string segment */
 950             if (len > 0) {
 951                 Copy(const_pv, dsv_pv, len, char);
 952                 dsv_pv   += len;
 953                 const_pv += len;
 954             }
 955
 956             if (++svpv_p == svpv_end)
 957                 break;
 958
 959             /* append next arg */
 960             len = svpv_p->len;
 961
 962             if (LIKELY(len > 0)) {
 963                 Copy(svpv_p->pv, dsv_pv, len, char);
 964                 dsv_pv += len;
 965             }
 966             else if (UNLIKELY(len < 0)) {
 967                 /* negative length indicates two special cases */
 968                 const char *p = svpv_p->pv;
 969                 len = -len;
 970                 if (UNLIKELY(p)) {
 971                     /* copy plain-but-variant pv to a utf8 targ */
 972                     assert(dst_utf8);
 973                     while (len--) {
 974                         U8 c = (U8) *p++;
 975                         if (UTF8_IS_INVARIANT(c))
 976                             *dsv_pv++ = c;
 977                         else {
 978                             *dsv_pv++ = UTF8_EIGHT_BIT_HI(c);
 979                             *dsv_pv++ = UTF8_EIGHT_BIT_LO(c);
 980                             len--;
 981                         }
 982                     }
 983                 }
 984                 else
 985                     /* arg is already-copied targ */
 986                     dsv_pv += len;
 987             }
 988
 989         }
 990     }
 991
 992     *dsv_pv = '\0';
 993     SvCUR_set(dsv, dsv_pv - SvPVX(dsv));
 994     assert(grow >= SvCUR(dsv) + 1);
 995     assert(SvLEN(dsv) >= SvCUR(dsv) + 1);
 996
 997     /* --------------------------------------------------------------
 998      * Phase 6:
 999      *
1000      * Handle overloading. If an overloaded arg or targ was detected
1001      * earlier, dsv will have been set to a new mortal, and any args and
1002      * consts to the left of the first overloaded arg will have been
1003      * accumulated to it. This section completes any further concatenation
1004      * steps with overloading handled.
1005      */
1006
1007     if (UNLIKELY(dsv != targ)) {
1008         SV *res;
1009
1010         SvFLAGS(dsv) |= dst_utf8;
1011
1012         if (SP <= toparg) {
1013             /* Stringifying the RHS was abandoned because *SP
1014              * is overloaded. dsv contains all the concatted strings
1015              * before *SP. Apply the rest of the args using overloading.
1016              */
1017             SV *left, *right, *res;
1018             int i;
1019             bool getmg = FALSE;
1020             SV *constsv = NULL;
1021                                /* number of args already concatted */
1022             STRLEN n          = (nargs - 1) - (toparg - SP);
1023                                /* current arg is either the first
1024                                 * or second value to be concatted
1025                                 * (including constant strings), so would
1026                                 * form part of the first concat */
1027             bool first_concat = (    n == 0
1028                                  || (n == 1 && const_lens[-2].size < 0
1029                                             && const_lens[-1].size < 0));
1030             int  f_assign     = first_concat ? 0 : AMGf_assign;
1031
1032             left = dsv;
1033
1034             for (; n < nargs; n++) {
1035                 /* loop twice, first applying the arg, then the const segment */
1036                 for (i = 0; i < 2; i++) {
1037                     if (i) {
1038                         /* append next const string segment */
1039                         STRLEN len = (STRLEN)((const_lens++)->size);
1040                         /* a length of -1 implies no constant string
1041                          * rather than a zero-length one, e.g.
1042                          * ($a . $b) versus ($a . "" . $b)
1043                          */
1044                         if ((SSize_t)len < 0)
1045                             continue;
1046
1047                         /* set constsv to the next constant string segment */
1048                         if (constsv) {
1049                             sv_setpvn(constsv, const_pv, len);
1050                             if (dst_utf8)
1051                                 SvUTF8_on(constsv);
1052                             else
1053                                 SvUTF8_off(constsv);
1054                         }
1055                         else
1056                             constsv = newSVpvn_flags(const_pv, len,
1057                                                     (dst_utf8 | SVs_TEMP));
1058
1059                         right = constsv;
1060                         const_pv += len;
1061                     }
1062                     else {
1063                         /* append next arg */
1064                         right = *SP++;
1065                         if (getmg)
1066                             SvGETMAGIC(right);
1067                         else
1068                             /* SvGETMAGIC already called on this SV just
1069                              * before we broke from the loop earlier */
1070                             getmg = TRUE;
1071
1072                         if (first_concat && n == 0 && const_lens[-1].size < 0) {
1073                             /* nothing before the current arg; repeat the
1074                              * loop to get a second arg */
1075                             left = right;
1076                             first_concat = FALSE;
1077                             continue;
1078                         }
1079                     }
1080
1081                     if ((SvAMAGIC(left) || SvAMAGIC(right))
1082                         && (res = amagic_call(left, right, concat_amg, f_assign))
1083                     )
1084                         left = res;
1085                     else {
1086                         if (left != dsv) {
1087                             sv_setsv(dsv, left);
1088                             left = dsv;
1089                         }
1090                         sv_catsv_nomg(left, right);
1091                     }
1092                     f_assign = AMGf_assign;
1093                 }
1094             }
1095             dsv = left;
1096         }
1097
1098         /* assign/append RHS (dsv) to LHS (targ) */
1099         if (is_append)  {
1100             if ((SvAMAGIC(targ) || SvAMAGIC(dsv))
1101                 && (res = amagic_call(targ, dsv, concat_amg, AMGf_assign))
1102             )
1103                 sv_setsv(targ, res);
1104             else
1105                 sv_catsv_nomg(targ, dsv);
1106         }
1107         else
1108             sv_setsv(targ, dsv);
1109     }
1110
1111     /* --------------------------------------------------------------
1112      * Phase 7:
1113      *
1114      * return result
1115      */
1116
1117   phase7:
1118
1119     SP -= stack_adj;
1120     SvTAINT(targ);
1121     SETTARG;
1122     RETURN;
1123 }
1124
1125
1126 /* push the elements of av onto the stack.
1127  * Returns PL_op->op_next to allow tail-call optimisation of its callers */
1128
1129 STATIC OP*
1130 S_pushav(pTHX_ AV* const av)
1131 {
1132     dSP;
1133     const SSize_t maxarg = AvFILL(av) + 1;
1134     EXTEND(SP, maxarg);
1135     if (UNLIKELY(SvRMAGICAL(av))) {
1136         PADOFFSET i;
1137         for (i=0; i < (PADOFFSET)maxarg; i++) {
1138             SV ** const svp = av_fetch(av, i, FALSE);
1139             SP[i+1] = svp ? *svp : &PL_sv_undef;
1140         }
1141     }
1142     else {
1143         PADOFFSET i;
1144         for (i=0; i < (PADOFFSET)maxarg; i++) {
1145             SV * const sv = AvARRAY(av)[i];
1146             SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
1147         }
1148     }
1149     SP += maxarg;
1150     PUTBACK;
1151     return NORMAL;
1152 }
1153
1154
1155 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
1156
1157 PP(pp_padrange)
1158 {
1159     dSP;
1160     PADOFFSET base = PL_op->op_targ;
1161     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
1162     if (PL_op->op_flags & OPf_SPECIAL) {
1163         /* fake the RHS of my ($x,$y,..) = @_ */
1164         PUSHMARK(SP);
1165         (void)S_pushav(aTHX_ GvAVn(PL_defgv));
1166         SPAGAIN;
1167     }
1168
1169     /* note, this is only skipped for compile-time-known void cxt */
1170     if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
1171         int i;
1172
1173         EXTEND(SP, count);
1174         PUSHMARK(SP);
1175         for (i = 0; i <count; i++)
1176             *++SP = PAD_SV(base+i);
1177     }
1178     if (PL_op->op_private & OPpLVAL_INTRO) {
1179         SV **svp = &(PAD_SVl(base));
1180         const UV payload = (UV)(
1181                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
1182                     | (count << SAVE_TIGHT_SHIFT)
1183                     | SAVEt_CLEARPADRANGE);
1184         int i;
1185
1186         STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
1187         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
1188                 == (Size_t)base);
1189         {
1190             dSS_ADD;
1191             SS_ADD_UV(payload);
1192             SS_ADD_END(1);
1193         }
1194
1195         for (i = 0; i <count; i++)
1196             SvPADSTALE_off(*svp++); /* mark lexical as active */
1197     }
1198     RETURN;
1199 }
1200
1201
1202 PP(pp_padsv)
1203 {
1204     dSP;
1205     EXTEND(SP, 1);
1206     {
1207         OP * const op = PL_op;
1208         /* access PL_curpad once */
1209         SV ** const padentry = &(PAD_SVl(op->op_targ));
1210         {
1211             dTARG;
1212             TARG = *padentry;
1213             PUSHs(TARG);
1214             PUTBACK; /* no pop/push after this, TOPs ok */
1215         }
1216         if (op->op_flags & OPf_MOD) {
1217             if (op->op_private & OPpLVAL_INTRO)
1218                 if (!(op->op_private & OPpPAD_STATE))
1219                     save_clearsv(padentry);
1220             if (op->op_private & OPpDEREF) {
1221                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
1222                    than TARG reduces the scope of TARG, so it does not
1223                    span the call to save_clearsv, resulting in smaller
1224                    machine code. */
1225                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
1226             }
1227         }
1228         return op->op_next;
1229     }
1230 }
1231
1232 PP(pp_readline)
1233 {
1234     dSP;
1235     /* pp_coreargs pushes a NULL to indicate no args passed to
1236      * CORE::readline() */
1237     if (TOPs) {
1238         SvGETMAGIC(TOPs);
1239         tryAMAGICunTARGETlist(iter_amg, 0);
1240         PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1241     }
1242     else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
1243     if (!isGV_with_GP(PL_last_in_gv)) {
1244         if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
1245             PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
1246         else {
1247             dSP;
1248             XPUSHs(MUTABLE_SV(PL_last_in_gv));
1249             PUTBACK;
1250             Perl_pp_rv2gv(aTHX);
1251             PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
1252             assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
1253         }
1254     }
1255     return do_readline();
1256 }
1257
1258 PP(pp_eq)
1259 {
1260     dSP;
1261     SV *left, *right;
1262
1263     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
1264     right = POPs;
1265     left  = TOPs;
1266     SETs(boolSV(
1267         (SvIOK_notUV(left) && SvIOK_notUV(right))
1268         ? (SvIVX(left) == SvIVX(right))
1269         : ( do_ncmp(left, right) == 0)
1270     ));
1271     RETURN;
1272 }
1273
1274
1275 /* also used for: pp_i_preinc() */
1276
1277 PP(pp_preinc)
1278 {
1279     SV *sv = *PL_stack_sp;
1280
1281     if (LIKELY(((sv->sv_flags &
1282                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1283                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1284                 == SVf_IOK))
1285         && SvIVX(sv) != IV_MAX)
1286     {
1287         SvIV_set(sv, SvIVX(sv) + 1);
1288     }
1289     else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
1290         sv_inc(sv);
1291     SvSETMAGIC(sv);
1292     return NORMAL;
1293 }
1294
1295
1296 /* also used for: pp_i_predec() */
1297
1298 PP(pp_predec)
1299 {
1300     SV *sv = *PL_stack_sp;
1301
1302     if (LIKELY(((sv->sv_flags &
1303                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1304                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1305                 == SVf_IOK))
1306         && SvIVX(sv) != IV_MIN)
1307     {
1308         SvIV_set(sv, SvIVX(sv) - 1);
1309     }
1310     else /* Do all the PERL_PRESERVE_IVUV and hard cases  in sv_dec */
1311         sv_dec(sv);
1312     SvSETMAGIC(sv);
1313     return NORMAL;
1314 }
1315
1316
1317 /* also used for: pp_orassign() */
1318
1319 PP(pp_or)
1320 {
1321     dSP;
1322     SV *sv;
1323     PERL_ASYNC_CHECK();
1324     sv = TOPs;
1325     if (SvTRUE_NN(sv))
1326         RETURN;
1327     else {
1328         if (PL_op->op_type == OP_OR)
1329             --SP;
1330         RETURNOP(cLOGOP->op_other);
1331     }
1332 }
1333
1334
1335 /* also used for: pp_dor() pp_dorassign() */
1336
1337 PP(pp_defined)
1338 {
1339     dSP;
1340     SV* sv;
1341     bool defined;
1342     const int op_type = PL_op->op_type;
1343     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
1344
1345     if (is_dor) {
1346         PERL_ASYNC_CHECK();
1347         sv = TOPs;
1348         if (UNLIKELY(!sv || !SvANY(sv))) {
1349             if (op_type == OP_DOR)
1350                 --SP;
1351             RETURNOP(cLOGOP->op_other);
1352         }
1353     }
1354     else {
1355         /* OP_DEFINED */
1356         sv = POPs;
1357         if (UNLIKELY(!sv || !SvANY(sv)))
1358             RETPUSHNO;
1359     }
1360
1361     defined = FALSE;
1362     switch (SvTYPE(sv)) {
1363     case SVt_PVAV:
1364         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1365             defined = TRUE;
1366         break;
1367     case SVt_PVHV:
1368         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1369             defined = TRUE;
1370         break;
1371     case SVt_PVCV:
1372         if (CvROOT(sv) || CvXSUB(sv))
1373             defined = TRUE;
1374         break;
1375     default:
1376         SvGETMAGIC(sv);
1377         if (SvOK(sv))
1378             defined = TRUE;
1379         break;
1380     }
1381
1382     if (is_dor) {
1383         if(defined)
1384             RETURN;
1385         if(op_type == OP_DOR)
1386             --SP;
1387         RETURNOP(cLOGOP->op_other);
1388     }
1389     /* assuming OP_DEFINED */
1390     if(defined)
1391         RETPUSHYES;
1392     RETPUSHNO;
1393 }
1394
1395
1396
1397 PP(pp_add)
1398 {
1399     dSP; dATARGET; bool useleft; SV *svl, *svr;
1400
1401     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
1402     svr = TOPs;
1403     svl = TOPm1s;
1404
1405 #ifdef PERL_PRESERVE_IVUV
1406
1407     /* special-case some simple common cases */
1408     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1409         IV il, ir;
1410         U32 flags = (svl->sv_flags & svr->sv_flags);
1411         if (flags & SVf_IOK) {
1412             /* both args are simple IVs */
1413             UV topl, topr;
1414             il = SvIVX(svl);
1415             ir = SvIVX(svr);
1416           do_iv:
1417             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1418             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1419
1420             /* if both are in a range that can't under/overflow, do a
1421              * simple integer add: if the top of both numbers
1422              * are 00  or 11, then it's safe */
1423             if (!( ((topl+1) | (topr+1)) & 2)) {
1424                 SP--;
1425                 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
1426                 SETs(TARG);
1427                 RETURN;
1428             }
1429             goto generic;
1430         }
1431         else if (flags & SVf_NOK) {
1432             /* both args are NVs */
1433             NV nl = SvNVX(svl);
1434             NV nr = SvNVX(svr);
1435
1436             if (
1437 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1438                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1439                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1440 #else
1441                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1442 #endif
1443                 )
1444                 /* nothing was lost by converting to IVs */
1445                 goto do_iv;
1446             SP--;
1447             TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
1448             SETs(TARG);
1449             RETURN;
1450         }
1451     }
1452
1453   generic:
1454
1455     useleft = USE_LEFT(svl);
1456     /* We must see if we can perform the addition with integers if possible,
1457        as the integer code detects overflow while the NV code doesn't.
1458        If either argument hasn't had a numeric conversion yet attempt to get
1459        the IV. It's important to do this now, rather than just assuming that
1460        it's not IOK as a PV of "9223372036854775806" may not take well to NV
1461        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1462        integer in case the second argument is IV=9223372036854775806
1463        We can (now) rely on sv_2iv to do the right thing, only setting the
1464        public IOK flag if the value in the NV (or PV) slot is truly integer.
1465
1466        A side effect is that this also aggressively prefers integer maths over
1467        fp maths for integer values.
1468
1469        How to detect overflow?
1470
1471        C 99 section 6.2.6.1 says
1472
1473        The range of nonnegative values of a signed integer type is a subrange
1474        of the corresponding unsigned integer type, and the representation of
1475        the same value in each type is the same. A computation involving
1476        unsigned operands can never overflow, because a result that cannot be
1477        represented by the resulting unsigned integer type is reduced modulo
1478        the number that is one greater than the largest value that can be
1479        represented by the resulting type.
1480
1481        (the 9th paragraph)
1482
1483        which I read as "unsigned ints wrap."
1484
1485        signed integer overflow seems to be classed as "exception condition"
1486
1487        If an exceptional condition occurs during the evaluation of an
1488        expression (that is, if the result is not mathematically defined or not
1489        in the range of representable values for its type), the behavior is
1490        undefined.
1491
1492        (6.5, the 5th paragraph)
1493
1494        I had assumed that on 2s complement machines signed arithmetic would
1495        wrap, hence coded pp_add and pp_subtract on the assumption that
1496        everything perl builds on would be happy.  After much wailing and
1497        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
1498        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
1499        unsigned code below is actually shorter than the old code. :-)
1500     */
1501
1502     if (SvIV_please_nomg(svr)) {
1503         /* Unless the left argument is integer in range we are going to have to
1504            use NV maths. Hence only attempt to coerce the right argument if
1505            we know the left is integer.  */
1506         UV auv = 0;
1507         bool auvok = FALSE;
1508         bool a_valid = 0;
1509
1510         if (!useleft) {
1511             auv = 0;
1512             a_valid = auvok = 1;
1513             /* left operand is undef, treat as zero. + 0 is identity,
1514                Could SETi or SETu right now, but space optimise by not adding
1515                lots of code to speed up what is probably a rarish case.  */
1516         } else {
1517             /* Left operand is defined, so is it IV? */
1518             if (SvIV_please_nomg(svl)) {
1519                 if ((auvok = SvUOK(svl)))
1520                     auv = SvUVX(svl);
1521                 else {
1522                     const IV aiv = SvIVX(svl);
1523                     if (aiv >= 0) {
1524                         auv = aiv;
1525                         auvok = 1;      /* Now acting as a sign flag.  */
1526                     } else {
1527                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1528                     }
1529                 }
1530                 a_valid = 1;
1531             }
1532         }
1533         if (a_valid) {
1534             bool result_good = 0;
1535             UV result;
1536             UV buv;
1537             bool buvok = SvUOK(svr);
1538
1539             if (buvok)
1540                 buv = SvUVX(svr);
1541             else {
1542                 const IV biv = SvIVX(svr);
1543                 if (biv >= 0) {
1544                     buv = biv;
1545                     buvok = 1;
1546                 } else
1547                     buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1548             }
1549             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1550                else "IV" now, independent of how it came in.
1551                if a, b represents positive, A, B negative, a maps to -A etc
1552                a + b =>  (a + b)
1553                A + b => -(a - b)
1554                a + B =>  (a - b)
1555                A + B => -(a + b)
1556                all UV maths. negate result if A negative.
1557                add if signs same, subtract if signs differ. */
1558
1559             if (auvok ^ buvok) {
1560                 /* Signs differ.  */
1561                 if (auv >= buv) {
1562                     result = auv - buv;
1563                     /* Must get smaller */
1564                     if (result <= auv)
1565                         result_good = 1;
1566                 } else {
1567                     result = buv - auv;
1568                     if (result <= buv) {
1569                         /* result really should be -(auv-buv). as its negation
1570                            of true value, need to swap our result flag  */
1571                         auvok = !auvok;
1572                         result_good = 1;
1573                     }
1574                 }
1575             } else {
1576                 /* Signs same */
1577                 result = auv + buv;
1578                 if (result >= auv)
1579                     result_good = 1;
1580             }
1581             if (result_good) {
1582                 SP--;
1583                 if (auvok)
1584                     SETu( result );
1585                 else {
1586                     /* Negate result */
1587                     if (result <= (UV)IV_MIN)
1588                         SETi(result == (UV)IV_MIN
1589                                 ? IV_MIN : -(IV)result);
1590                     else {
1591                         /* result valid, but out of range for IV.  */
1592                         SETn( -(NV)result );
1593                     }
1594                 }
1595                 RETURN;
1596             } /* Overflow, drop through to NVs.  */
1597         }
1598     }
1599
1600 #else
1601     useleft = USE_LEFT(svl);
1602 #endif
1603
1604     {
1605         NV value = SvNV_nomg(svr);
1606         (void)POPs;
1607         if (!useleft) {
1608             /* left operand is undef, treat as zero. + 0.0 is identity. */
1609             SETn(value);
1610             RETURN;
1611         }
1612         SETn( value + SvNV_nomg(svl) );
1613         RETURN;
1614     }
1615 }
1616
1617
1618 /* also used for: pp_aelemfast_lex() */
1619
1620 PP(pp_aelemfast)
1621 {
1622     dSP;
1623     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
1624         ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
1625     const U32 lval = PL_op->op_flags & OPf_MOD;
1626     const I8 key   = (I8)PL_op->op_private;
1627     SV** svp;
1628     SV *sv;
1629
1630     assert(SvTYPE(av) == SVt_PVAV);
1631
1632     EXTEND(SP, 1);
1633
1634     /* inlined av_fetch() for simple cases ... */
1635     if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
1636         sv = AvARRAY(av)[key];
1637         if (sv) {
1638             PUSHs(sv);
1639             RETURN;
1640         }
1641     }
1642
1643     /* ... else do it the hard way */
1644     svp = av_fetch(av, key, lval);
1645     sv = (svp ? *svp : &PL_sv_undef);
1646
1647     if (UNLIKELY(!svp && lval))
1648         DIE(aTHX_ PL_no_aelem, (int)key);
1649
1650     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
1651         mg_get(sv);
1652     PUSHs(sv);
1653     RETURN;
1654 }
1655
1656 PP(pp_join)
1657 {
1658     dSP; dMARK; dTARGET;
1659     MARK++;
1660     do_join(TARG, *MARK, MARK, SP);
1661     SP = MARK;
1662     SETs(TARG);
1663     RETURN;
1664 }
1665
1666 /* Oversized hot code. */
1667
1668 /* also used for: pp_say() */
1669
1670 PP(pp_print)
1671 {
1672     dSP; dMARK; dORIGMARK;
1673     PerlIO *fp;
1674     MAGIC *mg;
1675     GV * const gv
1676         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1677     IO *io = GvIO(gv);
1678
1679     if (io
1680         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1681     {
1682       had_magic:
1683         if (MARK == ORIGMARK) {
1684             /* If using default handle then we need to make space to
1685              * pass object as 1st arg, so move other args up ...
1686              */
1687             MEXTEND(SP, 1);
1688             ++MARK;
1689             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1690             ++SP;
1691         }
1692         return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
1693                                 mg,
1694                                 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
1695                                  | (PL_op->op_type == OP_SAY
1696                                     ? TIED_METHOD_SAY : 0)), sp - mark);
1697     }
1698     if (!io) {
1699         if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
1700             && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1701             goto had_magic;
1702         report_evil_fh(gv);
1703         SETERRNO(EBADF,RMS_IFI);
1704         goto just_say_no;
1705     }
1706     else if (!(fp = IoOFP(io))) {
1707         if (IoIFP(io))
1708             report_wrongway_fh(gv, '<');
1709         else
1710             report_evil_fh(gv);
1711         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1712         goto just_say_no;
1713     }
1714     else {
1715         SV * const ofs = GvSV(PL_ofsgv); /* $, */
1716         MARK++;
1717         if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
1718             while (MARK <= SP) {
1719                 if (!do_print(*MARK, fp))
1720                     break;
1721                 MARK++;
1722                 if (MARK <= SP) {
1723                     /* don't use 'ofs' here - it may be invalidated by magic callbacks */
1724                     if (!do_print(GvSV(PL_ofsgv), fp)) {
1725                         MARK--;
1726                         break;
1727                     }
1728                 }
1729             }
1730         }
1731         else {
1732             while (MARK <= SP) {
1733                 if (!do_print(*MARK, fp))
1734                     break;
1735                 MARK++;
1736             }
1737         }
1738         if (MARK <= SP)
1739             goto just_say_no;
1740         else {
1741             if (PL_op->op_type == OP_SAY) {
1742                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
1743                     goto just_say_no;
1744             }
1745             else if (PL_ors_sv && SvOK(PL_ors_sv))
1746                 if (!do_print(PL_ors_sv, fp)) /* $\ */
1747                     goto just_say_no;
1748
1749             if (IoFLAGS(io) & IOf_FLUSH)
1750                 if (PerlIO_flush(fp) == EOF)
1751                     goto just_say_no;
1752         }
1753     }
1754     SP = ORIGMARK;
1755     XPUSHs(&PL_sv_yes);
1756     RETURN;
1757
1758   just_say_no:
1759     SP = ORIGMARK;
1760     XPUSHs(&PL_sv_undef);
1761     RETURN;
1762 }
1763
1764
1765 /* do the common parts of pp_padhv() and pp_rv2hv()
1766  * It assumes the caller has done EXTEND(SP, 1) or equivalent.
1767  * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
1768  * 'has_targ' indicates that the op has a target - this should
1769  * be a compile-time constant so that the code can constant-folded as
1770  * appropriate
1771  * */
1772
1773 PERL_STATIC_INLINE OP*
1774 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
1775 {
1776     bool is_tied;
1777     bool is_bool;
1778     MAGIC *mg;
1779     dSP;
1780     IV  i;
1781     SV *sv;
1782
1783     assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
1784
1785     if (gimme == G_ARRAY) {
1786         hv_pushkv(hv, 3);
1787         return NORMAL;
1788     }
1789
1790     if (is_keys)
1791         /* 'keys %h' masquerading as '%h': reset iterator */
1792         (void)hv_iterinit(hv);
1793
1794     if (gimme == G_VOID)
1795         return NORMAL;
1796
1797     is_bool = (     PL_op->op_private & OPpTRUEBOOL
1798               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
1799                   && block_gimme() == G_VOID));
1800     is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
1801
1802     if (UNLIKELY(is_tied)) {
1803         if (is_keys && !is_bool) {
1804             i = 0;
1805             while (hv_iternext(hv))
1806                 i++;
1807             goto push_i;
1808         }
1809         else {
1810             sv = magic_scalarpack(hv, mg);
1811             goto push_sv;
1812         }
1813     }
1814     else {
1815         i = HvUSEDKEYS(hv);
1816         if (is_bool) {
1817             sv = i ? &PL_sv_yes : &PL_sv_zero;
1818           push_sv:
1819             PUSHs(sv);
1820         }
1821         else {
1822           push_i:
1823             if (has_targ) {
1824                 dTARGET;
1825                 PUSHi(i);
1826             }
1827             else
1828 #ifdef PERL_OP_PARENT
1829             if (is_keys) {
1830                 /* parent op should be an unused OP_KEYS whose targ we can
1831                  * use */
1832                 dTARG;
1833                 OP *k;
1834
1835                 assert(!OpHAS_SIBLING(PL_op));
1836                 k = PL_op->op_sibparent;
1837                 assert(k->op_type == OP_KEYS);
1838                 TARG = PAD_SV(k->op_targ);
1839                 PUSHi(i);
1840             }
1841             else
1842 #endif
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                             sv = sv_2mortal(newSVavdefelem(av,
3598                             /* Resolve a negative index now, unless it points
3599                              * before the beginning of the array, in which
3600                              * case record it for error reporting in
3601                              * magic_setdefelem. */
3602                                 elem < 0 && len + elem >= 0
3603                                     ? len + elem : elem, 1));
3604                         }
3605                         else {
3606                             if (UNLIKELY(localizing)) {
3607                                 if (preeminent) {
3608                                     save_aelem(av, elem, svp);
3609                                     sv = *svp; /* may have changed */
3610                                 }
3611                                 else
3612                                     SAVEADELETE(av, elem);
3613                             }
3614                         }
3615                     }
3616                     else {
3617                         sv = (svp ? *svp : &PL_sv_undef);
3618                         /* see note in pp_helem() */
3619                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
3620                             mg_get(sv);
3621                     }
3622                 }
3623
3624             }
3625           finish:
3626             {
3627                 dSP;
3628                 XPUSHs(sv);
3629                 RETURN;
3630             }
3631             /* NOTREACHED */
3632
3633
3634
3635
3636         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
3637             sv = PAD_SVl((++items)->pad_offset);
3638             goto do_HV_helem;
3639
3640         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
3641             sv = UNOP_AUX_item_sv(++items);
3642             assert(isGV_with_GP(sv));
3643             sv = (SV*)GvHVn((GV*)sv);
3644             goto do_HV_helem;
3645
3646         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
3647             {
3648                 dSP;
3649                 sv = POPs;
3650                 PUTBACK;
3651                 goto do_HV_rv2hv_helem;
3652             }
3653
3654         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
3655             sv = UNOP_AUX_item_sv(++items);
3656             assert(isGV_with_GP(sv));
3657             sv = GvSVn((GV*)sv);
3658             goto do_HV_vivify_rv2hv_helem;
3659
3660         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
3661             sv = PAD_SVl((++items)->pad_offset);
3662             /* FALLTHROUGH */
3663
3664         do_HV_vivify_rv2hv_helem:
3665         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
3666             /* this is the OPpDEREF action normally found at the end of
3667              * ops like aelem, helem, rv2sv */
3668             sv = vivify_ref(sv, OPpDEREF_HV);
3669             /* FALLTHROUGH */
3670
3671         do_HV_rv2hv_helem:
3672             /* this is basically a copy of pp_rv2hv when it just has the
3673              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
3674
3675             SvGETMAGIC(sv);
3676             if (LIKELY(SvROK(sv))) {
3677                 if (UNLIKELY(SvAMAGIC(sv))) {
3678                     sv = amagic_deref_call(sv, to_hv_amg);
3679                 }
3680                 sv = SvRV(sv);
3681                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
3682                     DIE(aTHX_ "Not a HASH reference");
3683             }
3684             else if (SvTYPE(sv) != SVt_PVHV) {
3685                 if (!isGV_with_GP(sv))
3686                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
3687                 sv = MUTABLE_SV(GvHVn((GV*)sv));
3688             }
3689             /* FALLTHROUGH */
3690
3691         do_HV_helem:
3692             {
3693                 /* retrieve the key; this may be either a lexical / package
3694                  * var or a string constant, whose index/ptr is stored as an
3695                  * item
3696                  */
3697                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
3698
3699                 assert(SvTYPE(sv) == SVt_PVHV);
3700
3701                 switch (actions & MDEREF_INDEX_MASK) {
3702                 case MDEREF_INDEX_none:
3703                     goto finish;
3704
3705                 case MDEREF_INDEX_const:
3706                     keysv = UNOP_AUX_item_sv(++items);
3707                     break;
3708
3709                 case MDEREF_INDEX_padsv:
3710                     keysv = PAD_SVl((++items)->pad_offset);
3711                     break;
3712
3713                 case MDEREF_INDEX_gvsv:
3714                     keysv = UNOP_AUX_item_sv(++items);
3715                     keysv = GvSVn((GV*)keysv);
3716                     break;
3717                 }
3718
3719                 /* see comment above about setting this var */
3720                 PL_multideref_pc = items;
3721
3722
3723                 /* ensure that candidate CONSTs have been HEKified */
3724                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
3725                        || SvTYPE(keysv) >= SVt_PVMG
3726                        || !SvOK(keysv)
3727                        || SvROK(keysv)
3728                        || SvIsCOW_shared_hash(keysv));
3729
3730                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
3731
3732                 if (!(actions & MDEREF_FLAG_last)) {
3733                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
3734                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
3735                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3736                     break;
3737                 }
3738
3739                 if (PL_op->op_private &
3740                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
3741                 {
3742                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
3743                         sv = hv_exists_ent((HV*)sv, keysv, 0)
3744                                                 ? &PL_sv_yes : &PL_sv_no;
3745                     }
3746                     else {
3747                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
3748                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
3749                         if (discard)
3750                             return NORMAL;
3751                         if (!sv)
3752                             sv = &PL_sv_undef;
3753                     }
3754                 }
3755                 else {
3756                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3757                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3758                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3759                     bool preeminent = TRUE;
3760                     SV **svp;
3761                     HV * const hv = (HV*)sv;
3762                     HE* he;
3763
3764                     if (UNLIKELY(localizing)) {
3765                         MAGIC *mg;
3766                         HV *stash;
3767
3768                         /* If we can determine whether the element exist,
3769                          * Try to preserve the existenceness of a tied hash
3770                          * element by using EXISTS and DELETE if possible.
3771                          * Fallback to FETCH and STORE otherwise. */
3772                         if (SvCANEXISTDELETE(hv))
3773                             preeminent = hv_exists_ent(hv, keysv, 0);
3774                     }
3775
3776                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
3777                     svp = he ? &HeVAL(he) : NULL;
3778
3779
3780                     if (lval) {
3781                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
3782                             SV* lv;
3783                             SV* key2;
3784                             if (!defer)
3785                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
3786                             lv = sv_newmortal();
3787                             sv_upgrade(lv, SVt_PVLV);
3788                             LvTYPE(lv) = 'y';
3789                             sv_magic(lv, key2 = newSVsv(keysv),
3790                                                 PERL_MAGIC_defelem, NULL, 0);
3791                             /* sv_magic() increments refcount */
3792                             SvREFCNT_dec_NN(key2);
3793                             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
3794                             LvTARGLEN(lv) = 1;
3795                             sv = lv;
3796                         }
3797                         else {
3798                             if (localizing) {
3799                                 if (HvNAME_get(hv) && isGV_or_RVCV(sv))
3800                                     save_gp(MUTABLE_GV(sv),
3801                                         !(PL_op->op_flags & OPf_SPECIAL));
3802                                 else if (preeminent) {
3803                                     save_helem_flags(hv, keysv, svp,
3804                                          (PL_op->op_flags & OPf_SPECIAL)
3805                                             ? 0 : SAVEf_SETMAGIC);
3806                                     sv = *svp; /* may have changed */
3807                                 }
3808                                 else
3809                                     SAVEHDELETE(hv, keysv);
3810                             }
3811                         }
3812                     }
3813                     else {
3814                         sv = (svp && *svp ? *svp : &PL_sv_undef);
3815                         /* see note in pp_helem() */
3816                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
3817                             mg_get(sv);
3818                     }
3819                 }
3820                 goto finish;
3821             }
3822
3823         } /* switch */
3824
3825         actions >>= MDEREF_SHIFT;
3826     } /* while */
3827     /* NOTREACHED */
3828 }
3829
3830
3831 PP(pp_iter)
3832 {
3833     PERL_CONTEXT *cx;
3834     SV *oldsv;
3835     SV **itersvp;
3836
3837     SV *sv;
3838     AV *av;
3839     IV ix;
3840     IV inc;
3841
3842     cx = CX_CUR();
3843     itersvp = CxITERVAR(cx);
3844     assert(itersvp);
3845
3846     switch (CxTYPE(cx)) {
3847
3848     case CXt_LOOP_LAZYSV: /* string increment */
3849     {
3850         SV* cur = cx->blk_loop.state_u.lazysv.cur;
3851         SV *end = cx->blk_loop.state_u.lazysv.end;
3852         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
3853            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
3854         STRLEN maxlen = 0;
3855         const char *max = SvPV_const(end, maxlen);
3856         if (DO_UTF8(end) && IN_UNI_8_BIT)
3857             maxlen = sv_len_utf8_nomg(end);
3858         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
3859             goto retno;
3860
3861         oldsv = *itersvp;
3862         /* NB: on the first iteration, oldsv will have a ref count of at
3863          * least 2 (one extra from blk_loop.itersave), so the GV or pad
3864          * slot will get localised; on subsequent iterations the RC==1
3865          * optimisation may kick in and the SV will be reused. */
3866          if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3867             /* safe to reuse old SV */
3868             sv_setsv(oldsv, cur);
3869         }
3870         else
3871         {
3872             /* we need a fresh SV every time so that loop body sees a
3873              * completely new SV for closures/references to work as
3874              * they used to */
3875             *itersvp = newSVsv(cur);
3876             SvREFCNT_dec(oldsv);
3877         }
3878         if (strEQ(SvPVX_const(cur), max))
3879             sv_setiv(cur, 0); /* terminate next time */
3880         else
3881             sv_inc(cur);
3882         break;
3883     }
3884
3885     case CXt_LOOP_LAZYIV: /* integer increment */
3886     {
3887         IV cur = cx->blk_loop.state_u.lazyiv.cur;
3888         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
3889             goto retno;
3890
3891         oldsv = *itersvp;
3892         /* see NB comment above */
3893         if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
3894             /* safe to reuse old SV */
3895
3896             if (    (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
3897                  == SVt_IV)
3898             {
3899                 /* Cheap SvIOK_only().
3900                  * Assert that flags which SvIOK_only() would test or
3901                  * clear can't be set, because we're SVt_IV */
3902                 assert(!(SvFLAGS(oldsv) &
3903                     (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
3904                 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
3905                 /* SvIV_set() where sv_any points to head */
3906                 oldsv->sv_u.svu_iv = cur;
3907
3908             }
3909             else
3910                 sv_setiv(oldsv, cur);
3911         }
3912         else
3913         {
3914             /* we need a fresh SV every time so that loop body sees a
3915              * completely new SV for closures/references to work as they
3916              * used to */
3917             *itersvp = newSViv(cur);
3918             SvREFCNT_dec(oldsv);
3919         }
3920
3921         if (UNLIKELY(cur == IV_MAX)) {
3922             /* Handle end of range at IV_MAX */
3923             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
3924         } else
3925             ++cx->blk_loop.state_u.lazyiv.cur;
3926         break;
3927     }
3928
3929     case CXt_LOOP_LIST: /* for (1,2,3) */
3930
3931         assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
3932         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3933         ix = (cx->blk_loop.state_u.stack.ix += inc);
3934         if (UNLIKELY(inc > 0
3935                         ? ix > cx->blk_oldsp
3936                         : ix <= cx->blk_loop.state_u.stack.basesp)
3937         )
3938             goto retno;
3939
3940         sv = PL_stack_base[ix];
3941         av = NULL;
3942         goto loop_ary_common;
3943
3944     case CXt_LOOP_ARY: /* for (@ary) */
3945
3946         av = cx->blk_loop.state_u.ary.ary;
3947         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
3948         ix = (cx->blk_loop.state_u.ary.ix += inc);
3949         if (UNLIKELY(inc > 0
3950                         ? ix > AvFILL(av)
3951                         : ix < 0)
3952         )
3953             goto retno;
3954
3955         if (UNLIKELY(SvRMAGICAL(av))) {
3956             SV * const * const svp = av_fetch(av, ix, FALSE);
3957             sv = svp ? *svp : NULL;
3958         }
3959         else {
3960             sv = AvARRAY(av)[ix];
3961         }
3962
3963       loop_ary_common:
3964
3965         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
3966             SvSetMagicSV(*itersvp, sv);
3967             break;
3968         }
3969
3970         if (LIKELY(sv)) {
3971             if (UNLIKELY(SvIS_FREED(sv))) {
3972                 *itersvp = NULL;
3973                 Perl_croak(aTHX_ "Use of freed value in iteration");
3974             }
3975             if (SvPADTMP(sv)) {
3976                 sv = newSVsv(sv);
3977             }
3978             else {
3979                 SvTEMP_off(sv);
3980                 SvREFCNT_inc_simple_void_NN(sv);
3981             }
3982         }
3983         else if (av) {
3984             sv = newSVavdefelem(av, ix, 0);
3985         }
3986         else
3987             sv = &PL_sv_undef;
3988
3989         oldsv = *itersvp;
3990         *itersvp = sv;
3991         SvREFCNT_dec(oldsv);
3992         break;
3993
3994     default:
3995         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
3996     }
3997
3998     /* Bypass pushing &PL_sv_yes and calling pp_and(); instead
3999      * jump straight to the AND op's op_other */
4000     assert(PL_op->op_next->op_type == OP_AND);
4001     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
4002     return cLOGOPx(PL_op->op_next)->op_other;
4003
4004   retno:
4005     /* Bypass pushing &PL_sv_no and calling pp_and(); instead
4006      * jump straight to the AND op's op_next */
4007     assert(PL_op->op_next->op_type == OP_AND);
4008     assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
4009     /* pp_enteriter should have pre-extended the stack */
4010     EXTEND_SKIP(PL_stack_sp, 1);
4011     /* we only need this for the rare case where the OP_AND isn't
4012      * in void context, e.g. $x = do { for (..) {...} };
4013      * but its cheaper to just push it rather than testing first
4014      */
4015     *++PL_stack_sp = &PL_sv_no;
4016     return PL_op->op_next->op_next;
4017 }
4018
4019
4020 /*
4021 A description of how taint works in pattern matching and substitution.
4022
4023 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
4024 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
4025
4026 While the pattern is being assembled/concatenated and then compiled,
4027 PL_tainted will get set (via TAINT_set) if any component of the pattern
4028 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
4029 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
4030 TAINT_get).  It will also be set if any component of the pattern matches
4031 based on locale-dependent behavior.
4032
4033 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
4034 the pattern is marked as tainted. This means that subsequent usage, such
4035 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
4036 on the new pattern too.
4037
4038 RXf_TAINTED_SEEN is used post-execution by the get magic code
4039 of $1 et al to indicate whether the returned value should be tainted.
4040 It is the responsibility of the caller of the pattern (i.e. pp_match,
4041 pp_subst etc) to set this flag for any other circumstances where $1 needs
4042 to be tainted.
4043
4044 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
4045
4046 There are three possible sources of taint
4047     * the source string
4048     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
4049     * the replacement string (or expression under /e)
4050
4051 There are four destinations of taint and they are affected by the sources
4052 according to the rules below:
4053
4054     * the return value (not including /r):
4055         tainted by the source string and pattern, but only for the
4056         number-of-iterations case; boolean returns aren't tainted;
4057     * the modified string (or modified copy under /r):
4058         tainted by the source string, pattern, and replacement strings;
4059     * $1 et al:
4060         tainted by the pattern, and under 'use re "taint"', by the source
4061         string too;
4062     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
4063         should always be unset before executing subsequent code.
4064
4065 The overall action of pp_subst is:
4066
4067     * at the start, set bits in rxtainted indicating the taint status of
4068         the various sources.
4069
4070     * After each pattern execution, update the SUBST_TAINT_PAT bit in
4071         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
4072         pattern has subsequently become tainted via locale ops.
4073
4074     * If control is being passed to pp_substcont to execute a /e block,
4075         save rxtainted in the CXt_SUBST block, for future use by
4076         pp_substcont.
4077
4078     * Whenever control is being returned to perl code (either by falling
4079         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
4080         use the flag bits in rxtainted to make all the appropriate types of
4081         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
4082         et al will appear tainted.
4083
4084 pp_match is just a simpler version of the above.
4085
4086 */
4087
4088 PP(pp_subst)
4089 {
4090     dSP; dTARG;
4091     PMOP *pm = cPMOP;
4092     PMOP *rpm = pm;
4093     char *s;
4094     char *strend;
4095     const char *c;
4096     STRLEN clen;
4097     SSize_t iters = 0;
4098     SSize_t maxiters;
4099     bool once;
4100     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
4101                         See "how taint works" above */
4102     char *orig;
4103     U8 r_flags;
4104     REGEXP *rx = PM_GETRE(pm);
4105     regexp *prog = ReANY(rx);
4106     STRLEN len;
4107     int force_on_match = 0;
4108     const I32 oldsave = PL_savestack_ix;
4109     STRLEN slen;
4110     bool doutf8 = FALSE; /* whether replacement is in utf8 */
4111 #ifdef PERL_ANY_COW
4112     bool was_cow;
4113 #endif
4114     SV *nsv = NULL;
4115     /* known replacement string? */
4116     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
4117
4118     PERL_ASYNC_CHECK();
4119
4120     if (PL_op->op_flags & OPf_STACKED)
4121         TARG = POPs;
4122     else {
4123         if (ARGTARG)
4124             GETTARGET;
4125         else {
4126             TARG = DEFSV;
4127         }
4128         EXTEND(SP,1);
4129     }
4130
4131     SvGETMAGIC(TARG); /* must come before cow check */
4132 #ifdef PERL_ANY_COW
4133     /* note that a string might get converted to COW during matching */
4134     was_cow = cBOOL(SvIsCOW(TARG));
4135 #endif
4136     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4137 #ifndef PERL_ANY_COW
4138         if (SvIsCOW(TARG))
4139             sv_force_normal_flags(TARG,0);
4140 #endif
4141         if ((SvREADONLY(TARG)
4142                 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
4143                       || SvTYPE(TARG) > SVt_PVLV)
4144                      && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
4145             Perl_croak_no_modify();
4146     }
4147     PUTBACK;
4148
4149     orig = SvPV_nomg(TARG, len);
4150     /* note we don't (yet) force the var into being a string; if we fail
4151      * to match, we leave as-is; on successful match however, we *will*
4152      * coerce into a string, then repeat the match */
4153     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
4154         force_on_match = 1;
4155
4156     /* only replace once? */
4157     once = !(rpm->op_pmflags & PMf_GLOBAL);
4158
4159     /* See "how taint works" above */
4160     if (TAINTING_get) {
4161         rxtainted  = (
4162             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
4163           | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
4164           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
4165           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4166                 ? SUBST_TAINT_BOOLRET : 0));
4167         TAINT_NOT;
4168     }
4169
4170   force_it:
4171     if (!pm || !orig)
4172         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
4173
4174     strend = orig + len;
4175     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
4176     maxiters = 2 * slen + 10;   /* We can match twice at each
4177                                    position, once with zero-length,
4178                                    second time with non-zero. */
4179
4180     /* handle the empty pattern */
4181     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
4182         if (PL_curpm == PL_reg_curpm) {
4183             if (PL_curpm_under) {
4184                 if (PL_curpm_under == PL_reg_curpm) {
4185                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
4186                 } else {
4187                     pm = PL_curpm_under;
4188                 }
4189             }
4190         } else {
4191             pm = PL_curpm;
4192         }
4193         rx = PM_GETRE(pm);
4194         prog = ReANY(rx);
4195     }
4196
4197 #ifdef PERL_SAWAMPERSAND
4198     r_flags = (    RXp_NPARENS(prog)
4199                 || PL_sawampersand
4200                 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
4201                 || (rpm->op_pmflags & PMf_KEEPCOPY)
4202               )
4203           ? REXEC_COPY_STR
4204           : 0;
4205 #else
4206     r_flags = REXEC_COPY_STR;
4207 #endif
4208
4209     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
4210     {
4211         SPAGAIN;
4212         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
4213         LEAVE_SCOPE(oldsave);
4214         RETURN;
4215     }
4216     PL_curpm = pm;
4217
4218     /* known replacement string? */
4219     if (dstr) {
4220         /* replacement needing upgrading? */
4221         if (DO_UTF8(TARG) && !doutf8) {
4222              nsv = sv_newmortal();
4223              SvSetSV(nsv, dstr);
4224              sv_utf8_upgrade(nsv);
4225              c = SvPV_const(nsv, clen);
4226              doutf8 = TRUE;
4227         }
4228         else {
4229             c = SvPV_const(dstr, clen);
4230             doutf8 = DO_UTF8(dstr);
4231         }
4232
4233         if (SvTAINTED(dstr))
4234             rxtainted |= SUBST_TAINT_REPL;
4235     }
4236     else {
4237         c = NULL;
4238         doutf8 = FALSE;
4239     }
4240
4241     /* can do inplace substitution? */
4242     if (c
4243 #ifdef PERL_ANY_COW
4244         && !was_cow
4245 #endif
4246         && (I32)clen <= RXp_MINLENRET(prog)
4247         && (  once
4248            || !(r_flags & REXEC_COPY_STR)
4249            || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
4250            )
4251         && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
4252         && (!doutf8 || SvUTF8(TARG))
4253         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
4254     {
4255
4256 #ifdef PERL_ANY_COW
4257         /* string might have got converted to COW since we set was_cow */
4258         if (SvIsCOW(TARG)) {
4259           if (!force_on_match)
4260             goto have_a_cow;
4261           assert(SvVOK(TARG));
4262         }
4263 #endif
4264         if (force_on_match) {
4265             /* redo the first match, this time with the orig var
4266              * forced into being a string */
4267             force_on_match = 0;
4268             orig = SvPV_force_nomg(TARG, len);
4269             goto force_it;
4270         }
4271
4272         if (once) {
4273             char *d, *m;
4274             if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4275                 rxtainted |= SUBST_TAINT_PAT;
4276             m = orig + RXp_OFFS(prog)[0].start;
4277             d = orig + RXp_OFFS(prog)[0].end;
4278             s = orig;
4279             if (m - s > strend - d) {  /* faster to shorten from end */
4280                 I32 i;
4281                 if (clen) {
4282                     Copy(c, m, clen, char);
4283                     m += clen;
4284                 }
4285                 i = strend - d;
4286                 if (i > 0) {
4287                     Move(d, m, i, char);
4288                     m += i;
4289                 }
4290                 *m = '\0';
4291                 SvCUR_set(TARG, m - s);
4292             }
4293             else {      /* faster from front */
4294                 I32 i = m - s;
4295                 d -= clen;
4296                 if (i > 0)
4297                     Move(s, d - i, i, char);
4298                 sv_chop(TARG, d-i);
4299                 if (clen)
4300                     Copy(c, d, clen, char);
4301             }
4302             SPAGAIN;
4303             PUSHs(&PL_sv_yes);
4304         }
4305         else {
4306             char *d, *m;
4307             d = s = RXp_OFFS(prog)[0].start + orig;
4308             do {
4309                 I32 i;
4310                 if (UNLIKELY(iters++ > maxiters))
4311                     DIE(aTHX_ "Substitution loop");
4312                 /* run time pattern taint, eg locale */
4313                 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4314                     rxtainted |= SUBST_TAINT_PAT;
4315                 m = RXp_OFFS(prog)[0].start + orig;
4316                 if ((i = m - s)) {
4317                     if (s != d)
4318                         Move(s, d, i, char);
4319                     d += i;
4320                 }
4321                 if (clen) {
4322                     Copy(c, d, clen, char);
4323                     d += clen;
4324                 }
4325                 s = RXp_OFFS(prog)[0].end + orig;
4326             } while (CALLREGEXEC(rx, s, strend, orig,
4327                                  s == m, /* don't match same null twice */
4328                                  TARG, NULL,
4329                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4330             if (s != d) {
4331                 I32 i = strend - s;
4332                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
4333                 Move(s, d, i+1, char);          /* include the NUL */
4334             }
4335             SPAGAIN;
4336             if (PL_op->op_private & OPpTRUEBOOL)
4337                 PUSHs(iters ? &PL_sv_yes : &PL_sv_zero);
4338             else
4339                 mPUSHi(iters);
4340         }
4341     }
4342     else {
4343         bool first;
4344         char *m;
4345         SV *repl;
4346         if (force_on_match) {
4347             /* redo the first match, this time with the orig var
4348              * forced into being a string */
4349             force_on_match = 0;
4350             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4351                 /* I feel that it should be possible to avoid this mortal copy
4352                    given that the code below copies into a new destination.
4353                    However, I suspect it isn't worth the complexity of
4354                    unravelling the C<goto force_it> for the small number of
4355                    cases where it would be viable to drop into the copy code. */
4356                 TARG = sv_2mortal(newSVsv(TARG));
4357             }
4358             orig = SvPV_force_nomg(TARG, len);
4359             goto force_it;
4360         }
4361 #ifdef PERL_ANY_COW
4362       have_a_cow:
4363 #endif
4364         if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
4365             rxtainted |= SUBST_TAINT_PAT;
4366         repl = dstr;
4367         s = RXp_OFFS(prog)[0].start + orig;
4368         dstr = newSVpvn_flags(orig, s-orig,
4369                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
4370         if (!c) {
4371             PERL_CONTEXT *cx;
4372             SPAGAIN;
4373             m = orig;
4374             /* note that a whole bunch of local vars are saved here for
4375              * use by pp_substcont: here's a list of them in case you're
4376              * searching for places in this sub that uses a particular var:
4377              * iters maxiters r_flags oldsave rxtainted orig dstr targ
4378              * s m strend rx once */
4379             CX_PUSHSUBST(cx);
4380             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
4381         }
4382         first = TRUE;
4383         do {
4384             if (UNLIKELY(iters++ > maxiters))
4385                 DIE(aTHX_ "Substitution loop");
4386             if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
4387                 rxtainted |= SUBST_TAINT_PAT;
4388             if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
4389                 char *old_s    = s;
4390                 char *old_orig = orig;
4391                 assert(RXp_SUBOFFSET(prog) == 0);
4392
4393                 orig = RXp_SUBBEG(prog);
4394                 s = orig + (old_s - old_orig);
4395                 strend = s + (strend - old_s);
4396             }
4397             m = RXp_OFFS(prog)[0].start + orig;
4398             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
4399             s = RXp_OFFS(prog)[0].end + orig;
4400             if (first) {
4401                 /* replacement already stringified */
4402               if (clen)
4403                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
4404               first = FALSE;
4405             }
4406             else {
4407                 sv_catsv(dstr, repl);
4408                 if (UNLIKELY(SvTAINTED(repl)))
4409                     rxtainted |= SUBST_TAINT_REPL;
4410             }
4411             if (once)
4412                 break;
4413         } while (CALLREGEXEC(rx, s, strend, orig,
4414                              s == m,    /* Yields minend of 0 or 1 */
4415                              TARG, NULL,
4416                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
4417         assert(strend >= s);
4418         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
4419
4420         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
4421             /* From here on down we're using the copy, and leaving the original
4422                untouched.  */
4423             TARG = dstr;
4424             SPAGAIN;
4425             PUSHs(dstr);
4426         } else {
4427 #ifdef PERL_ANY_COW
4428             /* The match may make the string COW. If so, brilliant, because
4429                that's just saved us one malloc, copy and free - the regexp has
4430                donated the old buffer, and we malloc an entirely new one, rather
4431                than the regexp malloc()ing a buffer and copying our original,
4432                only for us to throw it away here during the substitution.  */
4433             if (SvIsCOW(TARG)) {
4434                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
4435             } else
4436 #endif
4437             {
4438                 SvPV_free(TARG);
4439             }
4440             SvPV_set(TARG, SvPVX(dstr));
4441             SvCUR_set(TARG, SvCUR(dstr));
4442             SvLEN_set(TARG, SvLEN(dstr));
4443             SvFLAGS(TARG) |= SvUTF8(dstr);
4444             SvPV_set(dstr, NULL);
4445
4446             SPAGAIN;
4447             mPUSHi(iters);
4448         }
4449     }
4450
4451     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
4452         (void)SvPOK_only_UTF8(TARG);
4453     }
4454
4455     /* See "how taint works" above */
4456     if (TAINTING_get) {
4457         if ((rxtainted & SUBST_TAINT_PAT) ||
4458             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
4459                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
4460         )
4461             (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
4462
4463         if (!(rxtainted & SUBST_TAINT_BOOLRET)
4464             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
4465         )
4466             SvTAINTED_on(TOPs);  /* taint return value */
4467         else
4468             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
4469
4470         /* needed for mg_set below */
4471         TAINT_set(
4472           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
4473         );
4474         SvTAINT(TARG);
4475     }
4476     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
4477     TAINT_NOT;
4478     LEAVE_SCOPE(oldsave);
4479     RETURN;
4480 }
4481
4482 PP(pp_grepwhile)
4483 {
4484     dSP;
4485     dPOPss;
4486
4487     if (SvTRUE_NN(sv))
4488         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
4489     ++*PL_markstack_ptr;
4490     FREETMPS;
4491     LEAVE_with_name("grep_item");                                       /* exit inner scope */
4492
4493     /* All done yet? */
4494     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
4495         I32 items;
4496         const U8 gimme = GIMME_V;
4497
4498         LEAVE_with_name("grep");                                        /* exit outer scope */
4499         (void)POPMARK;                          /* pop src */
4500         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
4501         (void)POPMARK;                          /* pop dst */
4502         SP = PL_stack_base + POPMARK;           /* pop original mark */
4503         if (gimme == G_SCALAR) {
4504             if (PL_op->op_private & OPpTRUEBOOL)
4505                 PUSHs(items ? &PL_sv_yes : &PL_sv_zero);
4506             else {
4507                 dTARGET;
4508                 PUSHi(items);
4509             }
4510         }
4511         else if (gimme == G_ARRAY)
4512             SP += items;
4513         RETURN;
4514     }
4515     else {
4516         SV *src;
4517
4518         ENTER_with_name("grep_item");                                   /* enter inner scope */
4519         SAVEVPTR(PL_curpm);
4520
4521         src = PL_stack_base[TOPMARK];
4522         if (SvPADTMP(src)) {
4523             src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
4524             PL_tmps_floor++;
4525         }
4526         SvTEMP_off(src);
4527         DEFSV_set(src);
4528
4529         RETURNOP(cLOGOP->op_other);
4530     }
4531 }
4532
4533 /* leave_adjust_stacks():
4534  *
4535  * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
4536  * positioning them at to_sp+1 onwards, and do the equivalent of a
4537  * FREEMPS and TAINT_NOT.
4538  *
4539  * Not intended to be called in void context.
4540  *
4541  * When leaving a sub, eval, do{} or other scope, the things that need
4542  * doing to process the return args are:
4543  *    * in scalar context, only return the last arg (or PL_sv_undef if none);
4544  *    * for the types of return that return copies of their args (such
4545  *      as rvalue sub return), make a mortal copy of every return arg,
4546  *      except where we can optimise the copy away without it being
4547  *      semantically visible;
4548  *    * make sure that the arg isn't prematurely freed; in the case of an
4549  *      arg not copied, this may involve mortalising it. For example, in
4550  *      C<sub f { my $x = ...; $x }>, $x would be freed when we do
4551  *      CX_LEAVE_SCOPE(cx) unless it's protected or copied.
4552  *
4553  * What condition to use when deciding whether to pass the arg through
4554  * or make a copy, is determined by the 'pass' arg; its valid values are:
4555  *   0: rvalue sub/eval exit
4556  *   1: other rvalue scope exit
4557  *   2: :lvalue sub exit in rvalue context
4558  *   3: :lvalue sub exit in lvalue context and other lvalue scope exits
4559  *
4560  * There is a big issue with doing a FREETMPS. We would like to free any
4561  * temps created by the last statement which the sub executed, rather than
4562  * leaving them for the caller. In a situation where a sub call isn't
4563  * soon followed by a nextstate (e.g. nested recursive calls, a la
4564  * fibonacci()), temps can accumulate, causing memory and performance
4565  * issues.
4566  *
4567  * On the other hand, we don't want to free any TEMPs which are keeping
4568  * alive any return args that we skipped copying; nor do we wish to undo
4569  * any mortalising done here.
4570  *
4571  * The solution is to split the temps stack frame into two, with a cut
4572  * point delineating the two halves. We arrange that by the end of this
4573  * function, all the temps stack frame entries we wish to keep are in the
4574  * range  PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
4575  * the range  tmps_base .. PL_tmps_ix.  During the course of this
4576  * function, tmps_base starts off as PL_tmps_floor+1, then increases
4577  * whenever we find or create a temp that we know should be kept. In
4578  * general the stuff above tmps_base is undecided until we reach the end,
4579  * and we may need a sort stage for that.
4580  *
4581  * To determine whether a TEMP is keeping a return arg alive, every
4582  * arg that is kept rather than copied and which has the SvTEMP flag
4583  * set, has the flag temporarily unset, to mark it. At the end we scan
4584  * the temps stack frame above the cut for entries without SvTEMP and
4585  * keep them, while turning SvTEMP on again. Note that if we die before
4586  * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
4587  * those SVs may be slightly less efficient.
4588  *
4589  * In practice various optimisations for some common cases mean we can
4590  * avoid most of the scanning and swapping about with the temps stack.
4591  */
4592
4593 void
4594 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
4595 {
4596     dVAR;
4597     dSP;
4598     SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
4599     SSize_t nargs;
4600
4601     PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
4602
4603     TAINT_NOT;
4604
4605     if (gimme == G_ARRAY) {
4606         nargs = SP - from_sp;
4607         from_sp++;
4608     }
4609     else {
4610         assert(gimme == G_SCALAR);
4611         if (UNLIKELY(from_sp >= SP)) {
4612             /* no return args */
4613             assert(from_sp == SP);
4614             EXTEND(SP, 1);
4615             *++SP = &PL_sv_undef;
4616             to_sp = SP;
4617             nargs   = 0;
4618         }
4619         else {
4620             from_sp = SP;
4621             nargs   = 1;
4622         }
4623     }
4624
4625     /* common code for G_SCALAR and G_ARRAY */
4626
4627     tmps_base = PL_tmps_floor + 1;
4628
4629     assert(nargs >= 0);
4630     if (nargs) {
4631         /* pointer version of tmps_base. Not safe across temp stack
4632          * reallocs. */
4633         SV **tmps_basep;
4634
4635         EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
4636         tmps_basep = PL_tmps_stack + tmps_base;
4637
4638         /* process each return arg */
4639
4640         do {
4641             SV *sv = *from_sp++;
4642
4643             assert(PL_tmps_ix + nargs < PL_tmps_max);
4644 #ifdef DEBUGGING
4645             /* PADTMPs with container set magic shouldn't appear in the
4646              * wild. This assert is more important for pp_leavesublv(),
4647              * but by testing for it here, we're more likely to catch
4648              * bad cases (what with :lvalue subs not being widely
4649              * deployed). The two issues are that for something like
4650              *     sub :lvalue { $tied{foo} }
4651              * or
4652              *     sub :lvalue { substr($foo,1,2) }
4653              * pp_leavesublv() will croak if the sub returns a PADTMP,
4654              * and currently functions like pp_substr() return a mortal
4655              * rather than using their PADTMP when returning a PVLV.
4656              * This is because the PVLV will hold a ref to $foo,
4657              * so $foo would get delayed in being freed while
4658              * the PADTMP SV remained in the PAD.
4659              * So if this assert fails it means either:
4660              *  1) there is pp code similar to pp_substr that is
4661              *     returning a PADTMP instead of a mortal, and probably
4662              *     needs fixing, or
4663              *  2) pp_leavesublv is making unwarranted assumptions
4664              *     about always croaking on a PADTMP
4665              */
4666             if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
4667                 MAGIC *mg;
4668                 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
4669                     assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
4670                 }
4671             }
4672 #endif
4673
4674             if (
4675                pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
4676              : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
4677              : pass == 2 ? (!SvPADTMP(sv))
4678              : 1)
4679             {
4680                 /* pass through: skip copy for logic or optimisation
4681                  * reasons; instead mortalise it, except that ... */
4682                 *++to_sp = sv;
4683
4684                 if (SvTEMP(sv)) {
4685                     /* ... since this SV is an SvTEMP , we don't need to
4686                      * re-mortalise it; instead we just need to ensure
4687                      * that its existing entry in the temps stack frame
4688                      * ends up below the cut and so avoids being freed
4689                      * this time round. We mark it as needing to be kept
4690                      * by temporarily unsetting SvTEMP; then at the end,
4691                      * we shuffle any !SvTEMP entries on the tmps stack
4692                      * back below the cut.
4693                      * However, there's a significant chance that there's
4694                      * a 1:1 correspondence between the first few (or all)
4695                      * elements in the return args stack frame and those
4696                      * in the temps stack frame; e,g.:
4697                      *      sub f { ....; map {...} .... },
4698                      * or if we're exiting multiple scopes and one of the
4699                      * inner scopes has already made mortal copies of each
4700                      * return arg.
4701                      *
4702                      * If so, this arg sv will correspond to the next item
4703                      * on the tmps stack above the cut, and so can be kept
4704                      * merely by moving the cut boundary up one, rather
4705                      * than messing with SvTEMP.  If all args are 1:1 then
4706                      * we can avoid the sorting stage below completely.
4707                      *
4708                      * If there are no items above the cut on the tmps
4709                      * stack, then the SvTEMP must comne from an item
4710                      * below the cut, so there's nothing to do.
4711                      */
4712                     if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
4713                         if (sv == *tmps_basep)
4714                             tmps_basep++;
4715                         else
4716                             SvTEMP_off(sv);
4717                     }
4718                 }
4719                 else if (!SvPADTMP(sv)) {
4720                     /* mortalise arg to avoid it being freed during save
4721                      * stack unwinding. Pad tmps don't need mortalising as
4722                      * they're never freed. This is the equivalent of
4723                      * sv_2mortal(SvREFCNT_inc(sv)), except that:
4724                      *  * it assumes that the temps stack has already been
4725                      *    extended;
4726                      *  * it puts the new item at the cut rather than at
4727                      *    ++PL_tmps_ix, moving the previous occupant there
4728                      *    instead.
4729                      */
4730                     if (!SvIMMORTAL(sv)) {
4731                         SvREFCNT_inc_simple_void_NN(sv);
4732                         SvTEMP_on(sv);
4733                         /* Note that if there's nothing above the cut,
4734                          * this copies the garbage one slot above
4735                          * PL_tmps_ix onto itself. This is harmless (the
4736                          * stack's already been extended), but might in
4737                          * theory trigger warnings from tools like ASan
4738                          */
4739                         PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
4740                         *tmps_basep++ = sv;
4741                     }
4742                 }
4743             }
4744             else {
4745                 /* Make a mortal copy of the SV.
4746                  * The following code is the equivalent of sv_mortalcopy()
4747                  * except that:
4748                  *  * it assumes the temps stack has already been extended;
4749                  *  * it optimises the copying for some simple SV types;
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                 SV *newsv = newSV(0);
4755
4756                 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
4757                 /* put it on the tmps stack early so it gets freed if we die */
4758                 *tmps_basep++ = newsv;
4759                 *++to_sp = newsv;
4760
4761                 if (SvTYPE(sv) <= SVt_IV) {
4762                     /* arg must be one of undef, IV/UV, or RV: skip
4763                      * sv_setsv_flags() and do the copy directly */
4764                     U32 dstflags;
4765                     U32 srcflags = SvFLAGS(sv);
4766
4767                     assert(!SvGMAGICAL(sv));
4768                     if (srcflags & (SVf_IOK|SVf_ROK)) {
4769                         SET_SVANY_FOR_BODYLESS_IV(newsv);
4770
4771                         if (srcflags & SVf_ROK) {
4772                             newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
4773                             /* SV type plus flags */
4774                             dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
4775                         }
4776                         else {
4777                             /* both src and dst are <= SVt_IV, so sv_any
4778                              * points to the head; so access the heads
4779                              * directly rather than going via sv_any.
4780                              */
4781                             assert(    &(sv->sv_u.svu_iv)
4782                                     == &(((XPVIV*) SvANY(sv))->xiv_iv));
4783                             assert(    &(newsv->sv_u.svu_iv)
4784                                     == &(((XPVIV*) SvANY(newsv))->xiv_iv));
4785                             newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
4786                             /* SV type plus flags */
4787                             dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
4788                                             |(srcflags & SVf_IVisUV));
4789                         }
4790                     }
4791                     else {
4792                         assert(!(srcflags & SVf_OK));
4793                         dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
4794                     }
4795                     SvFLAGS(newsv) = dstflags;
4796
4797                 }
4798                 else {
4799                     /* do the full sv_setsv() */
4800                     SSize_t old_base;
4801
4802                     SvTEMP_on(newsv);
4803                     old_base = tmps_basep - PL_tmps_stack;
4804                     SvGETMAGIC(sv);
4805                     sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
4806                     /* the mg_get or sv_setsv might have created new temps
4807                      * or realloced the tmps stack; regrow and reload */
4808                     EXTEND_MORTAL(nargs);
4809                     tmps_basep = PL_tmps_stack + old_base;
4810                     TAINT_NOT;  /* Each item is independent */
4811                 }
4812
4813             }
4814         } while (--nargs);
4815
4816         /* If there are any temps left above the cut, we need to sort
4817          * them into those to keep and those to free. The only ones to
4818          * keep are those for which we've temporarily unset SvTEMP.
4819          * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
4820          * swapping pairs as necessary. Stop when we meet in the middle.
4821          */
4822         {
4823             SV **top = PL_tmps_stack + PL_tmps_ix;
4824             while (tmps_basep <= top) {
4825                 SV *sv = *top;
4826                 if (SvTEMP(sv))
4827                     top--;
4828                 else {
4829                     SvTEMP_on(sv);
4830                     *top = *tmps_basep;
4831                     *tmps_basep = sv;
4832                     tmps_basep++;
4833                 }
4834             }
4835         }
4836
4837         tmps_base = tmps_basep - PL_tmps_stack;
4838     }
4839
4840     PL_stack_sp = to_sp;
4841
4842     /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
4843     while (PL_tmps_ix >= tmps_base) {
4844         SV* const sv = PL_tmps_stack[PL_tmps_ix--];
4845 #ifdef PERL_POISON
4846         PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
4847 #endif
4848         if (LIKELY(sv)) {
4849             SvTEMP_off(sv);
4850             SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
4851         }
4852     }
4853 }
4854
4855
4856 /* also tail-called by pp_return */
4857
4858 PP(pp_leavesub)
4859 {
4860     U8 gimme;
4861     PERL_CONTEXT *cx;
4862     SV **oldsp;
4863     OP *retop;
4864
4865     cx = CX_CUR();
4866     assert(CxTYPE(cx) == CXt_SUB);
4867
4868     if (CxMULTICALL(cx)) {
4869         /* entry zero of a stack is always PL_sv_undef, which
4870          * simplifies converting a '()' return into undef in scalar context */
4871         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
4872         return 0;
4873     }
4874
4875     gimme = cx->blk_gimme;
4876     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
4877
4878     if (gimme == G_VOID)
4879         PL_stack_sp = oldsp;
4880     else
4881         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4882
4883     CX_LEAVE_SCOPE(cx);
4884     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
4885     cx_popblock(cx);
4886     retop = cx->blk_sub.retop;
4887     CX_POP(cx);
4888
4889     return retop;
4890 }
4891
4892
4893 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
4894  * forces an abandon */
4895
4896 void
4897 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
4898 {
4899     const SSize_t fill = AvFILLp(av);
4900
4901     PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
4902
4903     if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
4904         av_clear(av);
4905         AvREIFY_only(av);
4906     }
4907     else {
4908         AV *newav = newAV();
4909         av_extend(newav, fill);
4910         AvREIFY_only(newav);
4911         PAD_SVl(0) = MUTABLE_SV(newav);
4912         SvREFCNT_dec_NN(av);
4913     }
4914 }
4915
4916
4917 PP(pp_entersub)
4918 {
4919     dSP; dPOPss;
4920     GV *gv;
4921     CV *cv;
4922     PERL_CONTEXT *cx;
4923     I32 old_savestack_ix;
4924
4925     if (UNLIKELY(!sv))
4926         goto do_die;
4927
4928     /* Locate the CV to call:
4929      * - most common case: RV->CV: f(), $ref->():
4930      *   note that if a sub is compiled before its caller is compiled,
4931      *   the stash entry will be a ref to a CV, rather than being a GV.
4932      * - second most common case: CV: $ref->method()
4933      */
4934
4935     /* a non-magic-RV -> CV ? */
4936     if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
4937         cv = MUTABLE_CV(SvRV(sv));
4938         if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
4939             goto do_ref;
4940     }
4941     else
4942         cv = MUTABLE_CV(sv);
4943
4944     /* a CV ? */
4945     if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
4946         /* handle all the weird cases */
4947         switch (SvTYPE(sv)) {
4948         case SVt_PVLV:
4949             if (!isGV_with_GP(sv))
4950                 goto do_default;
4951             /* FALLTHROUGH */
4952         case SVt_PVGV:
4953             cv = GvCVu((const GV *)sv);
4954             if (UNLIKELY(!cv)) {
4955                 HV *stash;
4956                 cv = sv_2cv(sv, &stash, &gv, 0);
4957                 if (!cv) {
4958                     old_savestack_ix = PL_savestack_ix;
4959                     goto try_autoload;
4960                 }
4961             }
4962             break;
4963
4964         default:
4965           do_default:
4966             SvGETMAGIC(sv);
4967             if (SvROK(sv)) {
4968               do_ref:
4969                 if (UNLIKELY(SvAMAGIC(sv))) {
4970                     sv = amagic_deref_call(sv, to_cv_amg);
4971                     /* Don't SPAGAIN here.  */
4972                 }
4973             }
4974             else {
4975                 const char *sym;
4976                 STRLEN len;
4977                 if (UNLIKELY(!SvOK(sv)))
4978                     DIE(aTHX_ PL_no_usym, "a subroutine");
4979
4980                 if (UNLIKELY(sv == &PL_sv_yes)) { /* unfound import, ignore */
4981                     if (PL_op->op_flags & OPf_STACKED) /* hasargs */
4982                         SP = PL_stack_base + POPMARK;
4983                     else
4984                         (void)POPMARK;
4985                     if (GIMME_V == G_SCALAR)
4986                         PUSHs(&PL_sv_undef);
4987                     RETURN;
4988                 }
4989
4990                 sym = SvPV_nomg_const(sv, len);
4991                 if (PL_op->op_private & HINT_STRICT_REFS)
4992                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
4993                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
4994                 break;
4995             }
4996             cv = MUTABLE_CV(SvRV(sv));
4997             if (LIKELY(SvTYPE(cv) == SVt_PVCV))
4998                 break;
4999             /* FALLTHROUGH */
5000         case SVt_PVHV:
5001         case SVt_PVAV:
5002           do_die:
5003             DIE(aTHX_ "Not a CODE reference");
5004         }
5005     }
5006
5007     /* At this point we want to save PL_savestack_ix, either by doing a
5008      * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
5009      * CV we will be using (so we don't know whether its XS, so we can't
5010      * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
5011      * the save stack. So remember where we are currently on the save
5012      * stack, and later update the CX or scopestack entry accordingly. */
5013     old_savestack_ix = PL_savestack_ix;
5014
5015     /* these two fields are in a union. If they ever become separate,
5016      * we have to test for both of them being null below */
5017     assert(cv);
5018     assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
5019     while (UNLIKELY(!CvROOT(cv))) {
5020         GV* autogv;
5021         SV* sub_name;
5022
5023         /* anonymous or undef'd function leaves us no recourse */
5024         if (CvLEXICAL(cv) && CvHASGV(cv))
5025             DIE(aTHX_ "Undefined subroutine &%" SVf " called",
5026                        SVfARG(cv_name(cv, NULL, 0)));
5027         if (CvANON(cv) || !CvHASGV(cv)) {
5028             DIE(aTHX_ "Undefined subroutine called");
5029         }
5030
5031         /* autoloaded stub? */
5032         if (cv != GvCV(gv = CvGV(cv))) {
5033             cv = GvCV(gv);
5034         }
5035         /* should call AUTOLOAD now? */
5036         else {
5037           try_autoload:
5038             autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
5039                                      (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
5040                                     |(PL_op->op_flags & OPf_REF
5041                                        ? GV_AUTOLOAD_ISMETHOD
5042                                        : 0));
5043             cv = autogv ? GvCV(autogv) : NULL;
5044         }
5045         if (!cv) {
5046             sub_name = sv_newmortal();
5047             gv_efullname3(sub_name, gv, NULL);
5048             DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
5049         }
5050     }
5051
5052     /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
5053     if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
5054         DIE(aTHX_ "Closure prototype called");
5055
5056     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
5057             && !CvNODEBUG(cv)))
5058     {
5059          Perl_get_db_sub(aTHX_ &sv, cv);
5060          if (CvISXSUB(cv))
5061              PL_curcopdb = PL_curcop;
5062          if (CvLVALUE(cv)) {
5063              /* check for lsub that handles lvalue subroutines */
5064              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
5065              /* if lsub not found then fall back to DB::sub */
5066              if (!cv) cv = GvCV(PL_DBsub);
5067          } else {
5068              cv = GvCV(PL_DBsub);
5069          }
5070
5071         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
5072             DIE(aTHX_ "No DB::sub routine defined");
5073     }
5074
5075     if (!(CvISXSUB(cv))) {
5076         /* This path taken at least 75% of the time   */
5077         dMARK;
5078         PADLIST *padlist;
5079         I32 depth;
5080         bool hasargs;
5081         U8 gimme;
5082
5083         /* keep PADTMP args alive throughout the call (we need to do this
5084          * because @_ isn't refcounted). Note that we create the mortals
5085          * in the caller's tmps frame, so they won't be freed until after
5086          * we return from the sub.
5087          */
5088         {
5089             SV **svp = MARK;
5090             while (svp < SP) {
5091                 SV *sv = *++svp;
5092                 if (!sv)
5093                     continue;
5094                 if (SvPADTMP(sv))
5095                     *svp = sv = sv_mortalcopy(sv);
5096                 SvTEMP_off(sv);
5097             }
5098         }
5099
5100         gimme = GIMME_V;
5101         cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
5102         hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
5103         cx_pushsub(cx, cv, PL_op->op_next, hasargs);
5104
5105         padlist = CvPADLIST(cv);
5106         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
5107             pad_push(padlist, depth);
5108         PAD_SET_CUR_NOSAVE(padlist, depth);
5109         if (LIKELY(hasargs)) {
5110             AV *const av = MUTABLE_AV(PAD_SVl(0));
5111             SSize_t items;
5112             AV **defavp;
5113
5114             defavp = &GvAV(PL_defgv);
5115             cx->blk_sub.savearray = *defavp;
5116             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
5117
5118             /* it's the responsibility of whoever leaves a sub to ensure
5119              * that a clean, empty AV is left in pad[0]. This is normally
5120              * done by cx_popsub() */
5121             assert(!AvREAL(av) && AvFILLp(av) == -1);
5122
5123             items = SP - MARK;
5124             if (UNLIKELY(items - 1 > AvMAX(av))) {
5125                 SV **ary = AvALLOC(av);
5126                 Renew(ary, items, SV*);
5127                 AvMAX(av) = items - 1;
5128                 AvALLOC(av) = ary;
5129                 AvARRAY(av) = ary;
5130             }
5131
5132             if (items)
5133                 Copy(MARK+1,AvARRAY(av),items,SV*);
5134             AvFILLp(av) = items - 1;
5135         }
5136         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5137             !CvLVALUE(cv)))
5138             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5139                 SVfARG(cv_name(cv, NULL, 0)));
5140         /* warning must come *after* we fully set up the context
5141          * stuff so that __WARN__ handlers can safely dounwind()
5142          * if they want to
5143          */
5144         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
5145                 && ckWARN(WARN_RECURSION)
5146                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
5147             sub_crush_depth(cv);
5148         RETURNOP(CvSTART(cv));
5149     }
5150     else {
5151         SSize_t markix = TOPMARK;
5152         bool is_scalar;
5153
5154         ENTER;
5155         /* pretend we did the ENTER earlier */
5156         PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
5157
5158         SAVETMPS;
5159         PUTBACK;
5160
5161         if (UNLIKELY(((PL_op->op_private
5162                & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
5163              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
5164             !CvLVALUE(cv)))
5165             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
5166                 SVfARG(cv_name(cv, NULL, 0)));
5167
5168         if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
5169             /* Need to copy @_ to stack. Alternative may be to
5170              * switch stack to @_, and copy return values
5171              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
5172             AV * const av = GvAV(PL_defgv);
5173             const SSize_t items = AvFILL(av) + 1;
5174
5175             if (items) {
5176                 SSize_t i = 0;
5177                 const bool m = cBOOL(SvRMAGICAL(av));
5178                 /* Mark is at the end of the stack. */
5179                 EXTEND(SP, items);
5180                 for (; i < items; ++i)
5181                 {
5182                     SV *sv;
5183                     if (m) {
5184                         SV ** const svp = av_fetch(av, i, 0);
5185                         sv = svp ? *svp : NULL;
5186                     }
5187                     else sv = AvARRAY(av)[i];
5188                     if (sv) SP[i+1] = sv;
5189                     else {
5190                         SP[i+1] = newSVavdefelem(av, i, 1);
5191                     }
5192                 }
5193                 SP += items;
5194                 PUTBACK ;
5195             }
5196         }
5197         else {
5198             SV **mark = PL_stack_base + markix;
5199             SSize_t items = SP - mark;
5200             while (items--) {
5201                 mark++;
5202                 if (*mark && SvPADTMP(*mark)) {
5203                     *mark = sv_mortalcopy(*mark);
5204                 }
5205             }
5206         }
5207         /* We assume first XSUB in &DB::sub is the called one. */
5208         if (UNLIKELY(PL_curcopdb)) {
5209             SAVEVPTR(PL_curcop);
5210             PL_curcop = PL_curcopdb;
5211             PL_curcopdb = NULL;
5212         }
5213         /* Do we need to open block here? XXXX */
5214
5215         /* calculate gimme here as PL_op might get changed and then not
5216          * restored until the LEAVE further down */
5217         is_scalar = (GIMME_V == G_SCALAR);
5218
5219         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
5220         assert(CvXSUB(cv));
5221         CvXSUB(cv)(aTHX_ cv);
5222
5223 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5224         /* This duplicates the check done in runops_debug(), but provides more
5225          * information in the common case of the fault being with an XSUB.
5226          *
5227          * It should also catch an XSUB pushing more than it extends
5228          * in scalar context.
5229         */
5230         if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
5231             Perl_croak_nocontext(
5232                 "panic: XSUB %s::%s (%s) failed to extend arg stack: "
5233                 "base=%p, sp=%p, hwm=%p\n",
5234                     HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv),
5235                     PL_stack_base, PL_stack_sp,
5236                     PL_stack_base + PL_curstackinfo->si_stack_hwm);
5237 #endif
5238         /* Enforce some sanity in scalar context. */
5239         if (is_scalar) {
5240             SV **svp = PL_stack_base + markix + 1;
5241             if (svp != PL_stack_sp) {
5242                 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
5243                 PL_stack_sp = svp;
5244             }
5245         }
5246         LEAVE;
5247         return NORMAL;
5248     }
5249 }
5250
5251 void
5252 Perl_sub_crush_depth(pTHX_ CV *cv)
5253 {
5254     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
5255
5256     if (CvANON(cv))
5257         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
5258     else {
5259         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
5260                     SVfARG(cv_name(cv,NULL,0)));
5261     }
5262 }
5263
5264
5265
5266 /* like croak, but report in context of caller */
5267
5268 void
5269 Perl_croak_caller(const char *pat, ...)
5270 {
5271     dTHX;
5272     va_list args;
5273     const PERL_CONTEXT *cx = caller_cx(0, NULL);
5274
5275     /* make error appear at call site */
5276     assert(cx);
5277     PL_curcop = cx->blk_oldcop;
5278
5279     va_start(args, pat);
5280     vcroak(pat, &args);
5281     NOT_REACHED; /* NOTREACHED */
5282     va_end(args);
5283 }
5284
5285
5286 PP(pp_aelem)
5287 {
5288     dSP;
5289     SV** svp;
5290     SV* const elemsv = POPs;
5291     IV elem = SvIV(elemsv);
5292     AV *const av = MUTABLE_AV(POPs);
5293     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
5294     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
5295     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5296     bool preeminent = TRUE;
5297     SV *sv;
5298
5299     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
5300         Perl_warner(aTHX_ packWARN(WARN_MISC),
5301                     "Use of reference \"%" SVf "\" as array index",
5302                     SVfARG(elemsv));
5303     if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
5304         RETPUSHUNDEF;
5305
5306     if (UNLIKELY(localizing)) {
5307         MAGIC *mg;
5308         HV *stash;
5309
5310         /* If we can determine whether the element exist,
5311          * Try to preserve the existenceness of a tied array
5312          * element by using EXISTS and DELETE if possible.
5313          * Fallback to FETCH and STORE otherwise. */
5314         if (SvCANEXISTDELETE(av))
5315             preeminent = av_exists(av, elem);
5316     }
5317
5318     svp = av_fetch(av, elem, lval && !defer);
5319     if (lval) {
5320 #ifdef PERL_MALLOC_WRAP
5321          if (SvUOK(elemsv)) {
5322               const UV uv = SvUV(elemsv);
5323               elem = uv > IV_MAX ? IV_MAX : uv;
5324          }
5325          else if (SvNOK(elemsv))
5326               elem = (IV)SvNV(elemsv);
5327          if (elem > 0) {
5328               static const char oom_array_extend[] =
5329                 "Out of memory during array extend"; /* Duplicated in av.c */
5330               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
5331          }
5332 #endif
5333         if (!svp || !*svp) {
5334             IV len;
5335             if (!defer)
5336                 DIE(aTHX_ PL_no_aelem, elem);
5337             len = av_tindex(av);
5338             mPUSHs(newSVavdefelem(av,
5339             /* Resolve a negative index now, unless it points before the
5340                beginning of the array, in which case record it for error
5341                reporting in magic_setdefelem. */
5342                 elem < 0 && len + elem >= 0 ? len + elem : elem,
5343                 1));
5344             RETURN;
5345         }
5346         if (UNLIKELY(localizing)) {
5347             if (preeminent)
5348                 save_aelem(av, elem, svp);
5349             else
5350                 SAVEADELETE(av, elem);
5351         }
5352         else if (PL_op->op_private & OPpDEREF) {
5353             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
5354             RETURN;
5355         }
5356     }
5357     sv = (svp ? *svp : &PL_sv_undef);
5358     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
5359         mg_get(sv);
5360     PUSHs(sv);
5361     RETURN;
5362 }
5363
5364 SV*
5365 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
5366 {
5367     PERL_ARGS_ASSERT_VIVIFY_REF;
5368
5369     SvGETMAGIC(sv);
5370     if (!SvOK(sv)) {
5371         if (SvREADONLY(sv))
5372             Perl_croak_no_modify();
5373         prepare_SV_for_RV(sv);
5374         switch (to_what) {
5375         case OPpDEREF_SV:
5376             SvRV_set(sv, newSV(0));
5377             break;
5378         case OPpDEREF_AV:
5379             SvRV_set(sv, MUTABLE_SV(newAV()));
5380             break;
5381         case OPpDEREF_HV:
5382             SvRV_set(sv, MUTABLE_SV(newHV()));
5383             break;
5384         }
5385         SvROK_on(sv);
5386         SvSETMAGIC(sv);
5387         SvGETMAGIC(sv);
5388     }
5389     if (SvGMAGICAL(sv)) {
5390         /* copy the sv without magic to prevent magic from being
5391            executed twice */
5392         SV* msv = sv_newmortal();
5393         sv_setsv_nomg(msv, sv);
5394         return msv;
5395     }
5396     return sv;
5397 }
5398
5399 PERL_STATIC_INLINE HV *
5400 S_opmethod_stash(pTHX_ SV* meth)
5401 {
5402     SV* ob;
5403     HV* stash;
5404
5405     SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
5406         ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
5407                             "package or object reference", SVfARG(meth)),
5408            (SV *)NULL)
5409         : *(PL_stack_base + TOPMARK + 1);
5410
5411     PERL_ARGS_ASSERT_OPMETHOD_STASH;
5412
5413     if (UNLIKELY(!sv))
5414        undefined:
5415         Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
5416                    SVfARG(meth));
5417
5418     if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
5419     else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
5420         stash = gv_stashsv(sv, GV_CACHE_ONLY);
5421         if (stash) return stash;
5422     }
5423
5424     if (SvROK(sv))
5425         ob = MUTABLE_SV(SvRV(sv));
5426     else if (!SvOK(sv)) goto undefined;
5427     else if (isGV_with_GP(sv)) {
5428         if (!GvIO(sv))
5429             Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
5430                              "without a package or object reference",
5431                               SVfARG(meth));
5432         ob = sv;
5433         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
5434             assert(!LvTARGLEN(ob));
5435             ob = LvTARG(ob);
5436             assert(ob);
5437         }
5438         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
5439     }
5440     else {
5441         /* this isn't a reference */
5442         GV* iogv;
5443         STRLEN packlen;
5444         const char * const packname = SvPV_nomg_const(sv, packlen);
5445         const U32 packname_utf8 = SvUTF8(sv);
5446         stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
5447         if (stash) return stash;
5448
5449         if (!(iogv = gv_fetchpvn_flags(
5450                 packname, packlen, packname_utf8, SVt_PVIO
5451              )) ||
5452             !(ob=MUTABLE_SV(GvIO(iogv))))
5453         {
5454             /* this isn't the name of a filehandle either */
5455             if (!packlen)
5456             {
5457                 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
5458                                  "without a package or object reference",
5459                                   SVfARG(meth));
5460             }
5461             /* assume it's a package name */
5462             stash = gv_stashpvn(packname, packlen, packname_utf8);
5463             if (stash) return stash;
5464             else return MUTABLE_HV(sv);
5465         }
5466         /* it _is_ a filehandle name -- replace with a reference */
5467         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
5468     }
5469
5470     /* if we got here, ob should be an object or a glob */
5471     if (!ob || !(SvOBJECT(ob)
5472                  || (isGV_with_GP(ob)
5473                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
5474                      && SvOBJECT(ob))))
5475     {
5476         Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
5477                    SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
5478                                         ? newSVpvs_flags("DOES", SVs_TEMP)
5479                                         : meth));
5480     }
5481
5482     return SvSTASH(ob);
5483 }
5484
5485 PP(pp_method)
5486 {
5487     dSP;
5488     GV* gv;
5489     HV* stash;
5490     SV* const meth = TOPs;
5491
5492     if (SvROK(meth)) {
5493         SV* const rmeth = SvRV(meth);
5494         if (SvTYPE(rmeth) == SVt_PVCV) {
5495             SETs(rmeth);
5496             RETURN;
5497         }
5498     }
5499
5500     stash = opmethod_stash(meth);
5501
5502     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
5503     assert(gv);
5504
5505     SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5506     RETURN;
5507 }
5508
5509 #define METHOD_CHECK_CACHE(stash,cache,meth)                            \
5510     const HE* const he = hv_fetch_ent(cache, meth, 0, 0);               \
5511     if (he) {                                                           \
5512         gv = MUTABLE_GV(HeVAL(he));                                     \
5513         if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv)        \
5514              == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))     \
5515         {                                                               \
5516             XPUSHs(MUTABLE_SV(GvCV(gv)));                               \
5517             RETURN;                                                     \
5518         }                                                               \
5519     }                                                                   \
5520
5521 PP(pp_method_named)
5522 {
5523     dSP;
5524     GV* gv;
5525     SV* const meth = cMETHOPx_meth(PL_op);
5526     HV* const stash = opmethod_stash(meth);
5527
5528     if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
5529         METHOD_CHECK_CACHE(stash, stash, meth);
5530     }
5531
5532     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
5533     assert(gv);
5534
5535     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5536     RETURN;
5537 }
5538
5539 PP(pp_method_super)
5540 {
5541     dSP;
5542     GV* gv;
5543     HV* cache;
5544     SV* const meth = cMETHOPx_meth(PL_op);
5545     HV* const stash = CopSTASH(PL_curcop);
5546     /* Actually, SUPER doesn't need real object's (or class') stash at all,
5547      * as it uses CopSTASH. However, we must ensure that object(class) is
5548      * correct (this check is done by S_opmethod_stash) */
5549     opmethod_stash(meth);
5550
5551     if ((cache = HvMROMETA(stash)->super)) {
5552         METHOD_CHECK_CACHE(stash, cache, meth);
5553     }
5554
5555     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
5556     assert(gv);
5557
5558     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5559     RETURN;
5560 }
5561
5562 PP(pp_method_redir)
5563 {
5564     dSP;
5565     GV* gv;
5566     SV* const meth = cMETHOPx_meth(PL_op);
5567     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
5568     opmethod_stash(meth); /* not used but needed for error checks */
5569
5570     if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
5571     else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
5572
5573     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
5574     assert(gv);
5575
5576     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5577     RETURN;
5578 }
5579
5580 PP(pp_method_redir_super)
5581 {
5582     dSP;
5583     GV* gv;
5584     HV* cache;
5585     SV* const meth = cMETHOPx_meth(PL_op);
5586     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
5587     opmethod_stash(meth); /* not used but needed for error checks */
5588
5589     if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
5590     else if ((cache = HvMROMETA(stash)->super)) {
5591          METHOD_CHECK_CACHE(stash, cache, meth);
5592     }
5593
5594     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
5595     assert(gv);
5596
5597     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
5598     RETURN;
5599 }
5600
5601 /*
5602  * ex: set ts=8 sts=4 sw=4 et:
5603  */