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