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