pp_hot.c

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