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