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