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 + cxstack[cxstack_ix].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) {
 134         SV * const temp = left;
 135         left = right; right = temp;
 136     }
 137     if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
 138         TAINT_NOT;
 139     if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
 140         /* *foo =\&bar */
 141         SV * const cv = SvRV(right);
 142         const U32 cv_type = SvTYPE(cv);
 143         const bool is_gv = isGV_with_GP(left);
 144         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 145
 146         if (!got_coderef) {
 147             assert(SvROK(cv));
 148         }
 149
 150         /* Can do the optimisation if left (LVALUE) is not a typeglob,
 151            right (RVALUE) is a reference to something, and we're in void
 152            context. */
 153         if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
 154             /* Is the target symbol table currently empty?  */
 155             GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
 156             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 157                 /* Good. Create a new proxy constant subroutine in the target.
 158                    The gv becomes a(nother) reference to the constant.  */
 159                 SV *const value = SvRV(cv);
 160
 161                 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
 162                 SvPCS_IMPORTED_on(gv);
 163                 SvRV_set(gv, value);
 164                 SvREFCNT_inc_simple_void(value);
 165                 SETs(left);
 166                 RETURN;
 167             }
 168         }
 169
 170         /* Need to fix things up.  */
 171         if (!is_gv) {
 172             /* Need to fix GV.  */
 173             left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
 174         }
 175
 176         if (!got_coderef) {
 177             /* We've been returned a constant rather than a full subroutine,
 178                but they expect a subroutine reference to apply.  */
 179             if (SvROK(cv)) {
 180                 ENTER_with_name("sassign_coderef");
 181                 SvREFCNT_inc_void(SvRV(cv));
 182                 /* newCONSTSUB takes a reference count on the passed in SV
 183                    from us.  We set the name to NULL, otherwise we get into
 184                    all sorts of fun as the reference to our new sub is
 185                    donated to the GV that we're about to assign to.
 186                 */
 187                 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
 188                                                       SvRV(cv))));
 189                 SvREFCNT_dec_NN(cv);
 190                 LEAVE_with_name("sassign_coderef");
 191             } else {
 192                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
 193                    is that
 194                    First:   ops for \&{"BONK"}; return us the constant in the
 195                             symbol table
 196                    Second:  ops for *{"BONK"} cause that symbol table entry
 197                             (and our reference to it) to be upgraded from RV
 198                             to typeblob)
 199                    Thirdly: We get here. cv is actually PVGV now, and its
 200                             GvCV() is actually the subroutine we're looking for
 201
 202                    So change the reference so that it points to the subroutine
 203                    of that typeglob, as that's what they were after all along.
 204                 */
 205                 GV *const upgraded = MUTABLE_GV(cv);
 206                 CV *const source = GvCV(upgraded);
 207
 208                 assert(source);
 209                 assert(CvFLAGS(source) & CVf_CONST);
 210
 211                 SvREFCNT_inc_void(source);
 212                 SvREFCNT_dec_NN(upgraded);
 213                 SvRV_set(right, MUTABLE_SV(source));
 214             }
 215         }
 216
 217     }
 218     if (
 219       UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
 220       (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
 221     )
 222         Perl_warner(aTHX_
 223             packWARN(WARN_MISC), "Useless assignment to a temporary"
 224         );
 225     SvSetMagicSV(left, right);
 226     SETs(left);
 227     RETURN;
 228 }
 229
 230 PP(pp_cond_expr)
 231 {
 232     dSP;
 233     PERL_ASYNC_CHECK();
 234     if (SvTRUEx(POPs))
 235         RETURNOP(cLOGOP->op_other);
 236     else
 237         RETURNOP(cLOGOP->op_next);
 238 }
 239
 240 PP(pp_unstack)
 241 {
 242     PERL_ASYNC_CHECK();
 243     TAINT_NOT;          /* Each statement is presumed innocent */
 244     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 245     FREETMPS;
 246     if (!(PL_op->op_flags & OPf_SPECIAL)) {
 247         I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
 248         LEAVE_SCOPE(oldsave);
 249     }
 250     return NORMAL;
 251 }
 252
 253 PP(pp_concat)
 254 {
 255   dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
 256   {
 257     dPOPTOPssrl;
 258     bool lbyte;
 259     STRLEN rlen;
 260     const char *rpv = NULL;
 261     bool rbyte = FALSE;
 262     bool rcopied = FALSE;
 263
 264     if (TARG == right && right != left) { /* $r = $l.$r */
 265         rpv = SvPV_nomg_const(right, rlen);
 266         rbyte = !DO_UTF8(right);
 267         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 268         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 269         rcopied = TRUE;
 270     }
 271
 272     if (TARG != left) { /* not $l .= $r */
 273         STRLEN llen;
 274         const char* const lpv = SvPV_nomg_const(left, llen);
 275         lbyte = !DO_UTF8(left);
 276         sv_setpvn(TARG, lpv, llen);
 277         if (!lbyte)
 278             SvUTF8_on(TARG);
 279         else
 280             SvUTF8_off(TARG);
 281     }
 282     else { /* $l .= $r   and   left == TARG */
 283         if (!SvOK(left)) {
 284             if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
 285                 report_uninit(right);
 286             sv_setpvs(left, "");
 287         }
 288         else {
 289             SvPV_force_nomg_nolen(left);
 290         }
 291         lbyte = !DO_UTF8(left);
 292         if (IN_BYTES)
 293             SvUTF8_off(left);
 294     }
 295
 296     if (!rcopied) {
 297         rpv = SvPV_nomg_const(right, rlen);
 298         rbyte = !DO_UTF8(right);
 299     }
 300     if (lbyte != rbyte) {
 301         if (lbyte)
 302             sv_utf8_upgrade_nomg(TARG);
 303         else {
 304             if (!rcopied)
 305                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 306             sv_utf8_upgrade_nomg(right);
 307             rpv = SvPV_nomg_const(right, rlen);
 308         }
 309     }
 310     sv_catpvn_nomg(TARG, rpv, rlen);
 311
 312     SETTARG;
 313     RETURN;
 314   }
 315 }
 316
 317 /* push the elements of av onto the stack.
 318  * XXX Note that padav has similar code but without the mg_get().
 319  * I suspect that the mg_get is no longer needed, but while padav
 320  * differs, it can't share this function */
 321
 322 STATIC void
 323 S_pushav(pTHX_ AV* const av)
 324 {
 325     dSP;
 326     const SSize_t maxarg = AvFILL(av) + 1;
 327     EXTEND(SP, maxarg);
 328     if (UNLIKELY(SvRMAGICAL(av))) {
 329         PADOFFSET i;
 330         for (i=0; i < (PADOFFSET)maxarg; i++) {
 331             SV ** const svp = av_fetch(av, i, FALSE);
 332             /* See note in pp_helem, and bug id #27839 */
 333             SP[i+1] = svp
 334                 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
 335                 : &PL_sv_undef;
 336         }
 337     }
 338     else {
 339         PADOFFSET i;
 340         for (i=0; i < (PADOFFSET)maxarg; i++) {
 341             SV * const sv = AvARRAY(av)[i];
 342             SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
 343         }
 344     }
 345     SP += maxarg;
 346     PUTBACK;
 347 }
 348
 349
 350 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
 351
 352 PP(pp_padrange)
 353 {
 354     dSP;
 355     PADOFFSET base = PL_op->op_targ;
 356     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
 357     int i;
 358     if (PL_op->op_flags & OPf_SPECIAL) {
 359         /* fake the RHS of my ($x,$y,..) = @_ */
 360         PUSHMARK(SP);
 361         S_pushav(aTHX_ GvAVn(PL_defgv));
 362         SPAGAIN;
 363     }
 364
 365     /* note, this is only skipped for compile-time-known void cxt */
 366     if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
 367         EXTEND(SP, count);
 368         PUSHMARK(SP);
 369         for (i = 0; i <count; i++)
 370             *++SP = PAD_SV(base+i);
 371     }
 372     if (PL_op->op_private & OPpLVAL_INTRO) {
 373         SV **svp = &(PAD_SVl(base));
 374         const UV payload = (UV)(
 375                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
 376                     | (count << SAVE_TIGHT_SHIFT)
 377                     | SAVEt_CLEARPADRANGE);
 378         STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
 379         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
 380         {
 381             dSS_ADD;
 382             SS_ADD_UV(payload);
 383             SS_ADD_END(1);
 384         }
 385
 386         for (i = 0; i <count; i++)
 387             SvPADSTALE_off(*svp++); /* mark lexical as active */
 388     }
 389     RETURN;
 390 }
 391
 392
 393 PP(pp_padsv)
 394 {
 395     dSP;
 396     EXTEND(SP, 1);
 397     {
 398         OP * const op = PL_op;
 399         /* access PL_curpad once */
 400         SV ** const padentry = &(PAD_SVl(op->op_targ));
 401         {
 402             dTARG;
 403             TARG = *padentry;
 404             PUSHs(TARG);
 405             PUTBACK; /* no pop/push after this, TOPs ok */
 406         }
 407         if (op->op_flags & OPf_MOD) {
 408             if (op->op_private & OPpLVAL_INTRO)
 409                 if (!(op->op_private & OPpPAD_STATE))
 410                     save_clearsv(padentry);
 411             if (op->op_private & OPpDEREF) {
 412                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
 413                    than TARG reduces the scope of TARG, so it does not
 414                    span the call to save_clearsv, resulting in smaller
 415                    machine code. */
 416                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
 417             }
 418         }
 419         return op->op_next;
 420     }
 421 }
 422
 423 PP(pp_readline)
 424 {
 425     dSP;
 426     if (TOPs) {
 427         SvGETMAGIC(TOPs);
 428         tryAMAGICunTARGETlist(iter_amg, 0);
 429         PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
 430     }
 431     else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
 432     if (!isGV_with_GP(PL_last_in_gv)) {
 433         if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
 434             PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
 435         else {
 436             dSP;
 437             XPUSHs(MUTABLE_SV(PL_last_in_gv));
 438             PUTBACK;
 439             Perl_pp_rv2gv(aTHX);
 440             PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
 441             if (PL_last_in_gv == (GV *)&PL_sv_undef)
 442                 PL_last_in_gv = NULL;
 443             else
 444                 assert(isGV_with_GP(PL_last_in_gv));
 445         }
 446     }
 447     return do_readline();
 448 }
 449
 450 PP(pp_eq)
 451 {
 452     dSP;
 453     SV *left, *right;
 454
 455     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
 456     right = POPs;
 457     left  = TOPs;
 458     SETs(boolSV(
 459         (SvIOK_notUV(left) && SvIOK_notUV(right))
 460         ? (SvIVX(left) == SvIVX(right))
 461         : ( do_ncmp(left, right) == 0)
 462     ));
 463     RETURN;
 464 }
 465
 466
 467 /* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
 468
 469 PP(pp_preinc)
 470 {
 471     dSP;
 472     const bool inc =
 473         PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
 474     if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
 475         Perl_croak_no_modify();
 476     if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
 477         && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
 478     {
 479         SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
 480         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 481     }
 482     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 483         if (inc) sv_inc(TOPs);
 484         else sv_dec(TOPs);
 485     SvSETMAGIC(TOPs);
 486     return NORMAL;
 487 }
 488
 489
 490 /* also used for: pp_orassign() */
 491
 492 PP(pp_or)
 493 {
 494     dSP;
 495     PERL_ASYNC_CHECK();
 496     if (SvTRUE(TOPs))
 497         RETURN;
 498     else {
 499         if (PL_op->op_type == OP_OR)
 500             --SP;
 501         RETURNOP(cLOGOP->op_other);
 502     }
 503 }
 504
 505
 506 /* also used for: pp_dor() pp_dorassign() */
 507
 508 PP(pp_defined)
 509 {
 510     dSP;
 511     SV* sv;
 512     bool defined;
 513     const int op_type = PL_op->op_type;
 514     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 515
 516     if (is_dor) {
 517         PERL_ASYNC_CHECK();
 518         sv = TOPs;
 519         if (UNLIKELY(!sv || !SvANY(sv))) {
 520             if (op_type == OP_DOR)
 521                 --SP;
 522             RETURNOP(cLOGOP->op_other);
 523         }
 524     }
 525     else {
 526         /* OP_DEFINED */
 527         sv = POPs;
 528         if (UNLIKELY(!sv || !SvANY(sv)))
 529             RETPUSHNO;
 530     }
 531
 532     defined = FALSE;
 533     switch (SvTYPE(sv)) {
 534     case SVt_PVAV:
 535         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 536             defined = TRUE;
 537         break;
 538     case SVt_PVHV:
 539         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 540             defined = TRUE;
 541         break;
 542     case SVt_PVCV:
 543         if (CvROOT(sv) || CvXSUB(sv))
 544             defined = TRUE;
 545         break;
 546     default:
 547         SvGETMAGIC(sv);
 548         if (SvOK(sv))
 549             defined = TRUE;
 550         break;
 551     }
 552
 553     if (is_dor) {
 554         if(defined)
 555             RETURN;
 556         if(op_type == OP_DOR)
 557             --SP;
 558         RETURNOP(cLOGOP->op_other);
 559     }
 560     /* assuming OP_DEFINED */
 561     if(defined)
 562         RETPUSHYES;
 563     RETPUSHNO;
 564 }
 565
 566 PP(pp_add)
 567 {
 568     dSP; dATARGET; bool useleft; SV *svl, *svr;
 569     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
 570     svr = TOPs;
 571     svl = TOPm1s;
 572
 573     useleft = USE_LEFT(svl);
 574 #ifdef PERL_PRESERVE_IVUV
 575     /* We must see if we can perform the addition with integers if possible,
 576        as the integer code detects overflow while the NV code doesn't.
 577        If either argument hasn't had a numeric conversion yet attempt to get
 578        the IV. It's important to do this now, rather than just assuming that
 579        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 580        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 581        integer in case the second argument is IV=9223372036854775806
 582        We can (now) rely on sv_2iv to do the right thing, only setting the
 583        public IOK flag if the value in the NV (or PV) slot is truly integer.
 584
 585        A side effect is that this also aggressively prefers integer maths over
 586        fp maths for integer values.
 587
 588        How to detect overflow?
 589
 590        C 99 section 6.2.6.1 says
 591
 592        The range of nonnegative values of a signed integer type is a subrange
 593        of the corresponding unsigned integer type, and the representation of
 594        the same value in each type is the same. A computation involving
 595        unsigned operands can never overflow, because a result that cannot be
 596        represented by the resulting unsigned integer type is reduced modulo
 597        the number that is one greater than the largest value that can be
 598        represented by the resulting type.
 599
 600        (the 9th paragraph)
 601
 602        which I read as "unsigned ints wrap."
 603
 604        signed integer overflow seems to be classed as "exception condition"
 605
 606        If an exceptional condition occurs during the evaluation of an
 607        expression (that is, if the result is not mathematically defined or not
 608        in the range of representable values for its type), the behavior is
 609        undefined.
 610
 611        (6.5, the 5th paragraph)
 612
 613        I had assumed that on 2s complement machines signed arithmetic would
 614        wrap, hence coded pp_add and pp_subtract on the assumption that
 615        everything perl builds on would be happy.  After much wailing and
 616        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 617        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 618        unsigned code below is actually shorter than the old code. :-)
 619     */
 620
 621     if (SvIV_please_nomg(svr)) {
 622         /* Unless the left argument is integer in range we are going to have to
 623            use NV maths. Hence only attempt to coerce the right argument if
 624            we know the left is integer.  */
 625         UV auv = 0;
 626         bool auvok = FALSE;
 627         bool a_valid = 0;
 628
 629         if (!useleft) {
 630             auv = 0;
 631             a_valid = auvok = 1;
 632             /* left operand is undef, treat as zero. + 0 is identity,
 633                Could SETi or SETu right now, but space optimise by not adding
 634                lots of code to speed up what is probably a rarish case.  */
 635         } else {
 636             /* Left operand is defined, so is it IV? */
 637             if (SvIV_please_nomg(svl)) {
 638                 if ((auvok = SvUOK(svl)))
 639                     auv = SvUVX(svl);
 640                 else {
 641                     const IV aiv = SvIVX(svl);
 642                     if (aiv >= 0) {
 643                         auv = aiv;
 644                         auvok = 1;      /* Now acting as a sign flag.  */
 645                     } else {
 646                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
 647                     }
 648                 }
 649                 a_valid = 1;
 650             }
 651         }
 652         if (a_valid) {
 653             bool result_good = 0;
 654             UV result;
 655             UV buv;
 656             bool buvok = SvUOK(svr);
 657
 658             if (buvok)
 659                 buv = SvUVX(svr);
 660             else {
 661                 const IV biv = SvIVX(svr);
 662                 if (biv >= 0) {
 663                     buv = biv;
 664                     buvok = 1;
 665                 } else
 666                     buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
 667             }
 668             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 669                else "IV" now, independent of how it came in.
 670                if a, b represents positive, A, B negative, a maps to -A etc
 671                a + b =>  (a + b)
 672                A + b => -(a - b)
 673                a + B =>  (a - b)
 674                A + B => -(a + b)
 675                all UV maths. negate result if A negative.
 676                add if signs same, subtract if signs differ. */
 677
 678             if (auvok ^ buvok) {
 679                 /* Signs differ.  */
 680                 if (auv >= buv) {
 681                     result = auv - buv;
 682                     /* Must get smaller */
 683                     if (result <= auv)
 684                         result_good = 1;
 685                 } else {
 686                     result = buv - auv;
 687                     if (result <= buv) {
 688                         /* result really should be -(auv-buv). as its negation
 689                            of true value, need to swap our result flag  */
 690                         auvok = !auvok;
 691                         result_good = 1;
 692                     }
 693                 }
 694             } else {
 695                 /* Signs same */
 696                 result = auv + buv;
 697                 if (result >= auv)
 698                     result_good = 1;
 699             }
 700             if (result_good) {
 701                 SP--;
 702                 if (auvok)
 703                     SETu( result );
 704                 else {
 705                     /* Negate result */
 706                     if (result <= (UV)IV_MIN)
 707                         SETi(result == (UV)IV_MIN
 708                                 ? IV_MIN : -(IV)result);
 709                     else {
 710                         /* result valid, but out of range for IV.  */
 711                         SETn( -(NV)result );
 712                     }
 713                 }
 714                 RETURN;
 715             } /* Overflow, drop through to NVs.  */
 716         }
 717     }
 718 #endif
 719     {
 720         NV value = SvNV_nomg(svr);
 721         (void)POPs;
 722         if (!useleft) {
 723             /* left operand is undef, treat as zero. + 0.0 is identity. */
 724             SETn(value);
 725             RETURN;
 726         }
 727         SETn( value + SvNV_nomg(svl) );
 728         RETURN;
 729     }
 730 }
 731
 732
 733 /* also used for: pp_aelemfast_lex() */
 734
 735 PP(pp_aelemfast)
 736 {
 737     dSP;
 738     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
 739         ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
 740     const U32 lval = PL_op->op_flags & OPf_MOD;
 741     SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
 742     SV *sv = (svp ? *svp : &PL_sv_undef);
 743
 744     if (UNLIKELY(!svp && lval))
 745         DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
 746
 747     EXTEND(SP, 1);
 748     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
 749         mg_get(sv);
 750     PUSHs(sv);
 751     RETURN;
 752 }
 753
 754 PP(pp_join)
 755 {
 756     dSP; dMARK; dTARGET;
 757     MARK++;
 758     do_join(TARG, *MARK, MARK, SP);
 759     SP = MARK;
 760     SETs(TARG);
 761     RETURN;
 762 }
 763
 764 PP(pp_pushre)
 765 {
 766     dSP;
 767 #ifdef DEBUGGING
 768     /*
 769      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 770      * will be enough to hold an OP*.
 771      */
 772     SV* const sv = sv_newmortal();
 773     sv_upgrade(sv, SVt_PVLV);
 774     LvTYPE(sv) = '/';
 775     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 776     XPUSHs(sv);
 777 #else
 778     XPUSHs(MUTABLE_SV(PL_op));
 779 #endif
 780     RETURN;
 781 }
 782
 783 /* Oversized hot code. */
 784
 785 /* also used for: pp_say() */
 786
 787 PP(pp_print)
 788 {
 789     dSP; dMARK; dORIGMARK;
 790     PerlIO *fp;
 791     MAGIC *mg;
 792     GV * const gv
 793         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
 794     IO *io = GvIO(gv);
 795
 796     if (io
 797         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
 798     {
 799       had_magic:
 800         if (MARK == ORIGMARK) {
 801             /* If using default handle then we need to make space to
 802              * pass object as 1st arg, so move other args up ...
 803              */
 804             MEXTEND(SP, 1);
 805             ++MARK;
 806             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 807             ++SP;
 808         }
 809         return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
 810                                 mg,
 811                                 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
 812                                  | (PL_op->op_type == OP_SAY
 813                                     ? TIED_METHOD_SAY : 0)), sp - mark);
 814     }
 815     if (!io) {
 816         if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
 817             && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
 818             goto had_magic;
 819         report_evil_fh(gv);
 820         SETERRNO(EBADF,RMS_IFI);
 821         goto just_say_no;
 822     }
 823     else if (!(fp = IoOFP(io))) {
 824         if (IoIFP(io))
 825             report_wrongway_fh(gv, '<');
 826         else
 827             report_evil_fh(gv);
 828         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 829         goto just_say_no;
 830     }
 831     else {
 832         SV * const ofs = GvSV(PL_ofsgv); /* $, */
 833         MARK++;
 834         if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
 835             while (MARK <= SP) {
 836                 if (!do_print(*MARK, fp))
 837                     break;
 838                 MARK++;
 839                 if (MARK <= SP) {
 840                     /* don't use 'ofs' here - it may be invalidated by magic callbacks */
 841                     if (!do_print(GvSV(PL_ofsgv), fp)) {
 842                         MARK--;
 843                         break;
 844                     }
 845                 }
 846             }
 847         }
 848         else {
 849             while (MARK <= SP) {
 850                 if (!do_print(*MARK, fp))
 851                     break;
 852                 MARK++;
 853             }
 854         }
 855         if (MARK <= SP)
 856             goto just_say_no;
 857         else {
 858             if (PL_op->op_type == OP_SAY) {
 859                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
 860                     goto just_say_no;
 861             }
 862             else if (PL_ors_sv && SvOK(PL_ors_sv))
 863                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 864                     goto just_say_no;
 865
 866             if (IoFLAGS(io) & IOf_FLUSH)
 867                 if (PerlIO_flush(fp) == EOF)
 868                     goto just_say_no;
 869         }
 870     }
 871     SP = ORIGMARK;
 872     XPUSHs(&PL_sv_yes);
 873     RETURN;
 874
 875   just_say_no:
 876     SP = ORIGMARK;
 877     XPUSHs(&PL_sv_undef);
 878     RETURN;
 879 }
 880
 881
 882 /* also used for: pp_rv2hv() */
 883 /* also called directly by pp_lvavref */
 884
 885 PP(pp_rv2av)
 886 {
 887     dSP; dTOPss;
 888     const I32 gimme = GIMME_V;
 889     static const char an_array[] = "an ARRAY";
 890     static const char a_hash[] = "a HASH";
 891     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
 892                           || PL_op->op_type == OP_LVAVREF;
 893     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 894
 895     SvGETMAGIC(sv);
 896     if (SvROK(sv)) {
 897         if (UNLIKELY(SvAMAGIC(sv))) {
 898             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
 899         }
 900         sv = SvRV(sv);
 901         if (UNLIKELY(SvTYPE(sv) != type))
 902             /* diag_listed_as: Not an ARRAY reference */
 903             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
 904         else if (UNLIKELY(PL_op->op_flags & OPf_MOD
 905                 && PL_op->op_private & OPpLVAL_INTRO))
 906             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 907     }
 908     else if (UNLIKELY(SvTYPE(sv) != type)) {
 909             GV *gv;
 910
 911             if (!isGV_with_GP(sv)) {
 912                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 913                                      type, &sp);
 914                 if (!gv)
 915                     RETURN;
 916             }
 917             else {
 918                 gv = MUTABLE_GV(sv);
 919             }
 920             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
 921             if (PL_op->op_private & OPpLVAL_INTRO)
 922                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
 923     }
 924     if (PL_op->op_flags & OPf_REF) {
 925                 SETs(sv);
 926                 RETURN;
 927     }
 928     else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
 929               const I32 flags = is_lvalue_sub();
 930               if (flags && !(flags & OPpENTERSUB_INARGS)) {
 931                 if (gimme != G_ARRAY)
 932                     goto croak_cant_return;
 933                 SETs(sv);
 934                 RETURN;
 935               }
 936     }
 937
 938     if (is_pp_rv2av) {
 939         AV *const av = MUTABLE_AV(sv);
 940         /* The guts of pp_rv2av  */
 941         if (gimme == G_ARRAY) {
 942             SP--;
 943             PUTBACK;
 944             S_pushav(aTHX_ av);
 945             SPAGAIN;
 946         }
 947         else if (gimme == G_SCALAR) {
 948             dTARGET;
 949             const SSize_t maxarg = AvFILL(av) + 1;
 950             SETi(maxarg);
 951         }
 952     } else {
 953         /* The guts of pp_rv2hv  */
 954         if (gimme == G_ARRAY) { /* array wanted */
 955             *PL_stack_sp = sv;
 956             return Perl_do_kv(aTHX);
 957         }
 958         else if ((PL_op->op_private & OPpTRUEBOOL
 959               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
 960                  && block_gimme() == G_VOID  ))
 961               && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
 962             SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
 963         else if (gimme == G_SCALAR) {
 964             dTARG;
 965             TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
 966             SETTARG;
 967         }
 968     }
 969     RETURN;
 970
 971  croak_cant_return:
 972     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
 973                is_pp_rv2av ? "array" : "hash");
 974     RETURN;
 975 }
 976
 977 STATIC void
 978 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
 979 {
 980     PERL_ARGS_ASSERT_DO_ODDBALL;
 981
 982     if (*oddkey) {
 983         if (ckWARN(WARN_MISC)) {
 984             const char *err;
 985             if (oddkey == firstkey &&
 986                 SvROK(*oddkey) &&
 987                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
 988                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
 989             {
 990                 err = "Reference found where even-sized list expected";
 991             }
 992             else
 993                 err = "Odd number of elements in hash assignment";
 994             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
 995         }
 996
 997     }
 998 }
 999
1000
1001 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
1002  * are common to both the LHS and RHS of an aassign, and replace them
1003  * with copies. All these copies are made before the actual list assign is
1004  * done.
1005  *
1006  * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
1007  * element ($b) to the first LH element ($a), modifies $a; when the
1008  * second assignment is done, the second RH element now has the wrong
1009  * value. So we initially replace the RHS with ($b, mortalcopy($a)).
1010  * Note that we don't need to make a mortal copy of $b.
1011  *
1012  * The algorithm below works by, for every RHS element, mark the
1013  * corresponding LHS target element with SVf_BREAK. Then if the RHS
1014  * element is found with SVf_BREAK set, it means it would have been
1015  * modified, so make a copy.
1016  * Note that by scanning both LHS and RHS in lockstep, we avoid
1017  * unnecessary copies (like $b above) compared with a naive
1018  * "mark all LHS; copy all marked RHS; unmark all LHS".
1019  *
1020  * If the LHS element is a 'my' declaration' and has a refcount of 1, then
1021  * it can't be common and can be skipped.
1022  *
1023  * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
1024  * that we thought we didn't need to call S_aassign_copy_common(), but we
1025  * have anyway for sanity checking. If we find we need to copy, then panic.
1026  */
1027
1028 PERL_STATIC_INLINE void
1029 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
1030         SV **firstrelem, SV **lastrelem
1031 #ifdef DEBUGGING
1032         , bool fake
1033 #endif
1034 )
1035 {
1036     dVAR;
1037     SV **relem;
1038     SV **lelem;
1039     SSize_t lcount = lastlelem - firstlelem + 1;
1040     bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
1041     bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
1042
1043     assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
1044     assert(firstlelem < lastlelem); /* at least 2 LH elements */
1045     assert(firstrelem < lastrelem); /* at least 2 RH elements */
1046
1047
1048     lelem = firstlelem;
1049     /* we never have to copy the first RH element; it can't be corrupted
1050      * by assigning something to the corresponding first LH element.
1051      * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
1052      */
1053     relem = firstrelem + 1;
1054
1055     for (; relem <= lastrelem; relem++) {
1056         SV *svr;
1057
1058         /* mark next LH element */
1059
1060         if (--lcount >= 0) {
1061             SV *svl = *lelem++;
1062
1063             if (UNLIKELY(!svl)) {/* skip AV alias marker */
1064                 assert (lelem <= lastlelem);
1065                 svl = *lelem++;
1066                 lcount--;
1067             }
1068
1069             assert(svl);
1070             if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
1071                 if (!marked)
1072                     return;
1073                 /* this LH element will consume all further args;
1074                  * no need to mark any further LH elements (if any).
1075                  * But we still need to scan any remaining RHS elements;
1076                  * set lcount negative to distinguish from  lcount == 0,
1077                  * so the loop condition continues being true
1078                  */
1079                 lcount = -1;
1080                 lelem--; /* no need to unmark this element */
1081             }
1082             else if (!(do_rc1 && SvREFCNT(svl) == 1) && svl != &PL_sv_undef) {
1083                 assert(!SvIMMORTAL(svl));
1084                 SvFLAGS(svl) |= SVf_BREAK;
1085                 marked = TRUE;
1086             }
1087             else if (!marked) {
1088                 /* don't check RH element if no SVf_BREAK flags set yet */
1089                 if (!lcount)
1090                     break;
1091                 continue;
1092             }
1093         }
1094
1095         /* see if corresponding RH element needs copying */
1096
1097         assert(marked);
1098         svr = *relem;
1099         assert(svr);
1100
1101         if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) {
1102
1103 #ifdef DEBUGGING
1104             if (fake) {
1105                 /* op_dump(PL_op); */
1106                 Perl_croak(aTHX_
1107                     "panic: aassign skipped needed copy of common RH elem %"
1108                         UVuf, (UV)(relem - firstrelem));
1109             }
1110 #endif
1111
1112             TAINT_NOT;  /* Each item is independent */
1113
1114             /* Dear TODO test in t/op/sort.t, I love you.
1115                (It's relying on a panic, not a "semi-panic" from newSVsv()
1116                and then an assertion failure below.)  */
1117             if (UNLIKELY(SvIS_FREED(svr))) {
1118                 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1119                            (void*)svr);
1120             }
1121             /* avoid break flag while copying; otherwise COW etc
1122              * disabled... */
1123             SvFLAGS(svr) &= ~SVf_BREAK;
1124             /* Not newSVsv(), as it does not allow copy-on-write,
1125                resulting in wasteful copies.
1126                Also, we use SV_NOSTEAL in case the SV is used more than
1127                once, e.g.  (...) = (f())[0,0]
1128                Where the same SV appears twice on the RHS without a ref
1129                count bump.  (Although I suspect that the SV won't be
1130                stealable here anyway - DAPM).
1131                */
1132             *relem = sv_mortalcopy_flags(svr,
1133                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1134             /* ... but restore afterwards in case it's needed again,
1135              * e.g. ($a,$b,$c) = (1,$a,$a)
1136              */
1137             SvFLAGS(svr) |= SVf_BREAK;
1138         }
1139
1140         if (!lcount)
1141             break;
1142     }
1143
1144     if (!marked)
1145         return;
1146
1147     /*unmark LHS */
1148
1149     while (lelem > firstlelem) {
1150         SV * const svl = *(--lelem);
1151         if (svl)
1152             SvFLAGS(svl) &= ~SVf_BREAK;
1153     }
1154 }
1155
1156
1157
1158 PP(pp_aassign)
1159 {
1160     dVAR; dSP;
1161     SV **lastlelem = PL_stack_sp;
1162     SV **lastrelem = PL_stack_base + POPMARK;
1163     SV **firstrelem = PL_stack_base + POPMARK + 1;
1164     SV **firstlelem = lastrelem + 1;
1165
1166     SV **relem;
1167     SV **lelem;
1168
1169     SV *sv;
1170     AV *ary;
1171
1172     I32 gimme;
1173     HV *hash;
1174     SSize_t i;
1175     int magic;
1176     U32 lval;
1177 #ifdef DEBUGGING
1178     bool fake = 0;
1179 #endif
1180
1181     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1182
1183     /* If there's a common identifier on both sides we have to take
1184      * special care that assigning the identifier on the left doesn't
1185      * clobber a value on the right that's used later in the list.
1186      */
1187
1188     if ( (PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1))
1189         /* at least 2 LH and RH elements, or commonality isn't an issue */
1190         && (firstlelem < lastlelem && firstrelem < lastrelem)
1191     ) {
1192         if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1193             /* skip the scan if all scalars have a ref count of 1 */
1194             for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1195                 sv = *lelem;
1196                 if (!sv || SvREFCNT(sv) == 1)
1197                     continue;
1198                 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1199                     goto do_scan;
1200                 break;
1201             }
1202         }
1203         else {
1204           do_scan:
1205             S_aassign_copy_common(aTHX_
1206                         firstlelem, lastlelem, firstrelem, lastrelem
1207 #ifdef DEBUGGING
1208                         , fake
1209 #endif
1210             );
1211         }
1212     }
1213 #ifdef DEBUGGING
1214     else {
1215         /* on debugging builds, do the scan even if we've concluded we
1216          * don't need to, then panic if we find commonality. Note that the
1217          * scanner assumes at least 2 elements */
1218         if (firstlelem < lastlelem && firstrelem < lastrelem) {
1219             fake = 1;
1220             goto do_scan;
1221         }
1222     }
1223 #endif
1224
1225     gimme = GIMME_V;
1226     lval = (gimme == G_ARRAY) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1227
1228     relem = firstrelem;
1229     lelem = firstlelem;
1230     ary = NULL;
1231     hash = NULL;
1232
1233     while (LIKELY(lelem <= lastlelem)) {
1234         bool alias = FALSE;
1235         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1236         sv = *lelem++;
1237         if (UNLIKELY(!sv)) {
1238             alias = TRUE;
1239             sv = *lelem++;
1240             ASSUME(SvTYPE(sv) == SVt_PVAV);
1241         }
1242         switch (SvTYPE(sv)) {
1243         case SVt_PVAV: {
1244             bool already_copied = FALSE;
1245             ary = MUTABLE_AV(sv);
1246             magic = SvMAGICAL(ary) != 0;
1247             ENTER;
1248             SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1249
1250             /* We need to clear ary. The is a danger that if we do this,
1251              * elements on the RHS may be prematurely freed, e.g.
1252              *   @a = ($a[0]);
1253              * In the case of possible commonality, make a copy of each
1254              * RHS SV *before* clearing the array, and add a reference
1255              * from the tmps stack, so that it doesn't leak on death.
1256              * Otherwise, make a copy of each RHS SV only as we're storing
1257              * it into the array - that way we don't have to worry about
1258              * it being leaked if we die, but don't incur the cost of
1259              * mortalising everything.
1260              */
1261
1262             if (   (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1263                 && (relem <= lastrelem)
1264                 && (magic || AvFILL(ary) != -1))
1265             {
1266                 SV **svp;
1267                 EXTEND_MORTAL(lastrelem - relem + 1);
1268                 for (svp = relem; svp <= lastrelem; svp++) {
1269                     /* see comment in S_aassign_copy_common about SV_NOSTEAL */
1270                     *svp = sv_mortalcopy_flags(*svp,
1271                             SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1272                     TAINT_NOT;
1273                 }
1274                 already_copied = TRUE;
1275             }
1276
1277             av_clear(ary);
1278             av_extend(ary, lastrelem - relem);
1279             i = 0;
1280             while (relem <= lastrelem) {        /* gobble up all the rest */
1281                 SV **didstore;
1282                 if (LIKELY(!alias)) {
1283                     if (already_copied)
1284                         sv = *relem;
1285                     else {
1286                         if (LIKELY(*relem))
1287                             /* before newSV, in case it dies */
1288                             SvGETMAGIC(*relem);
1289                         sv = newSV(0);
1290                         /* see comment in S_aassign_copy_common about
1291                          * SV_NOSTEAL */
1292                         sv_setsv_flags(sv, *relem,
1293                                     (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1294                         *relem = sv;
1295                     }
1296                 }
1297                 else {
1298                     if (!already_copied)
1299                         SvGETMAGIC(*relem);
1300                     if (!SvROK(*relem))
1301                         DIE(aTHX_ "Assigned value is not a reference");
1302                     if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1303                    /* diag_listed_as: Assigned value is not %s reference */
1304                         DIE(aTHX_
1305                            "Assigned value is not a SCALAR reference");
1306                     if (lval && !already_copied)
1307                         *relem = sv_mortalcopy(*relem);
1308                     /* XXX else check for weak refs?  */
1309                     sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1310                 }
1311                 relem++;
1312                 if (already_copied)
1313                     SvREFCNT_inc_simple_NN(sv); /* undo mortal free */
1314                 didstore = av_store(ary,i++,sv);
1315                 if (magic) {
1316                     if (!didstore)
1317                         sv_2mortal(sv);
1318                     if (SvSMAGICAL(sv))
1319                         mg_set(sv);
1320                 }
1321                 TAINT_NOT;
1322             }
1323             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1324                 SvSETMAGIC(MUTABLE_SV(ary));
1325             LEAVE;
1326             break;
1327         }
1328
1329         case SVt_PVHV: {                                /* normal hash */
1330                 SV *tmpstr;
1331                 int odd;
1332                 int duplicates = 0;
1333                 SV** topelem = relem;
1334                 SV **firsthashrelem = relem;
1335                 bool already_copied = FALSE;
1336
1337                 hash = MUTABLE_HV(sv);
1338                 magic = SvMAGICAL(hash) != 0;
1339
1340                 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1341                 if (UNLIKELY(odd)) {
1342                     do_oddball(lastrelem, firsthashrelem);
1343                     /* we have firstlelem to reuse, it's not needed anymore
1344                      */
1345                     *(lastrelem+1) = &PL_sv_undef;
1346                 }
1347
1348                 ENTER;
1349                 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1350
1351                 /* We need to clear hash. The is a danger that if we do this,
1352                  * elements on the RHS may be prematurely freed, e.g.
1353                  *   %h = (foo => $h{bar});
1354                  * In the case of possible commonality, make a copy of each
1355                  * RHS SV *before* clearing the hash, and add a reference
1356                  * from the tmps stack, so that it doesn't leak on death.
1357                  */
1358
1359                 if (   (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1360                     && (relem <= lastrelem)
1361                     && (magic || HvUSEDKEYS(hash)))
1362                 {
1363                     SV **svp;
1364                     EXTEND_MORTAL(lastrelem - relem + 1);
1365                     for (svp = relem; svp <= lastrelem; svp++) {
1366                         *svp = sv_mortalcopy_flags(*svp,
1367                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1368                         TAINT_NOT;
1369                     }
1370                     already_copied = TRUE;
1371                 }
1372
1373                 hv_clear(hash);
1374
1375                 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1376                     HE *didstore;
1377                     assert(*relem);
1378                     /* Copy the key if aassign is called in lvalue context,
1379                        to avoid having the next op modify our rhs.  Copy
1380                        it also if it is gmagical, lest it make the
1381                        hv_store_ent call below croak, leaking the value. */
1382                     sv = (lval || SvGMAGICAL(*relem)) && !already_copied
1383                          ? sv_mortalcopy(*relem)
1384                          : *relem;
1385                     relem++;
1386                     assert(*relem);
1387                     if (already_copied)
1388                         tmpstr = *relem++;
1389                     else {
1390                         SvGETMAGIC(*relem);
1391                         tmpstr = newSV(0);
1392                         sv_setsv_nomg(tmpstr,*relem++); /* value */
1393                     }
1394
1395                     if (gimme == G_ARRAY) {
1396                         if (hv_exists_ent(hash, sv, 0))
1397                             /* key overwrites an existing entry */
1398                             duplicates += 2;
1399                         else {
1400                             /* copy element back: possibly to an earlier
1401                              * stack location if we encountered dups earlier,
1402                              * possibly to a later stack location if odd */
1403                             *topelem++ = sv;
1404                             *topelem++ = tmpstr;
1405                         }
1406                     }
1407                     if (already_copied)
1408                         SvREFCNT_inc_simple_NN(tmpstr); /* undo mortal free */
1409                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1410                     if (magic) {
1411                         if (!didstore) sv_2mortal(tmpstr);
1412                         SvSETMAGIC(tmpstr);
1413                     }
1414                     TAINT_NOT;
1415                 }
1416                 LEAVE;
1417                 if (duplicates && gimme == G_ARRAY) {
1418                     /* at this point we have removed the duplicate key/value
1419                      * pairs from the stack, but the remaining values may be
1420                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1421                      * the (a 2), but the stack now probably contains
1422                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1423                      * obliterates the earlier key. So refresh all values. */
1424                     lastrelem -= duplicates;
1425                     relem = firsthashrelem;
1426                     while (relem < lastrelem+odd) {
1427                         HE *he;
1428                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1429                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1430                     }
1431                 }
1432                 if (odd && gimme == G_ARRAY) lastrelem++;
1433             }
1434             break;
1435         default:
1436             if (SvIMMORTAL(sv)) {
1437                 if (relem <= lastrelem)
1438                     relem++;
1439                 break;
1440             }
1441             if (relem <= lastrelem) {
1442                 if (UNLIKELY(
1443                   SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1444                   (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1445                 ))
1446                     Perl_warner(aTHX_
1447                        packWARN(WARN_MISC),
1448                       "Useless assignment to a temporary"
1449                     );
1450                 sv_setsv(sv, *relem);
1451                 *(relem++) = sv;
1452             }
1453             else
1454                 sv_setsv(sv, &PL_sv_undef);
1455             SvSETMAGIC(sv);
1456             break;
1457         }
1458     }
1459     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1460         /* Will be used to set PL_tainting below */
1461         Uid_t tmp_uid  = PerlProc_getuid();
1462         Uid_t tmp_euid = PerlProc_geteuid();
1463         Gid_t tmp_gid  = PerlProc_getgid();
1464         Gid_t tmp_egid = PerlProc_getegid();
1465
1466         /* XXX $> et al currently silently ignore failures */
1467         if (PL_delaymagic & DM_UID) {
1468 #ifdef HAS_SETRESUID
1469             PERL_UNUSED_RESULT(
1470                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1471                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1472                          (Uid_t)-1));
1473 #else
1474 #  ifdef HAS_SETREUID
1475             PERL_UNUSED_RESULT(
1476                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1477                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1478 #  else
1479 #    ifdef HAS_SETRUID
1480             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1481                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1482                 PL_delaymagic &= ~DM_RUID;
1483             }
1484 #    endif /* HAS_SETRUID */
1485 #    ifdef HAS_SETEUID
1486             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1487                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1488                 PL_delaymagic &= ~DM_EUID;
1489             }
1490 #    endif /* HAS_SETEUID */
1491             if (PL_delaymagic & DM_UID) {
1492                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1493                     DIE(aTHX_ "No setreuid available");
1494                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1495             }
1496 #  endif /* HAS_SETREUID */
1497 #endif /* HAS_SETRESUID */
1498
1499             tmp_uid  = PerlProc_getuid();
1500             tmp_euid = PerlProc_geteuid();
1501         }
1502         /* XXX $> et al currently silently ignore failures */
1503         if (PL_delaymagic & DM_GID) {
1504 #ifdef HAS_SETRESGID
1505             PERL_UNUSED_RESULT(
1506                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1507                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1508                           (Gid_t)-1));
1509 #else
1510 #  ifdef HAS_SETREGID
1511             PERL_UNUSED_RESULT(
1512                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1513                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1514 #  else
1515 #    ifdef HAS_SETRGID
1516             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1517                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1518                 PL_delaymagic &= ~DM_RGID;
1519             }
1520 #    endif /* HAS_SETRGID */
1521 #    ifdef HAS_SETEGID
1522             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1523                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1524                 PL_delaymagic &= ~DM_EGID;
1525             }
1526 #    endif /* HAS_SETEGID */
1527             if (PL_delaymagic & DM_GID) {
1528                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1529                     DIE(aTHX_ "No setregid available");
1530                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1531             }
1532 #  endif /* HAS_SETREGID */
1533 #endif /* HAS_SETRESGID */
1534
1535             tmp_gid  = PerlProc_getgid();
1536             tmp_egid = PerlProc_getegid();
1537         }
1538         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1539 #ifdef NO_TAINT_SUPPORT
1540         PERL_UNUSED_VAR(tmp_uid);
1541         PERL_UNUSED_VAR(tmp_euid);
1542         PERL_UNUSED_VAR(tmp_gid);
1543         PERL_UNUSED_VAR(tmp_egid);
1544 #endif
1545     }
1546     PL_delaymagic = 0;
1547
1548     if (gimme == G_VOID)
1549         SP = firstrelem - 1;
1550     else if (gimme == G_SCALAR) {
1551         dTARGET;
1552         SP = firstrelem;
1553         SETi(lastrelem - firstrelem + 1);
1554     }
1555     else {
1556         if (ary || hash)
1557             /* note that in this case *firstlelem may have been overwritten
1558                by sv_undef in the odd hash case */
1559             SP = lastrelem;
1560         else {
1561             SP = firstrelem + (lastlelem - firstlelem);
1562             lelem = firstlelem + (relem - firstrelem);
1563             while (relem <= SP)
1564                 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1565         }
1566     }
1567
1568     RETURN;
1569 }
1570
1571 PP(pp_qr)
1572 {
1573     dSP;
1574     PMOP * const pm = cPMOP;
1575     REGEXP * rx = PM_GETRE(pm);
1576     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1577     SV * const rv = sv_newmortal();
1578     CV **cvp;
1579     CV *cv;
1580
1581     SvUPGRADE(rv, SVt_IV);
1582     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1583        loathe to use it here, but it seems to be the right fix. Or close.
1584        The key part appears to be that it's essential for pp_qr to return a new
1585        object (SV), which implies that there needs to be an effective way to
1586        generate a new SV from the existing SV that is pre-compiled in the
1587        optree.  */
1588     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1589     SvROK_on(rv);
1590
1591     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1592     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1593         *cvp = cv_clone(cv);
1594         SvREFCNT_dec_NN(cv);
1595     }
1596
1597     if (pkg) {
1598         HV *const stash = gv_stashsv(pkg, GV_ADD);
1599         SvREFCNT_dec_NN(pkg);
1600         (void)sv_bless(rv, stash);
1601     }
1602
1603     if (UNLIKELY(RX_ISTAINTED(rx))) {
1604         SvTAINTED_on(rv);
1605         SvTAINTED_on(SvRV(rv));
1606     }
1607     XPUSHs(rv);
1608     RETURN;
1609 }
1610
1611 PP(pp_match)
1612 {
1613     dSP; dTARG;
1614     PMOP *pm = cPMOP;
1615     PMOP *dynpm = pm;
1616     const char *s;
1617     const char *strend;
1618     SSize_t curpos = 0; /* initial pos() or current $+[0] */
1619     I32 global;
1620     U8 r_flags = 0;
1621     const char *truebase;                       /* Start of string  */
1622     REGEXP *rx = PM_GETRE(pm);
1623     bool rxtainted;
1624     const I32 gimme = GIMME_V;
1625     STRLEN len;
1626     const I32 oldsave = PL_savestack_ix;
1627     I32 had_zerolen = 0;
1628     MAGIC *mg = NULL;
1629
1630     if (PL_op->op_flags & OPf_STACKED)
1631         TARG = POPs;
1632     else if (ARGTARG)
1633         GETTARGET;
1634     else {
1635         TARG = DEFSV;
1636         EXTEND(SP,1);
1637     }
1638
1639     PUTBACK;                            /* EVAL blocks need stack_sp. */
1640     /* Skip get-magic if this is a qr// clone, because regcomp has
1641        already done it. */
1642     truebase = ReANY(rx)->mother_re
1643          ? SvPV_nomg_const(TARG, len)
1644          : SvPV_const(TARG, len);
1645     if (!truebase)
1646         DIE(aTHX_ "panic: pp_match");
1647     strend = truebase + len;
1648     rxtainted = (RX_ISTAINTED(rx) ||
1649                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1650     TAINT_NOT;
1651
1652     /* We need to know this in case we fail out early - pos() must be reset */
1653     global = dynpm->op_pmflags & PMf_GLOBAL;
1654
1655     /* PMdf_USED is set after a ?? matches once */
1656     if (
1657 #ifdef USE_ITHREADS
1658         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1659 #else
1660         pm->op_pmflags & PMf_USED
1661 #endif
1662     ) {
1663         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1664         goto nope;
1665     }
1666
1667     /* empty pattern special-cased to use last successful pattern if
1668        possible, except for qr// */
1669     if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1670      && PL_curpm) {
1671         pm = PL_curpm;
1672         rx = PM_GETRE(pm);
1673     }
1674
1675     if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1676         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1677                                               UVuf" < %"IVdf")\n",
1678                                               (UV)len, (IV)RX_MINLEN(rx)));
1679         goto nope;
1680     }
1681
1682     /* get pos() if //g */
1683     if (global) {
1684         mg = mg_find_mglob(TARG);
1685         if (mg && mg->mg_len >= 0) {
1686             curpos = MgBYTEPOS(mg, TARG, truebase, len);
1687             /* last time pos() was set, it was zero-length match */
1688             if (mg->mg_flags & MGf_MINMATCH)
1689                 had_zerolen = 1;
1690         }
1691     }
1692
1693 #ifdef PERL_SAWAMPERSAND
1694     if (       RX_NPARENS(rx)
1695             || PL_sawampersand
1696             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1697             || (dynpm->op_pmflags & PMf_KEEPCOPY)
1698     )
1699 #endif
1700     {
1701         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1702         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1703          * only on the first iteration. Therefore we need to copy $' as well
1704          * as $&, to make the rest of the string available for captures in
1705          * subsequent iterations */
1706         if (! (global && gimme == G_ARRAY))
1707             r_flags |= REXEC_COPY_SKIP_POST;
1708     };
1709 #ifdef PERL_SAWAMPERSAND
1710     if (dynpm->op_pmflags & PMf_KEEPCOPY)
1711         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1712         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1713 #endif
1714
1715     s = truebase;
1716
1717   play_it_again:
1718     if (global)
1719         s = truebase + curpos;
1720
1721     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1722                      had_zerolen, TARG, NULL, r_flags))
1723         goto nope;
1724
1725     PL_curpm = pm;
1726     if (dynpm->op_pmflags & PMf_ONCE)
1727 #ifdef USE_ITHREADS
1728         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1729 #else
1730         dynpm->op_pmflags |= PMf_USED;
1731 #endif
1732
1733     if (rxtainted)
1734         RX_MATCH_TAINTED_on(rx);
1735     TAINT_IF(RX_MATCH_TAINTED(rx));
1736
1737     /* update pos */
1738
1739     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1740         if (!mg)
1741             mg = sv_magicext_mglob(TARG);
1742         MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1743         if (RX_ZERO_LEN(rx))
1744             mg->mg_flags |= MGf_MINMATCH;
1745         else
1746             mg->mg_flags &= ~MGf_MINMATCH;
1747     }
1748
1749     if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1750         LEAVE_SCOPE(oldsave);
1751         RETPUSHYES;
1752     }
1753
1754     /* push captures on stack */
1755
1756     {
1757         const I32 nparens = RX_NPARENS(rx);
1758         I32 i = (global && !nparens) ? 1 : 0;
1759
1760         SPAGAIN;                        /* EVAL blocks could move the stack. */
1761         EXTEND(SP, nparens + i);
1762         EXTEND_MORTAL(nparens + i);
1763         for (i = !i; i <= nparens; i++) {
1764             PUSHs(sv_newmortal());
1765             if (LIKELY((RX_OFFS(rx)[i].start != -1)
1766                      && RX_OFFS(rx)[i].end   != -1 ))
1767             {
1768                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1769                 const char * const s = RX_OFFS(rx)[i].start + truebase;
1770                 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1771                         || len < 0 || len > strend - s))
1772                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1773                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1774                         (long) i, (long) RX_OFFS(rx)[i].start,
1775                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1776                 sv_setpvn(*SP, s, len);
1777                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1778                     SvUTF8_on(*SP);
1779             }
1780         }
1781         if (global) {
1782             curpos = (UV)RX_OFFS(rx)[0].end;
1783             had_zerolen = RX_ZERO_LEN(rx);
1784             PUTBACK;                    /* EVAL blocks may use stack */
1785             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1786             goto play_it_again;
1787         }
1788         LEAVE_SCOPE(oldsave);
1789         RETURN;
1790     }
1791     NOT_REACHED; /* NOTREACHED */
1792
1793   nope:
1794     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1795         if (!mg)
1796             mg = mg_find_mglob(TARG);
1797         if (mg)
1798             mg->mg_len = -1;
1799     }
1800     LEAVE_SCOPE(oldsave);
1801     if (gimme == G_ARRAY)
1802         RETURN;
1803     RETPUSHNO;
1804 }
1805
1806 OP *
1807 Perl_do_readline(pTHX)
1808 {
1809     dSP; dTARGETSTACKED;
1810     SV *sv;
1811     STRLEN tmplen = 0;
1812     STRLEN offset;
1813     PerlIO *fp;
1814     IO * const io = GvIO(PL_last_in_gv);
1815     const I32 type = PL_op->op_type;
1816     const I32 gimme = GIMME_V;
1817
1818     if (io) {
1819         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1820         if (mg) {
1821             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1822             if (gimme == G_SCALAR) {
1823                 SPAGAIN;
1824                 SvSetSV_nosteal(TARG, TOPs);
1825                 SETTARG;
1826             }
1827             return NORMAL;
1828         }
1829     }
1830     fp = NULL;
1831     if (io) {
1832         fp = IoIFP(io);
1833         if (!fp) {
1834             if (IoFLAGS(io) & IOf_ARGV) {
1835                 if (IoFLAGS(io) & IOf_START) {
1836                     IoLINES(io) = 0;
1837                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1838                         IoFLAGS(io) &= ~IOf_START;
1839                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1840                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1841                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1842                         SvSETMAGIC(GvSV(PL_last_in_gv));
1843                         fp = IoIFP(io);
1844                         goto have_fp;
1845                     }
1846                 }
1847                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1848                 if (!fp) { /* Note: fp != IoIFP(io) */
1849                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1850                 }
1851             }
1852             else if (type == OP_GLOB)
1853                 fp = Perl_start_glob(aTHX_ POPs, io);
1854         }
1855         else if (type == OP_GLOB)
1856             SP--;
1857         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1858             report_wrongway_fh(PL_last_in_gv, '>');
1859         }
1860     }
1861     if (!fp) {
1862         if ((!io || !(IoFLAGS(io) & IOf_START))
1863             && ckWARN(WARN_CLOSED)
1864             && type != OP_GLOB)
1865         {
1866             report_evil_fh(PL_last_in_gv);
1867         }
1868         if (gimme == G_SCALAR) {
1869             /* undef TARG, and push that undefined value */
1870             if (type != OP_RCATLINE) {
1871                 sv_setsv(TARG,NULL);
1872             }
1873             PUSHTARG;
1874         }
1875         RETURN;
1876     }
1877   have_fp:
1878     if (gimme == G_SCALAR) {
1879         sv = TARG;
1880         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1881             mg_get(sv);
1882         if (SvROK(sv)) {
1883             if (type == OP_RCATLINE)
1884                 SvPV_force_nomg_nolen(sv);
1885             else
1886                 sv_unref(sv);
1887         }
1888         else if (isGV_with_GP(sv)) {
1889             SvPV_force_nomg_nolen(sv);
1890         }
1891         SvUPGRADE(sv, SVt_PV);
1892         tmplen = SvLEN(sv);     /* remember if already alloced */
1893         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1894             /* try short-buffering it. Please update t/op/readline.t
1895              * if you change the growth length.
1896              */
1897             Sv_Grow(sv, 80);
1898         }
1899         offset = 0;
1900         if (type == OP_RCATLINE && SvOK(sv)) {
1901             if (!SvPOK(sv)) {
1902                 SvPV_force_nomg_nolen(sv);
1903             }
1904             offset = SvCUR(sv);
1905         }
1906     }
1907     else {
1908         sv = sv_2mortal(newSV(80));
1909         offset = 0;
1910     }
1911
1912     /* This should not be marked tainted if the fp is marked clean */
1913 #define MAYBE_TAINT_LINE(io, sv) \
1914     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1915         TAINT;                          \
1916         SvTAINTED_on(sv);               \
1917     }
1918
1919 /* delay EOF state for a snarfed empty file */
1920 #define SNARF_EOF(gimme,rs,io,sv) \
1921     (gimme != G_SCALAR || SvCUR(sv)                                     \
1922      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1923
1924     for (;;) {
1925         PUTBACK;
1926         if (!sv_gets(sv, fp, offset)
1927             && (type == OP_GLOB
1928                 || SNARF_EOF(gimme, PL_rs, io, sv)
1929                 || PerlIO_error(fp)))
1930         {
1931             PerlIO_clearerr(fp);
1932             if (IoFLAGS(io) & IOf_ARGV) {
1933                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1934                 if (fp)
1935                     continue;
1936                 (void)do_close(PL_last_in_gv, FALSE);
1937             }
1938             else if (type == OP_GLOB) {
1939                 if (!do_close(PL_last_in_gv, FALSE)) {
1940                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1941                                    "glob failed (child exited with status %d%s)",
1942                                    (int)(STATUS_CURRENT >> 8),
1943                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1944                 }
1945             }
1946             if (gimme == G_SCALAR) {
1947                 if (type != OP_RCATLINE) {
1948                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1949                     SvOK_off(TARG);
1950                 }
1951                 SPAGAIN;
1952                 PUSHTARG;
1953             }
1954             MAYBE_TAINT_LINE(io, sv);
1955             RETURN;
1956         }
1957         MAYBE_TAINT_LINE(io, sv);
1958         IoLINES(io)++;
1959         IoFLAGS(io) |= IOf_NOLINE;
1960         SvSETMAGIC(sv);
1961         SPAGAIN;
1962         XPUSHs(sv);
1963         if (type == OP_GLOB) {
1964             const char *t1;
1965
1966             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1967                 char * const tmps = SvEND(sv) - 1;
1968                 if (*tmps == *SvPVX_const(PL_rs)) {
1969                     *tmps = '\0';
1970                     SvCUR_set(sv, SvCUR(sv) - 1);
1971                 }
1972             }
1973             for (t1 = SvPVX_const(sv); *t1; t1++)
1974 #ifdef __VMS
1975                 if (strchr("*%?", *t1))
1976 #else
1977                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1978 #endif
1979                         break;
1980             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1981                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1982                 continue;
1983             }
1984         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1985              if (ckWARN(WARN_UTF8)) {
1986                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1987                 const STRLEN len = SvCUR(sv) - offset;
1988                 const U8 *f;
1989
1990                 if (!is_utf8_string_loc(s, len, &f))
1991                     /* Emulate :encoding(utf8) warning in the same case. */
1992                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1993                                 "utf8 \"\\x%02X\" does not map to Unicode",
1994                                 f < (U8*)SvEND(sv) ? *f : 0);
1995              }
1996         }
1997         if (gimme == G_ARRAY) {
1998             if (SvLEN(sv) - SvCUR(sv) > 20) {
1999                 SvPV_shrink_to_cur(sv);
2000             }
2001             sv = sv_2mortal(newSV(80));
2002             continue;
2003         }
2004         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2005             /* try to reclaim a bit of scalar space (only on 1st alloc) */
2006             const STRLEN new_len
2007                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2008             SvPV_renew(sv, new_len);
2009         }
2010         RETURN;
2011     }
2012 }
2013
2014 PP(pp_helem)
2015 {
2016     dSP;
2017     HE* he;
2018     SV **svp;
2019     SV * const keysv = POPs;
2020     HV * const hv = MUTABLE_HV(POPs);
2021     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2022     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2023     SV *sv;
2024     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2025     bool preeminent = TRUE;
2026
2027     if (SvTYPE(hv) != SVt_PVHV)
2028         RETPUSHUNDEF;
2029
2030     if (localizing) {
2031         MAGIC *mg;
2032         HV *stash;
2033
2034         /* If we can determine whether the element exist,
2035          * Try to preserve the existenceness of a tied hash
2036          * element by using EXISTS and DELETE if possible.
2037          * Fallback to FETCH and STORE otherwise. */
2038         if (SvCANEXISTDELETE(hv))
2039             preeminent = hv_exists_ent(hv, keysv, 0);
2040     }
2041
2042     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2043     svp = he ? &HeVAL(he) : NULL;
2044     if (lval) {
2045         if (!svp || !*svp || *svp == &PL_sv_undef) {
2046             SV* lv;
2047             SV* key2;
2048             if (!defer) {
2049                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2050             }
2051             lv = sv_newmortal();
2052             sv_upgrade(lv, SVt_PVLV);
2053             LvTYPE(lv) = 'y';
2054             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2055             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
2056             LvTARG(lv) = SvREFCNT_inc_simple(hv);
2057             LvTARGLEN(lv) = 1;
2058             PUSHs(lv);
2059             RETURN;
2060         }
2061         if (localizing) {
2062             if (HvNAME_get(hv) && isGV(*svp))
2063                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2064             else if (preeminent)
2065                 save_helem_flags(hv, keysv, svp,
2066                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2067             else
2068                 SAVEHDELETE(hv, keysv);
2069         }
2070         else if (PL_op->op_private & OPpDEREF) {
2071             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2072             RETURN;
2073         }
2074     }
2075     sv = (svp && *svp ? *svp : &PL_sv_undef);
2076     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2077      * was to make C<local $tied{foo} = $tied{foo}> possible.
2078      * However, it seems no longer to be needed for that purpose, and
2079      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2080      * would loop endlessly since the pos magic is getting set on the
2081      * mortal copy and lost. However, the copy has the effect of
2082      * triggering the get magic, and losing it altogether made things like
2083      * c<$tied{foo};> in void context no longer do get magic, which some
2084      * code relied on. Also, delayed triggering of magic on @+ and friends
2085      * meant the original regex may be out of scope by now. So as a
2086      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2087      * being called too many times). */
2088     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2089         mg_get(sv);
2090     PUSHs(sv);
2091     RETURN;
2092 }
2093
2094
2095 /* a stripped-down version of Perl_softref2xv() for use by
2096  * pp_multideref(), which doesn't use PL_op->op_flags */
2097
2098 GV *
2099 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2100                 const svtype type)
2101 {
2102     if (PL_op->op_private & HINT_STRICT_REFS) {
2103         if (SvOK(sv))
2104             Perl_die(aTHX_ PL_no_symref_sv, sv,
2105                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2106         else
2107             Perl_die(aTHX_ PL_no_usym, what);
2108     }
2109     if (!SvOK(sv))
2110         Perl_die(aTHX_ PL_no_usym, what);
2111     return gv_fetchsv_nomg(sv, GV_ADD, type);
2112 }
2113
2114
2115 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2116  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
2117  *
2118  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2119  * Each of these either contains a set of actions, or an argument, such as
2120  * an IV to use as an array index, or a lexical var to retrieve.
2121  * Several actions re stored per UV; we keep shifting new actions off the
2122  * one UV, and only reload when it becomes zero.
2123  */
2124
2125 PP(pp_multideref)
2126 {
2127     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2128     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2129     UV actions = items->uv;
2130
2131     assert(actions);
2132     /* this tells find_uninit_var() where we're up to */
2133     PL_multideref_pc = items;
2134
2135     while (1) {
2136         /* there are three main classes of action; the first retrieve
2137          * the initial AV or HV from a variable or the stack; the second
2138          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2139          * the third an unrolled (/DREFHV, rv2hv, helem).
2140          */
2141         switch (actions & MDEREF_ACTION_MASK) {
2142
2143         case MDEREF_reload:
2144             actions = (++items)->uv;
2145             continue;
2146
2147         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
2148             sv = PAD_SVl((++items)->pad_offset);
2149             goto do_AV_aelem;
2150
2151         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
2152             sv = UNOP_AUX_item_sv(++items);
2153             assert(isGV_with_GP(sv));
2154             sv = (SV*)GvAVn((GV*)sv);
2155             goto do_AV_aelem;
2156
2157         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
2158             {
2159                 dSP;
2160                 sv = POPs;
2161                 PUTBACK;
2162                 goto do_AV_rv2av_aelem;
2163             }
2164
2165         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
2166             sv = UNOP_AUX_item_sv(++items);
2167             assert(isGV_with_GP(sv));
2168             sv = GvSVn((GV*)sv);
2169             goto do_AV_vivify_rv2av_aelem;
2170
2171         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
2172             sv = PAD_SVl((++items)->pad_offset);
2173             /* FALLTHROUGH */
2174
2175         do_AV_vivify_rv2av_aelem:
2176         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
2177             /* this is the OPpDEREF action normally found at the end of
2178              * ops like aelem, helem, rv2sv */
2179             sv = vivify_ref(sv, OPpDEREF_AV);
2180             /* FALLTHROUGH */
2181
2182         do_AV_rv2av_aelem:
2183             /* this is basically a copy of pp_rv2av when it just has the
2184              * sKR/1 flags */
2185             SvGETMAGIC(sv);
2186             if (LIKELY(SvROK(sv))) {
2187                 if (UNLIKELY(SvAMAGIC(sv))) {
2188                     sv = amagic_deref_call(sv, to_av_amg);
2189                 }
2190                 sv = SvRV(sv);
2191                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2192                     DIE(aTHX_ "Not an ARRAY reference");
2193             }
2194             else if (SvTYPE(sv) != SVt_PVAV) {
2195                 if (!isGV_with_GP(sv))
2196                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2197                 sv = MUTABLE_SV(GvAVn((GV*)sv));
2198             }
2199             /* FALLTHROUGH */
2200
2201         do_AV_aelem:
2202             {
2203                 /* retrieve the key; this may be either a lexical or package
2204                  * var (whose index/ptr is stored as an item) or a signed
2205                  * integer constant stored as an item.
2206                  */
2207                 SV *elemsv;
2208                 IV elem = 0; /* to shut up stupid compiler warnings */
2209
2210
2211                 assert(SvTYPE(sv) == SVt_PVAV);
2212
2213                 switch (actions & MDEREF_INDEX_MASK) {
2214                 case MDEREF_INDEX_none:
2215                     goto finish;
2216                 case MDEREF_INDEX_const:
2217                     elem  = (++items)->iv;
2218                     break;
2219                 case MDEREF_INDEX_padsv:
2220                     elemsv = PAD_SVl((++items)->pad_offset);
2221                     goto check_elem;
2222                 case MDEREF_INDEX_gvsv:
2223                     elemsv = UNOP_AUX_item_sv(++items);
2224                     assert(isGV_with_GP(elemsv));
2225                     elemsv = GvSVn((GV*)elemsv);
2226                 check_elem:
2227                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2228                                             && ckWARN(WARN_MISC)))
2229                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2230                                 "Use of reference \"%"SVf"\" as array index",
2231                                 SVfARG(elemsv));
2232                     /* the only time that S_find_uninit_var() needs this
2233                      * is to determine which index value triggered the
2234                      * undef warning. So just update it here. Note that
2235                      * since we don't save and restore this var (e.g. for
2236                      * tie or overload execution), its value will be
2237                      * meaningless apart from just here */
2238                     PL_multideref_pc = items;
2239                     elem = SvIV(elemsv);
2240                     break;
2241                 }
2242
2243
2244                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2245
2246                 if (!(actions & MDEREF_FLAG_last)) {
2247                     SV** svp = av_fetch((AV*)sv, elem, 1);
2248                     if (!svp || ! (sv=*svp))
2249                         DIE(aTHX_ PL_no_aelem, elem);
2250                     break;
2251                 }
2252
2253                 if (PL_op->op_private &
2254                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2255                 {
2256                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2257                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2258                     }
2259                     else {
2260                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2261                         sv = av_delete((AV*)sv, elem, discard);
2262                         if (discard)
2263                             return NORMAL;
2264                         if (!sv)
2265                             sv = &PL_sv_undef;
2266                     }
2267                 }
2268                 else {
2269                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2270                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2271                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2272                     bool preeminent = TRUE;
2273                     AV *const av = (AV*)sv;
2274                     SV** svp;
2275
2276                     if (UNLIKELY(localizing)) {
2277                         MAGIC *mg;
2278                         HV *stash;
2279
2280                         /* If we can determine whether the element exist,
2281                          * Try to preserve the existenceness of a tied array
2282                          * element by using EXISTS and DELETE if possible.
2283                          * Fallback to FETCH and STORE otherwise. */
2284                         if (SvCANEXISTDELETE(av))
2285                             preeminent = av_exists(av, elem);
2286                     }
2287
2288                     svp = av_fetch(av, elem, lval && !defer);
2289
2290                     if (lval) {
2291                         if (!svp || !(sv = *svp)) {
2292                             IV len;
2293                             if (!defer)
2294                                 DIE(aTHX_ PL_no_aelem, elem);
2295                             len = av_tindex(av);
2296                             sv = sv_2mortal(newSVavdefelem(av,
2297                             /* Resolve a negative index now, unless it points
2298                              * before the beginning of the array, in which
2299                              * case record it for error reporting in
2300                              * magic_setdefelem. */
2301                                 elem < 0 && len + elem >= 0
2302                                     ? len + elem : elem, 1));
2303                         }
2304                         else {
2305                             if (UNLIKELY(localizing)) {
2306                                 if (preeminent) {
2307                                     save_aelem(av, elem, svp);
2308                                     sv = *svp; /* may have changed */
2309                                 }
2310                                 else
2311                                     SAVEADELETE(av, elem);
2312                             }
2313                         }
2314                     }
2315                     else {
2316                         sv = (svp ? *svp : &PL_sv_undef);
2317                         /* see note in pp_helem() */
2318                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2319                             mg_get(sv);
2320                     }
2321                 }
2322
2323             }
2324           finish:
2325             {
2326                 dSP;
2327                 XPUSHs(sv);
2328                 RETURN;
2329             }
2330             /* NOTREACHED */
2331
2332
2333
2334
2335         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
2336             sv = PAD_SVl((++items)->pad_offset);
2337             goto do_HV_helem;
2338
2339         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
2340             sv = UNOP_AUX_item_sv(++items);
2341             assert(isGV_with_GP(sv));
2342             sv = (SV*)GvHVn((GV*)sv);
2343             goto do_HV_helem;
2344
2345         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
2346             {
2347                 dSP;
2348                 sv = POPs;
2349                 PUTBACK;
2350                 goto do_HV_rv2hv_helem;
2351             }
2352
2353         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
2354             sv = UNOP_AUX_item_sv(++items);
2355             assert(isGV_with_GP(sv));
2356             sv = GvSVn((GV*)sv);
2357             goto do_HV_vivify_rv2hv_helem;
2358
2359         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
2360             sv = PAD_SVl((++items)->pad_offset);
2361             /* FALLTHROUGH */
2362
2363         do_HV_vivify_rv2hv_helem:
2364         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
2365             /* this is the OPpDEREF action normally found at the end of
2366              * ops like aelem, helem, rv2sv */
2367             sv = vivify_ref(sv, OPpDEREF_HV);
2368             /* FALLTHROUGH */
2369
2370         do_HV_rv2hv_helem:
2371             /* this is basically a copy of pp_rv2hv when it just has the
2372              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2373
2374             SvGETMAGIC(sv);
2375             if (LIKELY(SvROK(sv))) {
2376                 if (UNLIKELY(SvAMAGIC(sv))) {
2377                     sv = amagic_deref_call(sv, to_hv_amg);
2378                 }
2379                 sv = SvRV(sv);
2380                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2381                     DIE(aTHX_ "Not a HASH reference");
2382             }
2383             else if (SvTYPE(sv) != SVt_PVHV) {
2384                 if (!isGV_with_GP(sv))
2385                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2386                 sv = MUTABLE_SV(GvHVn((GV*)sv));
2387             }
2388             /* FALLTHROUGH */
2389
2390         do_HV_helem:
2391             {
2392                 /* retrieve the key; this may be either a lexical / package
2393                  * var or a string constant, whose index/ptr is stored as an
2394                  * item
2395                  */
2396                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2397
2398                 assert(SvTYPE(sv) == SVt_PVHV);
2399
2400                 switch (actions & MDEREF_INDEX_MASK) {
2401                 case MDEREF_INDEX_none:
2402                     goto finish;
2403
2404                 case MDEREF_INDEX_const:
2405                     keysv = UNOP_AUX_item_sv(++items);
2406                     break;
2407
2408                 case MDEREF_INDEX_padsv:
2409                     keysv = PAD_SVl((++items)->pad_offset);
2410                     break;
2411
2412                 case MDEREF_INDEX_gvsv:
2413                     keysv = UNOP_AUX_item_sv(++items);
2414                     keysv = GvSVn((GV*)keysv);
2415                     break;
2416                 }
2417
2418                 /* see comment above about setting this var */
2419                 PL_multideref_pc = items;
2420
2421
2422                 /* ensure that candidate CONSTs have been HEKified */
2423                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2424                        || SvTYPE(keysv) >= SVt_PVMG
2425                        || !SvOK(keysv)
2426                        || SvROK(keysv)
2427                        || SvIsCOW_shared_hash(keysv));
2428
2429                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2430
2431                 if (!(actions & MDEREF_FLAG_last)) {
2432                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2433                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2434                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2435                     break;
2436                 }
2437
2438                 if (PL_op->op_private &
2439                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2440                 {
2441                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2442                         sv = hv_exists_ent((HV*)sv, keysv, 0)
2443                                                 ? &PL_sv_yes : &PL_sv_no;
2444                     }
2445                     else {
2446                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2447                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2448                         if (discard)
2449                             return NORMAL;
2450                         if (!sv)
2451                             sv = &PL_sv_undef;
2452                     }
2453                 }
2454                 else {
2455                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2456                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2457                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2458                     bool preeminent = TRUE;
2459                     SV **svp;
2460                     HV * const hv = (HV*)sv;
2461                     HE* he;
2462
2463                     if (UNLIKELY(localizing)) {
2464                         MAGIC *mg;
2465                         HV *stash;
2466
2467                         /* If we can determine whether the element exist,
2468                          * Try to preserve the existenceness of a tied hash
2469                          * element by using EXISTS and DELETE if possible.
2470                          * Fallback to FETCH and STORE otherwise. */
2471                         if (SvCANEXISTDELETE(hv))
2472                             preeminent = hv_exists_ent(hv, keysv, 0);
2473                     }
2474
2475                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2476                     svp = he ? &HeVAL(he) : NULL;
2477
2478
2479                     if (lval) {
2480                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2481                             SV* lv;
2482                             SV* key2;
2483                             if (!defer)
2484                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2485                             lv = sv_newmortal();
2486                             sv_upgrade(lv, SVt_PVLV);
2487                             LvTYPE(lv) = 'y';
2488                             sv_magic(lv, key2 = newSVsv(keysv),
2489                                                 PERL_MAGIC_defelem, NULL, 0);
2490                             /* sv_magic() increments refcount */
2491                             SvREFCNT_dec_NN(key2);
2492                             LvTARG(lv) = SvREFCNT_inc_simple(hv);
2493                             LvTARGLEN(lv) = 1;
2494                             sv = lv;
2495                         }
2496                         else {
2497                             if (localizing) {
2498                                 if (HvNAME_get(hv) && isGV(sv))
2499                                     save_gp(MUTABLE_GV(sv),
2500                                         !(PL_op->op_flags & OPf_SPECIAL));
2501                                 else if (preeminent) {
2502                                     save_helem_flags(hv, keysv, svp,
2503                                          (PL_op->op_flags & OPf_SPECIAL)
2504                                             ? 0 : SAVEf_SETMAGIC);
2505                                     sv = *svp; /* may have changed */
2506                                 }
2507                                 else
2508                                     SAVEHDELETE(hv, keysv);
2509                             }
2510                         }
2511                     }
2512                     else {
2513                         sv = (svp && *svp ? *svp : &PL_sv_undef);
2514                         /* see note in pp_helem() */
2515                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2516                             mg_get(sv);
2517                     }
2518                 }
2519                 goto finish;
2520             }
2521
2522         } /* switch */
2523
2524         actions >>= MDEREF_SHIFT;
2525     } /* while */
2526     /* NOTREACHED */
2527 }
2528
2529
2530 PP(pp_iter)
2531 {
2532     dSP;
2533     PERL_CONTEXT *cx;
2534     SV *oldsv;
2535     SV **itersvp;
2536
2537     EXTEND(SP, 1);
2538     cx = &cxstack[cxstack_ix];
2539     itersvp = CxITERVAR(cx);
2540
2541     switch (CxTYPE(cx)) {
2542
2543     case CXt_LOOP_LAZYSV: /* string increment */
2544     {
2545         SV* cur = cx->blk_loop.state_u.lazysv.cur;
2546         SV *end = cx->blk_loop.state_u.lazysv.end;
2547         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2548            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
2549         STRLEN maxlen = 0;
2550         const char *max = SvPV_const(end, maxlen);
2551         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2552             RETPUSHNO;
2553
2554         oldsv = *itersvp;
2555         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2556             /* safe to reuse old SV */
2557             sv_setsv(oldsv, cur);
2558         }
2559         else
2560         {
2561             /* we need a fresh SV every time so that loop body sees a
2562              * completely new SV for closures/references to work as
2563              * they used to */
2564             *itersvp = newSVsv(cur);
2565             SvREFCNT_dec_NN(oldsv);
2566         }
2567         if (strEQ(SvPVX_const(cur), max))
2568             sv_setiv(cur, 0); /* terminate next time */
2569         else
2570             sv_inc(cur);
2571         break;
2572     }
2573
2574     case CXt_LOOP_LAZYIV: /* integer increment */
2575     {
2576         IV cur = cx->blk_loop.state_u.lazyiv.cur;
2577         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2578             RETPUSHNO;
2579
2580         oldsv = *itersvp;
2581         /* don't risk potential race */
2582         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2583             /* safe to reuse old SV */
2584             sv_setiv(oldsv, cur);
2585         }
2586         else
2587         {
2588             /* we need a fresh SV every time so that loop body sees a
2589              * completely new SV for closures/references to work as they
2590              * used to */
2591             *itersvp = newSViv(cur);
2592             SvREFCNT_dec_NN(oldsv);
2593         }
2594
2595         if (UNLIKELY(cur == IV_MAX)) {
2596             /* Handle end of range at IV_MAX */
2597             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2598         } else
2599             ++cx->blk_loop.state_u.lazyiv.cur;
2600         break;
2601     }
2602
2603     case CXt_LOOP_FOR: /* iterate array */
2604     {
2605
2606         AV *av = cx->blk_loop.state_u.ary.ary;
2607         SV *sv;
2608         bool av_is_stack = FALSE;
2609         IV ix;
2610
2611         if (!av) {
2612             av_is_stack = TRUE;
2613             av = PL_curstack;
2614         }
2615         if (PL_op->op_private & OPpITER_REVERSED) {
2616             ix = --cx->blk_loop.state_u.ary.ix;
2617             if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
2618                 RETPUSHNO;
2619         }
2620         else {
2621             ix = ++cx->blk_loop.state_u.ary.ix;
2622             if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
2623                 RETPUSHNO;
2624         }
2625
2626         if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
2627             SV * const * const svp = av_fetch(av, ix, FALSE);
2628             sv = svp ? *svp : NULL;
2629         }
2630         else {
2631             sv = AvARRAY(av)[ix];
2632         }
2633
2634         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2635             SvSetMagicSV(*itersvp, sv);
2636             break;
2637         }
2638
2639         if (LIKELY(sv)) {
2640             if (UNLIKELY(SvIS_FREED(sv))) {
2641                 *itersvp = NULL;
2642                 Perl_croak(aTHX_ "Use of freed value in iteration");
2643             }
2644             if (SvPADTMP(sv)) {
2645                 sv = newSVsv(sv);
2646             }
2647             else {
2648                 SvTEMP_off(sv);
2649                 SvREFCNT_inc_simple_void_NN(sv);
2650             }
2651         }
2652         else if (!av_is_stack) {
2653             sv = newSVavdefelem(av, ix, 0);
2654         }
2655         else
2656             sv = &PL_sv_undef;
2657
2658         oldsv = *itersvp;
2659         *itersvp = sv;
2660         SvREFCNT_dec(oldsv);
2661         break;
2662     }
2663
2664     default:
2665         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2666     }
2667     RETPUSHYES;
2668 }
2669
2670 /*
2671 A description of how taint works in pattern matching and substitution.
2672
2673 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2674 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2675
2676 While the pattern is being assembled/concatenated and then compiled,
2677 PL_tainted will get set (via TAINT_set) if any component of the pattern
2678 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
2679 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2680 TAINT_get).  It will also be set if any component of the pattern matches
2681 based on locale-dependent behavior.
2682
2683 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2684 the pattern is marked as tainted. This means that subsequent usage, such
2685 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2686 on the new pattern too.
2687
2688 RXf_TAINTED_SEEN is used post-execution by the get magic code
2689 of $1 et al to indicate whether the returned value should be tainted.
2690 It is the responsibility of the caller of the pattern (i.e. pp_match,
2691 pp_subst etc) to set this flag for any other circumstances where $1 needs
2692 to be tainted.
2693
2694 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2695
2696 There are three possible sources of taint
2697     * the source string
2698     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2699     * the replacement string (or expression under /e)
2700
2701 There are four destinations of taint and they are affected by the sources
2702 according to the rules below:
2703
2704     * the return value (not including /r):
2705         tainted by the source string and pattern, but only for the
2706         number-of-iterations case; boolean returns aren't tainted;
2707     * the modified string (or modified copy under /r):
2708         tainted by the source string, pattern, and replacement strings;
2709     * $1 et al:
2710         tainted by the pattern, and under 'use re "taint"', by the source
2711         string too;
2712     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2713         should always be unset before executing subsequent code.
2714
2715 The overall action of pp_subst is:
2716
2717     * at the start, set bits in rxtainted indicating the taint status of
2718         the various sources.
2719
2720     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2721         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2722         pattern has subsequently become tainted via locale ops.
2723
2724     * If control is being passed to pp_substcont to execute a /e block,
2725         save rxtainted in the CXt_SUBST block, for future use by
2726         pp_substcont.
2727
2728     * Whenever control is being returned to perl code (either by falling
2729         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2730         use the flag bits in rxtainted to make all the appropriate types of
2731         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2732         et al will appear tainted.
2733
2734 pp_match is just a simpler version of the above.
2735
2736 */
2737
2738 PP(pp_subst)
2739 {
2740     dSP; dTARG;
2741     PMOP *pm = cPMOP;
2742     PMOP *rpm = pm;
2743     char *s;
2744     char *strend;
2745     const char *c;
2746     STRLEN clen;
2747     SSize_t iters = 0;
2748     SSize_t maxiters;
2749     bool once;
2750     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2751                         See "how taint works" above */
2752     char *orig;
2753     U8 r_flags;
2754     REGEXP *rx = PM_GETRE(pm);
2755     STRLEN len;
2756     int force_on_match = 0;
2757     const I32 oldsave = PL_savestack_ix;
2758     STRLEN slen;
2759     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2760 #ifdef PERL_ANY_COW
2761     bool is_cow;
2762 #endif
2763     SV *nsv = NULL;
2764     /* known replacement string? */
2765     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2766
2767     PERL_ASYNC_CHECK();
2768
2769     if (PL_op->op_flags & OPf_STACKED)
2770         TARG = POPs;
2771     else if (ARGTARG)
2772         GETTARGET;
2773     else {
2774         TARG = DEFSV;
2775         EXTEND(SP,1);
2776     }
2777
2778     SvGETMAGIC(TARG); /* must come before cow check */
2779 #ifdef PERL_ANY_COW
2780     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2781        because they make integers such as 256 "false".  */
2782     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2783 #else
2784     if (SvIsCOW(TARG))
2785         sv_force_normal_flags(TARG,0);
2786 #endif
2787     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2788         && (SvREADONLY(TARG)
2789             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2790                   || SvTYPE(TARG) > SVt_PVLV)
2791                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2792         Perl_croak_no_modify();
2793     PUTBACK;
2794
2795     orig = SvPV_nomg(TARG, len);
2796     /* note we don't (yet) force the var into being a string; if we fail
2797      * to match, we leave as-is; on successful match howeverm, we *will*
2798      * coerce into a string, then repeat the match */
2799     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2800         force_on_match = 1;
2801
2802     /* only replace once? */
2803     once = !(rpm->op_pmflags & PMf_GLOBAL);
2804
2805     /* See "how taint works" above */
2806     if (TAINTING_get) {
2807         rxtainted  = (
2808             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2809           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2810           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2811           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2812                 ? SUBST_TAINT_BOOLRET : 0));
2813         TAINT_NOT;
2814     }
2815
2816   force_it:
2817     if (!pm || !orig)
2818         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2819
2820     strend = orig + len;
2821     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2822     maxiters = 2 * slen + 10;   /* We can match twice at each
2823                                    position, once with zero-length,
2824                                    second time with non-zero. */
2825
2826     if (!RX_PRELEN(rx) && PL_curpm
2827      && !ReANY(rx)->mother_re) {
2828         pm = PL_curpm;
2829         rx = PM_GETRE(pm);
2830     }
2831
2832 #ifdef PERL_SAWAMPERSAND
2833     r_flags = (    RX_NPARENS(rx)
2834                 || PL_sawampersand
2835                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2836                 || (rpm->op_pmflags & PMf_KEEPCOPY)
2837               )
2838           ? REXEC_COPY_STR
2839           : 0;
2840 #else
2841     r_flags = REXEC_COPY_STR;
2842 #endif
2843
2844     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2845     {
2846         SPAGAIN;
2847         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2848         LEAVE_SCOPE(oldsave);
2849         RETURN;
2850     }
2851     PL_curpm = pm;
2852
2853     /* known replacement string? */
2854     if (dstr) {
2855         /* replacement needing upgrading? */
2856         if (DO_UTF8(TARG) && !doutf8) {
2857              nsv = sv_newmortal();
2858              SvSetSV(nsv, dstr);
2859              if (IN_ENCODING)
2860                   sv_recode_to_utf8(nsv, _get_encoding());
2861              else
2862                   sv_utf8_upgrade(nsv);
2863              c = SvPV_const(nsv, clen);
2864              doutf8 = TRUE;
2865         }
2866         else {
2867             c = SvPV_const(dstr, clen);
2868             doutf8 = DO_UTF8(dstr);
2869         }
2870
2871         if (SvTAINTED(dstr))
2872             rxtainted |= SUBST_TAINT_REPL;
2873     }
2874     else {
2875         c = NULL;
2876         doutf8 = FALSE;
2877     }
2878
2879     /* can do inplace substitution? */
2880     if (c
2881 #ifdef PERL_ANY_COW
2882         && !is_cow
2883 #endif
2884         && (I32)clen <= RX_MINLENRET(rx)
2885         && (  once
2886            || !(r_flags & REXEC_COPY_STR)
2887            || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2888            )
2889         && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2890         && (!doutf8 || SvUTF8(TARG))
2891         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2892     {
2893
2894 #ifdef PERL_ANY_COW
2895         if (SvIsCOW(TARG)) {
2896           if (!force_on_match)
2897             goto have_a_cow;
2898           assert(SvVOK(TARG));
2899         }
2900 #endif
2901         if (force_on_match) {
2902             /* redo the first match, this time with the orig var
2903              * forced into being a string */
2904             force_on_match = 0;
2905             orig = SvPV_force_nomg(TARG, len);
2906             goto force_it;
2907         }
2908
2909         if (once) {
2910             char *d, *m;
2911             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2912                 rxtainted |= SUBST_TAINT_PAT;
2913             m = orig + RX_OFFS(rx)[0].start;
2914             d = orig + RX_OFFS(rx)[0].end;
2915             s = orig;
2916             if (m - s > strend - d) {  /* faster to shorten from end */
2917                 I32 i;
2918                 if (clen) {
2919                     Copy(c, m, clen, char);
2920                     m += clen;
2921                 }
2922                 i = strend - d;
2923                 if (i > 0) {
2924                     Move(d, m, i, char);
2925                     m += i;
2926                 }
2927                 *m = '\0';
2928                 SvCUR_set(TARG, m - s);
2929             }
2930             else {      /* faster from front */
2931                 I32 i = m - s;
2932                 d -= clen;
2933                 if (i > 0)
2934                     Move(s, d - i, i, char);
2935                 sv_chop(TARG, d-i);
2936                 if (clen)
2937                     Copy(c, d, clen, char);
2938             }
2939             SPAGAIN;
2940             PUSHs(&PL_sv_yes);
2941         }
2942         else {
2943             char *d, *m;
2944             d = s = RX_OFFS(rx)[0].start + orig;
2945             do {
2946                 I32 i;
2947                 if (UNLIKELY(iters++ > maxiters))
2948                     DIE(aTHX_ "Substitution loop");
2949                 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2950                     rxtainted |= SUBST_TAINT_PAT;
2951                 m = RX_OFFS(rx)[0].start + orig;
2952                 if ((i = m - s)) {
2953                     if (s != d)
2954                         Move(s, d, i, char);
2955                     d += i;
2956                 }
2957                 if (clen) {
2958                     Copy(c, d, clen, char);
2959                     d += clen;
2960                 }
2961                 s = RX_OFFS(rx)[0].end + orig;
2962             } while (CALLREGEXEC(rx, s, strend, orig,
2963                                  s == m, /* don't match same null twice */
2964                                  TARG, NULL,
2965                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2966             if (s != d) {
2967                 I32 i = strend - s;
2968                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2969                 Move(s, d, i+1, char);          /* include the NUL */
2970             }
2971             SPAGAIN;
2972             mPUSHi(iters);
2973         }
2974     }
2975     else {
2976         bool first;
2977         char *m;
2978         SV *repl;
2979         if (force_on_match) {
2980             /* redo the first match, this time with the orig var
2981              * forced into being a string */
2982             force_on_match = 0;
2983             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2984                 /* I feel that it should be possible to avoid this mortal copy
2985                    given that the code below copies into a new destination.
2986                    However, I suspect it isn't worth the complexity of
2987                    unravelling the C<goto force_it> for the small number of
2988                    cases where it would be viable to drop into the copy code. */
2989                 TARG = sv_2mortal(newSVsv(TARG));
2990             }
2991             orig = SvPV_force_nomg(TARG, len);
2992             goto force_it;
2993         }
2994 #ifdef PERL_ANY_COW
2995       have_a_cow:
2996 #endif
2997         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2998             rxtainted |= SUBST_TAINT_PAT;
2999         repl = dstr;
3000         s = RX_OFFS(rx)[0].start + orig;
3001         dstr = newSVpvn_flags(orig, s-orig,
3002                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3003         if (!c) {
3004             PERL_CONTEXT *cx;
3005             SPAGAIN;
3006             m = orig;
3007             /* note that a whole bunch of local vars are saved here for
3008              * use by pp_substcont: here's a list of them in case you're
3009              * searching for places in this sub that uses a particular var:
3010              * iters maxiters r_flags oldsave rxtainted orig dstr targ
3011              * s m strend rx once */
3012             PUSHSUBST(cx);
3013             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3014         }
3015         first = TRUE;
3016         do {
3017             if (UNLIKELY(iters++ > maxiters))
3018                 DIE(aTHX_ "Substitution loop");
3019             if (UNLIKELY(RX_MATCH_TAINTED(rx)))
3020                 rxtainted |= SUBST_TAINT_PAT;
3021             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
3022                 char *old_s    = s;
3023                 char *old_orig = orig;
3024                 assert(RX_SUBOFFSET(rx) == 0);
3025
3026                 orig = RX_SUBBEG(rx);
3027                 s = orig + (old_s - old_orig);
3028                 strend = s + (strend - old_s);
3029             }
3030             m = RX_OFFS(rx)[0].start + orig;
3031             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3032             s = RX_OFFS(rx)[0].end + orig;
3033             if (first) {
3034                 /* replacement already stringified */
3035               if (clen)
3036                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3037               first = FALSE;
3038             }
3039             else {
3040                 if (IN_ENCODING) {
3041                     if (!nsv) nsv = sv_newmortal();
3042                     sv_copypv(nsv, repl);
3043                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
3044                     sv_catsv(dstr, nsv);
3045                 }
3046                 else sv_catsv(dstr, repl);
3047                 if (UNLIKELY(SvTAINTED(repl)))
3048                     rxtainted |= SUBST_TAINT_REPL;
3049             }
3050             if (once)
3051                 break;
3052         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
3053                              TARG, NULL,
3054                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3055         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3056
3057         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3058             /* From here on down we're using the copy, and leaving the original
3059                untouched.  */
3060             TARG = dstr;
3061             SPAGAIN;
3062             PUSHs(dstr);
3063         } else {
3064 #ifdef PERL_ANY_COW
3065             /* The match may make the string COW. If so, brilliant, because
3066                that's just saved us one malloc, copy and free - the regexp has
3067                donated the old buffer, and we malloc an entirely new one, rather
3068                than the regexp malloc()ing a buffer and copying our original,
3069                only for us to throw it away here during the substitution.  */
3070             if (SvIsCOW(TARG)) {
3071                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3072             } else
3073 #endif
3074             {
3075                 SvPV_free(TARG);
3076             }
3077             SvPV_set(TARG, SvPVX(dstr));
3078             SvCUR_set(TARG, SvCUR(dstr));
3079             SvLEN_set(TARG, SvLEN(dstr));
3080             SvFLAGS(TARG) |= SvUTF8(dstr);
3081             SvPV_set(dstr, NULL);
3082
3083             SPAGAIN;
3084             mPUSHi(iters);
3085         }
3086     }
3087
3088     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3089         (void)SvPOK_only_UTF8(TARG);
3090     }
3091
3092     /* See "how taint works" above */
3093     if (TAINTING_get) {
3094         if ((rxtainted & SUBST_TAINT_PAT) ||
3095             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3096                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3097         )
3098             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
3099
3100         if (!(rxtainted & SUBST_TAINT_BOOLRET)
3101             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3102         )
3103             SvTAINTED_on(TOPs);  /* taint return value */
3104         else
3105             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
3106
3107         /* needed for mg_set below */
3108         TAINT_set(
3109           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3110         );
3111         SvTAINT(TARG);
3112     }
3113     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3114     TAINT_NOT;
3115     LEAVE_SCOPE(oldsave);
3116     RETURN;
3117 }
3118
3119 PP(pp_grepwhile)
3120 {
3121     dSP;
3122
3123     if (SvTRUEx(POPs))
3124         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3125     ++*PL_markstack_ptr;
3126     FREETMPS;
3127     LEAVE_with_name("grep_item");                                       /* exit inner scope */
3128
3129     /* All done yet? */
3130     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3131         I32 items;
3132         const I32 gimme = GIMME_V;
3133
3134         LEAVE_with_name("grep");                                        /* exit outer scope */
3135         (void)POPMARK;                          /* pop src */
3136         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3137         (void)POPMARK;                          /* pop dst */
3138         SP = PL_stack_base + POPMARK;           /* pop original mark */
3139         if (gimme == G_SCALAR) {
3140             if (PL_op->op_private & OPpGREP_LEX) {
3141                 SV* const sv = sv_newmortal();
3142                 sv_setiv(sv, items);
3143                 PUSHs(sv);
3144             }
3145             else {
3146                 dTARGET;
3147                 XPUSHi(items);
3148             }
3149         }
3150         else if (gimme == G_ARRAY)
3151             SP += items;
3152         RETURN;
3153     }
3154     else {
3155         SV *src;
3156
3157         ENTER_with_name("grep_item");                                   /* enter inner scope */
3158         SAVEVPTR(PL_curpm);
3159
3160         src = PL_stack_base[*PL_markstack_ptr];
3161         if (SvPADTMP(src)) {
3162             src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
3163             PL_tmps_floor++;
3164         }
3165         SvTEMP_off(src);
3166         if (PL_op->op_private & OPpGREP_LEX)
3167             PAD_SVl(PL_op->op_targ) = src;
3168         else
3169             DEFSV_set(src);
3170
3171         RETURNOP(cLOGOP->op_other);
3172     }
3173 }
3174
3175 PP(pp_leavesub)
3176 {
3177     dSP;
3178     SV **mark;
3179     SV **newsp;
3180     PMOP *newpm;
3181     I32 gimme;
3182     PERL_CONTEXT *cx;
3183     SV *sv;
3184
3185     if (CxMULTICALL(&cxstack[cxstack_ix])) {
3186         /* entry zero of a stack is always PL_sv_undef, which
3187          * simplifies converting a '()' return into undef in scalar context */
3188         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
3189         return 0;
3190     }
3191
3192     POPBLOCK(cx,newpm);
3193     cxstack_ix++; /* temporarily protect top context */
3194
3195     TAINT_NOT;
3196     if (gimme == G_SCALAR) {
3197         MARK = newsp + 1;
3198         if (LIKELY(MARK <= SP)) {
3199             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
3200                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3201                      && !SvMAGICAL(TOPs)) {
3202                     *MARK = SvREFCNT_inc(TOPs);
3203                     FREETMPS;
3204                     sv_2mortal(*MARK);
3205                 }
3206                 else {
3207                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
3208                     FREETMPS;
3209                     *MARK = sv_mortalcopy(sv);
3210                     SvREFCNT_dec_NN(sv);
3211                 }
3212             }
3213             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3214                      && !SvMAGICAL(TOPs)) {
3215                 *MARK = TOPs;
3216             }
3217             else
3218                 *MARK = sv_mortalcopy(TOPs);
3219         }
3220         else {
3221             MEXTEND(MARK, 0);
3222             *MARK = &PL_sv_undef;
3223         }
3224         SP = MARK;
3225     }
3226     else if (gimme == G_ARRAY) {
3227         for (MARK = newsp + 1; MARK <= SP; MARK++) {
3228             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
3229                  || SvMAGICAL(*MARK)) {
3230                 *MARK = sv_mortalcopy(*MARK);
3231                 TAINT_NOT;      /* Each item is independent */
3232             }
3233         }
3234     }
3235     PUTBACK;
3236
3237     LEAVE;
3238     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
3239     cxstack_ix--;
3240     PL_curpm = newpm;   /* ... and pop $1 et al */
3241
3242     LEAVESUB(sv);
3243     return cx->blk_sub.retop;
3244 }
3245
3246 PP(pp_entersub)
3247 {
3248     dSP; dPOPss;
3249     GV *gv;
3250     CV *cv;
3251     PERL_CONTEXT *cx;
3252     I32 gimme;
3253     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
3254
3255     if (UNLIKELY(!sv))
3256         DIE(aTHX_ "Not a CODE reference");
3257     /* This is overwhelmingly the most common case:  */
3258     if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
3259         switch (SvTYPE(sv)) {
3260         case SVt_PVGV:
3261           we_have_a_glob:
3262             if (!(cv = GvCVu((const GV *)sv))) {
3263                 HV *stash;
3264                 cv = sv_2cv(sv, &stash, &gv, 0);
3265             }
3266             if (!cv) {
3267                 ENTER;
3268                 SAVETMPS;
3269                 goto try_autoload;
3270             }
3271             break;
3272         case SVt_PVLV:
3273             if(isGV_with_GP(sv)) goto we_have_a_glob;
3274             /* FALLTHROUGH */
3275         default:
3276             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
3277                 if (hasargs)
3278                     SP = PL_stack_base + POPMARK;
3279                 else
3280                     (void)POPMARK;
3281                 RETURN;
3282             }
3283             SvGETMAGIC(sv);
3284             if (SvROK(sv)) {
3285                 if (SvAMAGIC(sv)) {
3286                     sv = amagic_deref_call(sv, to_cv_amg);
3287                     /* Don't SPAGAIN here.  */
3288                 }
3289             }
3290             else {
3291                 const char *sym;
3292                 STRLEN len;
3293                 if (!SvOK(sv))
3294                     DIE(aTHX_ PL_no_usym, "a subroutine");
3295                 sym = SvPV_nomg_const(sv, len);
3296                 if (PL_op->op_private & HINT_STRICT_REFS)
3297                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3298                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3299                 break;
3300             }
3301             cv = MUTABLE_CV(SvRV(sv));
3302             if (SvTYPE(cv) == SVt_PVCV)
3303                 break;
3304             /* FALLTHROUGH */
3305         case SVt_PVHV:
3306         case SVt_PVAV:
3307             DIE(aTHX_ "Not a CODE reference");
3308             /* This is the second most common case:  */
3309         case SVt_PVCV:
3310             cv = MUTABLE_CV(sv);
3311             break;
3312         }
3313     }
3314
3315     ENTER;
3316
3317   retry:
3318     if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
3319         DIE(aTHX_ "Closure prototype called");
3320     if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
3321         GV* autogv;
3322         SV* sub_name;
3323
3324         /* anonymous or undef'd function leaves us no recourse */
3325         if (CvLEXICAL(cv) && CvHASGV(cv))
3326             DIE(aTHX_ "Undefined subroutine &%"SVf" called",
3327                        SVfARG(cv_name(cv, NULL, 0)));
3328         if (CvANON(cv) || !CvHASGV(cv)) {
3329             DIE(aTHX_ "Undefined subroutine called");
3330         }
3331
3332         /* autoloaded stub? */
3333         if (cv != GvCV(gv = CvGV(cv))) {
3334             cv = GvCV(gv);
3335         }
3336         /* should call AUTOLOAD now? */
3337         else {
3338           try_autoload:
3339             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3340                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
3341             {
3342                 cv = GvCV(autogv);
3343             }
3344             else {
3345                sorry:
3346                 sub_name = sv_newmortal();
3347                 gv_efullname3(sub_name, gv, NULL);
3348                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
3349             }
3350         }
3351         if (!cv)
3352             goto sorry;
3353         goto retry;
3354     }
3355
3356     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3357             && !CvNODEBUG(cv)))
3358     {
3359          Perl_get_db_sub(aTHX_ &sv, cv);
3360          if (CvISXSUB(cv))
3361              PL_curcopdb = PL_curcop;
3362          if (CvLVALUE(cv)) {
3363              /* check for lsub that handles lvalue subroutines */
3364              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
3365              /* if lsub not found then fall back to DB::sub */
3366              if (!cv) cv = GvCV(PL_DBsub);
3367          } else {
3368              cv = GvCV(PL_DBsub);
3369          }
3370
3371         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3372             DIE(aTHX_ "No DB::sub routine defined");
3373     }
3374
3375     gimme = GIMME_V;
3376
3377     if (!(CvISXSUB(cv))) {
3378         /* This path taken at least 75% of the time   */
3379         dMARK;
3380         PADLIST * const padlist = CvPADLIST(cv);
3381         I32 depth;
3382
3383         PUSHBLOCK(cx, CXt_SUB, MARK);
3384         PUSHSUB(cx);
3385         cx->blk_sub.retop = PL_op->op_next;
3386         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3387             PERL_STACK_OVERFLOW_CHECK();
3388             pad_push(padlist, depth);
3389         }
3390         SAVECOMPPAD();
3391         PAD_SET_CUR_NOSAVE(padlist, depth);
3392         if (LIKELY(hasargs)) {
3393             AV *const av = MUTABLE_AV(PAD_SVl(0));
3394             SSize_t items;
3395             AV **defavp;
3396
3397             if (UNLIKELY(AvREAL(av))) {
3398                 /* @_ is normally not REAL--this should only ever
3399                  * happen when DB::sub() calls things that modify @_ */
3400                 av_clear(av);
3401                 AvREAL_off(av);
3402                 AvREIFY_on(av);
3403             }
3404             defavp = &GvAV(PL_defgv);
3405             cx->blk_sub.savearray = *defavp;
3406             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
3407             CX_CURPAD_SAVE(cx->blk_sub);
3408             cx->blk_sub.argarray = av;
3409             items = SP - MARK;
3410
3411             if (UNLIKELY(items - 1 > AvMAX(av))) {
3412                 SV **ary = AvALLOC(av);
3413                 AvMAX(av) = items - 1;
3414                 Renew(ary, items, SV*);
3415                 AvALLOC(av) = ary;
3416                 AvARRAY(av) = ary;
3417             }
3418
3419             Copy(MARK+1,AvARRAY(av),items,SV*);
3420             AvFILLp(av) = items - 1;
3421
3422             MARK = AvARRAY(av);
3423             while (items--) {
3424                 if (*MARK)
3425                 {
3426                     if (SvPADTMP(*MARK)) {
3427                         *MARK = sv_mortalcopy(*MARK);
3428                     }
3429                     SvTEMP_off(*MARK);
3430                 }
3431                 MARK++;
3432             }
3433         }
3434         SAVETMPS;
3435         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3436             !CvLVALUE(cv)))
3437             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3438         /* warning must come *after* we fully set up the context
3439          * stuff so that __WARN__ handlers can safely dounwind()
3440          * if they want to
3441          */
3442         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
3443                 && ckWARN(WARN_RECURSION)
3444                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
3445             sub_crush_depth(cv);
3446         RETURNOP(CvSTART(cv));
3447     }
3448     else {
3449         SSize_t markix = TOPMARK;
3450
3451         SAVETMPS;
3452         PUTBACK;
3453
3454         if (UNLIKELY(((PL_op->op_private
3455                & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3456              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3457             !CvLVALUE(cv)))
3458             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3459
3460         if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3461             /* Need to copy @_ to stack. Alternative may be to
3462              * switch stack to @_, and copy return values
3463              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3464             AV * const av = GvAV(PL_defgv);
3465             const SSize_t items = AvFILL(av) + 1;
3466
3467             if (items) {
3468                 SSize_t i = 0;
3469                 const bool m = cBOOL(SvRMAGICAL(av));
3470                 /* Mark is at the end of the stack. */
3471                 EXTEND(SP, items);
3472                 for (; i < items; ++i)
3473                 {
3474                     SV *sv;
3475                     if (m) {
3476                         SV ** const svp = av_fetch(av, i, 0);
3477                         sv = svp ? *svp : NULL;
3478                     }
3479                     else sv = AvARRAY(av)[i];
3480                     if (sv) SP[i+1] = sv;
3481                     else {
3482                         SP[i+1] = newSVavdefelem(av, i, 1);
3483                     }
3484                 }
3485                 SP += items;
3486                 PUTBACK ;
3487             }
3488         }
3489         else {
3490             SV **mark = PL_stack_base + markix;
3491             SSize_t items = SP - mark;
3492             while (items--) {
3493                 mark++;
3494                 if (*mark && SvPADTMP(*mark)) {
3495                     *mark = sv_mortalcopy(*mark);
3496                 }
3497             }
3498         }
3499         /* We assume first XSUB in &DB::sub is the called one. */
3500         if (UNLIKELY(PL_curcopdb)) {
3501             SAVEVPTR(PL_curcop);
3502             PL_curcop = PL_curcopdb;
3503             PL_curcopdb = NULL;
3504         }
3505         /* Do we need to open block here? XXXX */
3506
3507         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3508         assert(CvXSUB(cv));
3509         CvXSUB(cv)(aTHX_ cv);
3510
3511         /* Enforce some sanity in scalar context. */
3512         if (gimme == G_SCALAR) {
3513             SV **svp = PL_stack_base + markix + 1;
3514             if (svp != PL_stack_sp) {
3515                 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3516                 PL_stack_sp = svp;
3517             }
3518         }
3519         LEAVE;
3520         return NORMAL;
3521     }
3522 }
3523
3524 void
3525 Perl_sub_crush_depth(pTHX_ CV *cv)
3526 {
3527     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3528
3529     if (CvANON(cv))
3530         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3531     else {
3532         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3533                     SVfARG(cv_name(cv,NULL,0)));
3534     }
3535 }
3536
3537 PP(pp_aelem)
3538 {
3539     dSP;
3540     SV** svp;
3541     SV* const elemsv = POPs;
3542     IV elem = SvIV(elemsv);
3543     AV *const av = MUTABLE_AV(POPs);
3544     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3545     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3546     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3547     bool preeminent = TRUE;
3548     SV *sv;
3549
3550     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
3551         Perl_warner(aTHX_ packWARN(WARN_MISC),
3552                     "Use of reference \"%"SVf"\" as array index",
3553                     SVfARG(elemsv));
3554     if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
3555         RETPUSHUNDEF;
3556
3557     if (UNLIKELY(localizing)) {
3558         MAGIC *mg;
3559         HV *stash;
3560
3561         /* If we can determine whether the element exist,
3562          * Try to preserve the existenceness of a tied array
3563          * element by using EXISTS and DELETE if possible.
3564          * Fallback to FETCH and STORE otherwise. */
3565         if (SvCANEXISTDELETE(av))
3566             preeminent = av_exists(av, elem);
3567     }
3568
3569     svp = av_fetch(av, elem, lval && !defer);
3570     if (lval) {
3571 #ifdef PERL_MALLOC_WRAP
3572          if (SvUOK(elemsv)) {
3573               const UV uv = SvUV(elemsv);
3574               elem = uv > IV_MAX ? IV_MAX : uv;
3575          }
3576          else if (SvNOK(elemsv))
3577               elem = (IV)SvNV(elemsv);
3578          if (elem > 0) {
3579               static const char oom_array_extend[] =
3580                 "Out of memory during array extend"; /* Duplicated in av.c */
3581               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3582          }
3583 #endif
3584         if (!svp || !*svp) {
3585             IV len;
3586             if (!defer)
3587                 DIE(aTHX_ PL_no_aelem, elem);
3588             len = av_tindex(av);
3589             mPUSHs(newSVavdefelem(av,
3590             /* Resolve a negative index now, unless it points before the
3591                beginning of the array, in which case record it for error
3592                reporting in magic_setdefelem. */
3593                 elem < 0 && len + elem >= 0 ? len + elem : elem,
3594                 1));
3595             RETURN;
3596         }
3597         if (UNLIKELY(localizing)) {
3598             if (preeminent)
3599                 save_aelem(av, elem, svp);
3600             else
3601                 SAVEADELETE(av, elem);
3602         }
3603         else if (PL_op->op_private & OPpDEREF) {
3604             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3605             RETURN;
3606         }
3607     }
3608     sv = (svp ? *svp : &PL_sv_undef);
3609     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3610         mg_get(sv);
3611     PUSHs(sv);
3612     RETURN;
3613 }
3614
3615 SV*
3616 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3617 {
3618     PERL_ARGS_ASSERT_VIVIFY_REF;
3619
3620     SvGETMAGIC(sv);
3621     if (!SvOK(sv)) {
3622         if (SvREADONLY(sv))
3623             Perl_croak_no_modify();
3624         prepare_SV_for_RV(sv);
3625         switch (to_what) {
3626         case OPpDEREF_SV:
3627             SvRV_set(sv, newSV(0));
3628             break;
3629         case OPpDEREF_AV:
3630             SvRV_set(sv, MUTABLE_SV(newAV()));
3631             break;
3632         case OPpDEREF_HV:
3633             SvRV_set(sv, MUTABLE_SV(newHV()));
3634             break;
3635         }
3636         SvROK_on(sv);
3637         SvSETMAGIC(sv);
3638         SvGETMAGIC(sv);
3639     }
3640     if (SvGMAGICAL(sv)) {
3641         /* copy the sv without magic to prevent magic from being
3642            executed twice */
3643         SV* msv = sv_newmortal();
3644         sv_setsv_nomg(msv, sv);
3645         return msv;
3646     }
3647     return sv;
3648 }
3649
3650 PERL_STATIC_INLINE HV *
3651 S_opmethod_stash(pTHX_ SV* meth)
3652 {
3653     SV* ob;
3654     HV* stash;
3655
3656     SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
3657         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3658                             "package or object reference", SVfARG(meth)),
3659            (SV *)NULL)
3660         : *(PL_stack_base + TOPMARK + 1);
3661
3662     PERL_ARGS_ASSERT_OPMETHOD_STASH;
3663
3664     if (UNLIKELY(!sv))
3665        undefined:
3666         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3667                    SVfARG(meth));
3668
3669     if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3670     else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3671         stash = gv_stashsv(sv, GV_CACHE_ONLY);
3672         if (stash) return stash;
3673     }
3674
3675     if (SvROK(sv))
3676         ob = MUTABLE_SV(SvRV(sv));
3677     else if (!SvOK(sv)) goto undefined;
3678     else if (isGV_with_GP(sv)) {
3679         if (!GvIO(sv))
3680             Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3681                              "without a package or object reference",
3682                               SVfARG(meth));
3683         ob = sv;
3684         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3685             assert(!LvTARGLEN(ob));
3686             ob = LvTARG(ob);
3687             assert(ob);
3688         }
3689         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3690     }
3691     else {
3692         /* this isn't a reference */
3693         GV* iogv;
3694         STRLEN packlen;
3695         const char * const packname = SvPV_nomg_const(sv, packlen);
3696         const U32 packname_utf8 = SvUTF8(sv);
3697         stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3698         if (stash) return stash;
3699
3700         if (!(iogv = gv_fetchpvn_flags(
3701                 packname, packlen, packname_utf8, SVt_PVIO
3702              )) ||
3703             !(ob=MUTABLE_SV(GvIO(iogv))))
3704         {
3705             /* this isn't the name of a filehandle either */
3706             if (!packlen)
3707             {
3708                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3709                                  "without a package or object reference",
3710                                   SVfARG(meth));
3711             }
3712             /* assume it's a package name */
3713             stash = gv_stashpvn(packname, packlen, packname_utf8);
3714             if (stash) return stash;
3715             else return MUTABLE_HV(sv);
3716         }
3717         /* it _is_ a filehandle name -- replace with a reference */
3718         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3719     }
3720
3721     /* if we got here, ob should be an object or a glob */
3722     if (!ob || !(SvOBJECT(ob)
3723                  || (isGV_with_GP(ob)
3724                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3725                      && SvOBJECT(ob))))
3726     {
3727         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3728                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3729                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3730                                         : meth));
3731     }
3732
3733     return SvSTASH(ob);
3734 }
3735
3736 PP(pp_method)
3737 {
3738     dSP;
3739     GV* gv;
3740     HV* stash;
3741     SV* const meth = TOPs;
3742
3743     if (SvROK(meth)) {
3744         SV* const rmeth = SvRV(meth);
3745         if (SvTYPE(rmeth) == SVt_PVCV) {
3746             SETs(rmeth);
3747             RETURN;
3748         }
3749     }
3750
3751     stash = opmethod_stash(meth);
3752
3753     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3754     assert(gv);
3755
3756     SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3757     RETURN;
3758 }
3759
3760 #define METHOD_CHECK_CACHE(stash,cache,meth)                            \
3761     const HE* const he = hv_fetch_ent(cache, meth, 0, 0);               \
3762     if (he) {                                                           \
3763         gv = MUTABLE_GV(HeVAL(he));                                     \
3764         if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv)        \
3765              == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))     \
3766         {                                                               \
3767             XPUSHs(MUTABLE_SV(GvCV(gv)));                               \
3768             RETURN;                                                     \
3769         }                                                               \
3770     }                                                                   \
3771
3772 PP(pp_method_named)
3773 {
3774     dSP;
3775     GV* gv;
3776     SV* const meth = cMETHOPx_meth(PL_op);
3777     HV* const stash = opmethod_stash(meth);
3778
3779     if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
3780         METHOD_CHECK_CACHE(stash, stash, meth);
3781     }
3782
3783     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3784     assert(gv);
3785
3786     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3787     RETURN;
3788 }
3789
3790 PP(pp_method_super)
3791 {
3792     dSP;
3793     GV* gv;
3794     HV* cache;
3795     SV* const meth = cMETHOPx_meth(PL_op);
3796     HV* const stash = CopSTASH(PL_curcop);
3797     /* Actually, SUPER doesn't need real object's (or class') stash at all,
3798      * as it uses CopSTASH. However, we must ensure that object(class) is
3799      * correct (this check is done by S_opmethod_stash) */
3800     opmethod_stash(meth);
3801
3802     if ((cache = HvMROMETA(stash)->super)) {
3803         METHOD_CHECK_CACHE(stash, cache, meth);
3804     }
3805
3806     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3807     assert(gv);
3808
3809     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3810     RETURN;
3811 }
3812
3813 PP(pp_method_redir)
3814 {
3815     dSP;
3816     GV* gv;
3817     SV* const meth = cMETHOPx_meth(PL_op);
3818     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3819     opmethod_stash(meth); /* not used but needed for error checks */
3820
3821     if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3822     else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3823
3824     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3825     assert(gv);
3826
3827     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3828     RETURN;
3829 }
3830
3831 PP(pp_method_redir_super)
3832 {
3833     dSP;
3834     GV* gv;
3835     HV* cache;
3836     SV* const meth = cMETHOPx_meth(PL_op);
3837     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3838     opmethod_stash(meth); /* not used but needed for error checks */
3839
3840     if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3841     else if ((cache = HvMROMETA(stash)->super)) {
3842          METHOD_CHECK_CACHE(stash, cache, meth);
3843     }
3844
3845     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3846     assert(gv);
3847
3848     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3849     RETURN;
3850 }
3851
3852 /*
3853  * ex: set ts=8 sts=4 sw=4 et:
3854  */