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     /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
1178      * only need to save locally, not on the save stack */
1179     U16 old_delaymagic = PL_delaymagic;
1180 #ifdef DEBUGGING
1181     bool fake = 0;
1182 #endif
1183
1184     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1185
1186     /* If there's a common identifier on both sides we have to take
1187      * special care that assigning the identifier on the left doesn't
1188      * clobber a value on the right that's used later in the list.
1189      */
1190
1191     if ( (PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1))
1192         /* at least 2 LH and RH elements, or commonality isn't an issue */
1193         && (firstlelem < lastlelem && firstrelem < lastrelem)
1194     ) {
1195         if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1196             /* skip the scan if all scalars have a ref count of 1 */
1197             for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1198                 sv = *lelem;
1199                 if (!sv || SvREFCNT(sv) == 1)
1200                     continue;
1201                 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1202                     goto do_scan;
1203                 break;
1204             }
1205         }
1206         else {
1207           do_scan:
1208             S_aassign_copy_common(aTHX_
1209                         firstlelem, lastlelem, firstrelem, lastrelem
1210 #ifdef DEBUGGING
1211                         , fake
1212 #endif
1213             );
1214         }
1215     }
1216 #ifdef DEBUGGING
1217     else {
1218         /* on debugging builds, do the scan even if we've concluded we
1219          * don't need to, then panic if we find commonality. Note that the
1220          * scanner assumes at least 2 elements */
1221         if (firstlelem < lastlelem && firstrelem < lastrelem) {
1222             fake = 1;
1223             goto do_scan;
1224         }
1225     }
1226 #endif
1227
1228     gimme = GIMME_V;
1229     lval = (gimme == G_ARRAY) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1230
1231     relem = firstrelem;
1232     lelem = firstlelem;
1233     ary = NULL;
1234     hash = NULL;
1235
1236     while (LIKELY(lelem <= lastlelem)) {
1237         bool alias = FALSE;
1238         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1239         sv = *lelem++;
1240         if (UNLIKELY(!sv)) {
1241             alias = TRUE;
1242             sv = *lelem++;
1243             ASSUME(SvTYPE(sv) == SVt_PVAV);
1244         }
1245         switch (SvTYPE(sv)) {
1246         case SVt_PVAV: {
1247             bool already_copied = FALSE;
1248             ary = MUTABLE_AV(sv);
1249             magic = SvMAGICAL(ary) != 0;
1250             ENTER;
1251             SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1252
1253             /* We need to clear ary. The is a danger that if we do this,
1254              * elements on the RHS may be prematurely freed, e.g.
1255              *   @a = ($a[0]);
1256              * In the case of possible commonality, make a copy of each
1257              * RHS SV *before* clearing the array, and add a reference
1258              * from the tmps stack, so that it doesn't leak on death.
1259              * Otherwise, make a copy of each RHS SV only as we're storing
1260              * it into the array - that way we don't have to worry about
1261              * it being leaked if we die, but don't incur the cost of
1262              * mortalising everything.
1263              */
1264
1265             if (   (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1266                 && (relem <= lastrelem)
1267                 && (magic || AvFILL(ary) != -1))
1268             {
1269                 SV **svp;
1270                 EXTEND_MORTAL(lastrelem - relem + 1);
1271                 for (svp = relem; svp <= lastrelem; svp++) {
1272                     /* see comment in S_aassign_copy_common about SV_NOSTEAL */
1273                     *svp = sv_mortalcopy_flags(*svp,
1274                             SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1275                     TAINT_NOT;
1276                 }
1277                 already_copied = TRUE;
1278             }
1279
1280             av_clear(ary);
1281             if (relem <= lastrelem)
1282                 av_extend(ary, lastrelem - relem);
1283
1284             i = 0;
1285             while (relem <= lastrelem) {        /* gobble up all the rest */
1286                 SV **didstore;
1287                 if (LIKELY(!alias)) {
1288                     if (already_copied)
1289                         sv = *relem;
1290                     else {
1291                         if (LIKELY(*relem))
1292                             /* before newSV, in case it dies */
1293                             SvGETMAGIC(*relem);
1294                         sv = newSV(0);
1295                         /* see comment in S_aassign_copy_common about
1296                          * SV_NOSTEAL */
1297                         sv_setsv_flags(sv, *relem,
1298                                     (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1299                         *relem = sv;
1300                     }
1301                 }
1302                 else {
1303                     if (!already_copied)
1304                         SvGETMAGIC(*relem);
1305                     if (!SvROK(*relem))
1306                         DIE(aTHX_ "Assigned value is not a reference");
1307                     if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1308                    /* diag_listed_as: Assigned value is not %s reference */
1309                         DIE(aTHX_
1310                            "Assigned value is not a SCALAR reference");
1311                     if (lval && !already_copied)
1312                         *relem = sv_mortalcopy(*relem);
1313                     /* XXX else check for weak refs?  */
1314                     sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1315                 }
1316                 relem++;
1317                 if (already_copied)
1318                     SvREFCNT_inc_simple_NN(sv); /* undo mortal free */
1319                 didstore = av_store(ary,i++,sv);
1320                 if (magic) {
1321                     if (!didstore)
1322                         sv_2mortal(sv);
1323                     if (SvSMAGICAL(sv))
1324                         mg_set(sv);
1325                 }
1326                 TAINT_NOT;
1327             }
1328             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1329                 SvSETMAGIC(MUTABLE_SV(ary));
1330             LEAVE;
1331             break;
1332         }
1333
1334         case SVt_PVHV: {                                /* normal hash */
1335                 SV *tmpstr;
1336                 int odd;
1337                 int duplicates = 0;
1338                 SV** topelem = relem;
1339                 SV **firsthashrelem = relem;
1340                 bool already_copied = FALSE;
1341
1342                 hash = MUTABLE_HV(sv);
1343                 magic = SvMAGICAL(hash) != 0;
1344
1345                 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1346                 if (UNLIKELY(odd)) {
1347                     do_oddball(lastrelem, firsthashrelem);
1348                     /* we have firstlelem to reuse, it's not needed anymore
1349                      */
1350                     *(lastrelem+1) = &PL_sv_undef;
1351                 }
1352
1353                 ENTER;
1354                 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1355
1356                 /* We need to clear hash. The is a danger that if we do this,
1357                  * elements on the RHS may be prematurely freed, e.g.
1358                  *   %h = (foo => $h{bar});
1359                  * In the case of possible commonality, make a copy of each
1360                  * RHS SV *before* clearing the hash, and add a reference
1361                  * from the tmps stack, so that it doesn't leak on death.
1362                  */
1363
1364                 if (   (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1365                     && (relem <= lastrelem)
1366                     && (magic || HvUSEDKEYS(hash)))
1367                 {
1368                     SV **svp;
1369                     EXTEND_MORTAL(lastrelem - relem + 1);
1370                     for (svp = relem; svp <= lastrelem; svp++) {
1371                         *svp = sv_mortalcopy_flags(*svp,
1372                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1373                         TAINT_NOT;
1374                     }
1375                     already_copied = TRUE;
1376                 }
1377
1378                 hv_clear(hash);
1379
1380                 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1381                     HE *didstore;
1382                     assert(*relem);
1383                     /* Copy the key if aassign is called in lvalue context,
1384                        to avoid having the next op modify our rhs.  Copy
1385                        it also if it is gmagical, lest it make the
1386                        hv_store_ent call below croak, leaking the value. */
1387                     sv = (lval || SvGMAGICAL(*relem)) && !already_copied
1388                          ? sv_mortalcopy(*relem)
1389                          : *relem;
1390                     relem++;
1391                     assert(*relem);
1392                     if (already_copied)
1393                         tmpstr = *relem++;
1394                     else {
1395                         SvGETMAGIC(*relem);
1396                         tmpstr = newSV(0);
1397                         sv_setsv_nomg(tmpstr,*relem++); /* value */
1398                     }
1399
1400                     if (gimme == G_ARRAY) {
1401                         if (hv_exists_ent(hash, sv, 0))
1402                             /* key overwrites an existing entry */
1403                             duplicates += 2;
1404                         else {
1405                             /* copy element back: possibly to an earlier
1406                              * stack location if we encountered dups earlier,
1407                              * possibly to a later stack location if odd */
1408                             *topelem++ = sv;
1409                             *topelem++ = tmpstr;
1410                         }
1411                     }
1412                     if (already_copied)
1413                         SvREFCNT_inc_simple_NN(tmpstr); /* undo mortal free */
1414                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1415                     if (magic) {
1416                         if (!didstore) sv_2mortal(tmpstr);
1417                         SvSETMAGIC(tmpstr);
1418                     }
1419                     TAINT_NOT;
1420                 }
1421                 LEAVE;
1422                 if (duplicates && gimme == G_ARRAY) {
1423                     /* at this point we have removed the duplicate key/value
1424                      * pairs from the stack, but the remaining values may be
1425                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1426                      * the (a 2), but the stack now probably contains
1427                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1428                      * obliterates the earlier key. So refresh all values. */
1429                     lastrelem -= duplicates;
1430                     relem = firsthashrelem;
1431                     while (relem < lastrelem+odd) {
1432                         HE *he;
1433                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1434                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1435                     }
1436                 }
1437                 if (odd && gimme == G_ARRAY) lastrelem++;
1438             }
1439             break;
1440         default:
1441             if (SvIMMORTAL(sv)) {
1442                 if (relem <= lastrelem)
1443                     relem++;
1444                 break;
1445             }
1446             if (relem <= lastrelem) {
1447                 if (UNLIKELY(
1448                   SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1449                   (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1450                 ))
1451                     Perl_warner(aTHX_
1452                        packWARN(WARN_MISC),
1453                       "Useless assignment to a temporary"
1454                     );
1455                 sv_setsv(sv, *relem);
1456                 *(relem++) = sv;
1457             }
1458             else
1459                 sv_setsv(sv, &PL_sv_undef);
1460             SvSETMAGIC(sv);
1461             break;
1462         }
1463     }
1464     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1465         /* Will be used to set PL_tainting below */
1466         Uid_t tmp_uid  = PerlProc_getuid();
1467         Uid_t tmp_euid = PerlProc_geteuid();
1468         Gid_t tmp_gid  = PerlProc_getgid();
1469         Gid_t tmp_egid = PerlProc_getegid();
1470
1471         /* XXX $> et al currently silently ignore failures */
1472         if (PL_delaymagic & DM_UID) {
1473 #ifdef HAS_SETRESUID
1474             PERL_UNUSED_RESULT(
1475                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1476                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1477                          (Uid_t)-1));
1478 #else
1479 #  ifdef HAS_SETREUID
1480             PERL_UNUSED_RESULT(
1481                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1482                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1483 #  else
1484 #    ifdef HAS_SETRUID
1485             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1486                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1487                 PL_delaymagic &= ~DM_RUID;
1488             }
1489 #    endif /* HAS_SETRUID */
1490 #    ifdef HAS_SETEUID
1491             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1492                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1493                 PL_delaymagic &= ~DM_EUID;
1494             }
1495 #    endif /* HAS_SETEUID */
1496             if (PL_delaymagic & DM_UID) {
1497                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1498                     DIE(aTHX_ "No setreuid available");
1499                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1500             }
1501 #  endif /* HAS_SETREUID */
1502 #endif /* HAS_SETRESUID */
1503
1504             tmp_uid  = PerlProc_getuid();
1505             tmp_euid = PerlProc_geteuid();
1506         }
1507         /* XXX $> et al currently silently ignore failures */
1508         if (PL_delaymagic & DM_GID) {
1509 #ifdef HAS_SETRESGID
1510             PERL_UNUSED_RESULT(
1511                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1512                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1513                           (Gid_t)-1));
1514 #else
1515 #  ifdef HAS_SETREGID
1516             PERL_UNUSED_RESULT(
1517                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1518                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1519 #  else
1520 #    ifdef HAS_SETRGID
1521             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1522                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1523                 PL_delaymagic &= ~DM_RGID;
1524             }
1525 #    endif /* HAS_SETRGID */
1526 #    ifdef HAS_SETEGID
1527             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1528                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1529                 PL_delaymagic &= ~DM_EGID;
1530             }
1531 #    endif /* HAS_SETEGID */
1532             if (PL_delaymagic & DM_GID) {
1533                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1534                     DIE(aTHX_ "No setregid available");
1535                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1536             }
1537 #  endif /* HAS_SETREGID */
1538 #endif /* HAS_SETRESGID */
1539
1540             tmp_gid  = PerlProc_getgid();
1541             tmp_egid = PerlProc_getegid();
1542         }
1543         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1544 #ifdef NO_TAINT_SUPPORT
1545         PERL_UNUSED_VAR(tmp_uid);
1546         PERL_UNUSED_VAR(tmp_euid);
1547         PERL_UNUSED_VAR(tmp_gid);
1548         PERL_UNUSED_VAR(tmp_egid);
1549 #endif
1550     }
1551     PL_delaymagic = old_delaymagic;
1552
1553     if (gimme == G_VOID)
1554         SP = firstrelem - 1;
1555     else if (gimme == G_SCALAR) {
1556         dTARGET;
1557         SP = firstrelem;
1558         SETi(lastrelem - firstrelem + 1);
1559     }
1560     else {
1561         if (ary || hash)
1562             /* note that in this case *firstlelem may have been overwritten
1563                by sv_undef in the odd hash case */
1564             SP = lastrelem;
1565         else {
1566             SP = firstrelem + (lastlelem - firstlelem);
1567             lelem = firstlelem + (relem - firstrelem);
1568             while (relem <= SP)
1569                 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1570         }
1571     }
1572
1573     RETURN;
1574 }
1575
1576 PP(pp_qr)
1577 {
1578     dSP;
1579     PMOP * const pm = cPMOP;
1580     REGEXP * rx = PM_GETRE(pm);
1581     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1582     SV * const rv = sv_newmortal();
1583     CV **cvp;
1584     CV *cv;
1585
1586     SvUPGRADE(rv, SVt_IV);
1587     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1588        loathe to use it here, but it seems to be the right fix. Or close.
1589        The key part appears to be that it's essential for pp_qr to return a new
1590        object (SV), which implies that there needs to be an effective way to
1591        generate a new SV from the existing SV that is pre-compiled in the
1592        optree.  */
1593     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1594     SvROK_on(rv);
1595
1596     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1597     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1598         *cvp = cv_clone(cv);
1599         SvREFCNT_dec_NN(cv);
1600     }
1601
1602     if (pkg) {
1603         HV *const stash = gv_stashsv(pkg, GV_ADD);
1604         SvREFCNT_dec_NN(pkg);
1605         (void)sv_bless(rv, stash);
1606     }
1607
1608     if (UNLIKELY(RX_ISTAINTED(rx))) {
1609         SvTAINTED_on(rv);
1610         SvTAINTED_on(SvRV(rv));
1611     }
1612     XPUSHs(rv);
1613     RETURN;
1614 }
1615
1616 PP(pp_match)
1617 {
1618     dSP; dTARG;
1619     PMOP *pm = cPMOP;
1620     PMOP *dynpm = pm;
1621     const char *s;
1622     const char *strend;
1623     SSize_t curpos = 0; /* initial pos() or current $+[0] */
1624     I32 global;
1625     U8 r_flags = 0;
1626     const char *truebase;                       /* Start of string  */
1627     REGEXP *rx = PM_GETRE(pm);
1628     bool rxtainted;
1629     const I32 gimme = GIMME_V;
1630     STRLEN len;
1631     const I32 oldsave = PL_savestack_ix;
1632     I32 had_zerolen = 0;
1633     MAGIC *mg = NULL;
1634
1635     if (PL_op->op_flags & OPf_STACKED)
1636         TARG = POPs;
1637     else if (ARGTARG)
1638         GETTARGET;
1639     else {
1640         TARG = DEFSV;
1641         EXTEND(SP,1);
1642     }
1643
1644     PUTBACK;                            /* EVAL blocks need stack_sp. */
1645     /* Skip get-magic if this is a qr// clone, because regcomp has
1646        already done it. */
1647     truebase = ReANY(rx)->mother_re
1648          ? SvPV_nomg_const(TARG, len)
1649          : SvPV_const(TARG, len);
1650     if (!truebase)
1651         DIE(aTHX_ "panic: pp_match");
1652     strend = truebase + len;
1653     rxtainted = (RX_ISTAINTED(rx) ||
1654                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1655     TAINT_NOT;
1656
1657     /* We need to know this in case we fail out early - pos() must be reset */
1658     global = dynpm->op_pmflags & PMf_GLOBAL;
1659
1660     /* PMdf_USED is set after a ?? matches once */
1661     if (
1662 #ifdef USE_ITHREADS
1663         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1664 #else
1665         pm->op_pmflags & PMf_USED
1666 #endif
1667     ) {
1668         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1669         goto nope;
1670     }
1671
1672     /* empty pattern special-cased to use last successful pattern if
1673        possible, except for qr// */
1674     if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1675      && PL_curpm) {
1676         pm = PL_curpm;
1677         rx = PM_GETRE(pm);
1678     }
1679
1680     if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1681         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1682                                               UVuf" < %"IVdf")\n",
1683                                               (UV)len, (IV)RX_MINLEN(rx)));
1684         goto nope;
1685     }
1686
1687     /* get pos() if //g */
1688     if (global) {
1689         mg = mg_find_mglob(TARG);
1690         if (mg && mg->mg_len >= 0) {
1691             curpos = MgBYTEPOS(mg, TARG, truebase, len);
1692             /* last time pos() was set, it was zero-length match */
1693             if (mg->mg_flags & MGf_MINMATCH)
1694                 had_zerolen = 1;
1695         }
1696     }
1697
1698 #ifdef PERL_SAWAMPERSAND
1699     if (       RX_NPARENS(rx)
1700             || PL_sawampersand
1701             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1702             || (dynpm->op_pmflags & PMf_KEEPCOPY)
1703     )
1704 #endif
1705     {
1706         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1707         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1708          * only on the first iteration. Therefore we need to copy $' as well
1709          * as $&, to make the rest of the string available for captures in
1710          * subsequent iterations */
1711         if (! (global && gimme == G_ARRAY))
1712             r_flags |= REXEC_COPY_SKIP_POST;
1713     };
1714 #ifdef PERL_SAWAMPERSAND
1715     if (dynpm->op_pmflags & PMf_KEEPCOPY)
1716         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1717         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1718 #endif
1719
1720     s = truebase;
1721
1722   play_it_again:
1723     if (global)
1724         s = truebase + curpos;
1725
1726     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1727                      had_zerolen, TARG, NULL, r_flags))
1728         goto nope;
1729
1730     PL_curpm = pm;
1731     if (dynpm->op_pmflags & PMf_ONCE)
1732 #ifdef USE_ITHREADS
1733         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1734 #else
1735         dynpm->op_pmflags |= PMf_USED;
1736 #endif
1737
1738     if (rxtainted)
1739         RX_MATCH_TAINTED_on(rx);
1740     TAINT_IF(RX_MATCH_TAINTED(rx));
1741
1742     /* update pos */
1743
1744     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1745         if (!mg)
1746             mg = sv_magicext_mglob(TARG);
1747         MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1748         if (RX_ZERO_LEN(rx))
1749             mg->mg_flags |= MGf_MINMATCH;
1750         else
1751             mg->mg_flags &= ~MGf_MINMATCH;
1752     }
1753
1754     if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1755         LEAVE_SCOPE(oldsave);
1756         RETPUSHYES;
1757     }
1758
1759     /* push captures on stack */
1760
1761     {
1762         const I32 nparens = RX_NPARENS(rx);
1763         I32 i = (global && !nparens) ? 1 : 0;
1764
1765         SPAGAIN;                        /* EVAL blocks could move the stack. */
1766         EXTEND(SP, nparens + i);
1767         EXTEND_MORTAL(nparens + i);
1768         for (i = !i; i <= nparens; i++) {
1769             PUSHs(sv_newmortal());
1770             if (LIKELY((RX_OFFS(rx)[i].start != -1)
1771                      && RX_OFFS(rx)[i].end   != -1 ))
1772             {
1773                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1774                 const char * const s = RX_OFFS(rx)[i].start + truebase;
1775                 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1776                         || len < 0 || len > strend - s))
1777                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1778                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1779                         (long) i, (long) RX_OFFS(rx)[i].start,
1780                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1781                 sv_setpvn(*SP, s, len);
1782                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1783                     SvUTF8_on(*SP);
1784             }
1785         }
1786         if (global) {
1787             curpos = (UV)RX_OFFS(rx)[0].end;
1788             had_zerolen = RX_ZERO_LEN(rx);
1789             PUTBACK;                    /* EVAL blocks may use stack */
1790             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1791             goto play_it_again;
1792         }
1793         LEAVE_SCOPE(oldsave);
1794         RETURN;
1795     }
1796     NOT_REACHED; /* NOTREACHED */
1797
1798   nope:
1799     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1800         if (!mg)
1801             mg = mg_find_mglob(TARG);
1802         if (mg)
1803             mg->mg_len = -1;
1804     }
1805     LEAVE_SCOPE(oldsave);
1806     if (gimme == G_ARRAY)
1807         RETURN;
1808     RETPUSHNO;
1809 }
1810
1811 OP *
1812 Perl_do_readline(pTHX)
1813 {
1814     dSP; dTARGETSTACKED;
1815     SV *sv;
1816     STRLEN tmplen = 0;
1817     STRLEN offset;
1818     PerlIO *fp;
1819     IO * const io = GvIO(PL_last_in_gv);
1820     const I32 type = PL_op->op_type;
1821     const I32 gimme = GIMME_V;
1822
1823     if (io) {
1824         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1825         if (mg) {
1826             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1827             if (gimme == G_SCALAR) {
1828                 SPAGAIN;
1829                 SvSetSV_nosteal(TARG, TOPs);
1830                 SETTARG;
1831             }
1832             return NORMAL;
1833         }
1834     }
1835     fp = NULL;
1836     if (io) {
1837         fp = IoIFP(io);
1838         if (!fp) {
1839             if (IoFLAGS(io) & IOf_ARGV) {
1840                 if (IoFLAGS(io) & IOf_START) {
1841                     IoLINES(io) = 0;
1842                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1843                         IoFLAGS(io) &= ~IOf_START;
1844                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1845                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1846                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1847                         SvSETMAGIC(GvSV(PL_last_in_gv));
1848                         fp = IoIFP(io);
1849                         goto have_fp;
1850                     }
1851                 }
1852                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1853                 if (!fp) { /* Note: fp != IoIFP(io) */
1854                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1855                 }
1856             }
1857             else if (type == OP_GLOB)
1858                 fp = Perl_start_glob(aTHX_ POPs, io);
1859         }
1860         else if (type == OP_GLOB)
1861             SP--;
1862         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1863             report_wrongway_fh(PL_last_in_gv, '>');
1864         }
1865     }
1866     if (!fp) {
1867         if ((!io || !(IoFLAGS(io) & IOf_START))
1868             && ckWARN(WARN_CLOSED)
1869             && type != OP_GLOB)
1870         {
1871             report_evil_fh(PL_last_in_gv);
1872         }
1873         if (gimme == G_SCALAR) {
1874             /* undef TARG, and push that undefined value */
1875             if (type != OP_RCATLINE) {
1876                 sv_setsv(TARG,NULL);
1877             }
1878             PUSHTARG;
1879         }
1880         RETURN;
1881     }
1882   have_fp:
1883     if (gimme == G_SCALAR) {
1884         sv = TARG;
1885         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1886             mg_get(sv);
1887         if (SvROK(sv)) {
1888             if (type == OP_RCATLINE)
1889                 SvPV_force_nomg_nolen(sv);
1890             else
1891                 sv_unref(sv);
1892         }
1893         else if (isGV_with_GP(sv)) {
1894             SvPV_force_nomg_nolen(sv);
1895         }
1896         SvUPGRADE(sv, SVt_PV);
1897         tmplen = SvLEN(sv);     /* remember if already alloced */
1898         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1899             /* try short-buffering it. Please update t/op/readline.t
1900              * if you change the growth length.
1901              */
1902             Sv_Grow(sv, 80);
1903         }
1904         offset = 0;
1905         if (type == OP_RCATLINE && SvOK(sv)) {
1906             if (!SvPOK(sv)) {
1907                 SvPV_force_nomg_nolen(sv);
1908             }
1909             offset = SvCUR(sv);
1910         }
1911     }
1912     else {
1913         sv = sv_2mortal(newSV(80));
1914         offset = 0;
1915     }
1916
1917     /* This should not be marked tainted if the fp is marked clean */
1918 #define MAYBE_TAINT_LINE(io, sv) \
1919     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1920         TAINT;                          \
1921         SvTAINTED_on(sv);               \
1922     }
1923
1924 /* delay EOF state for a snarfed empty file */
1925 #define SNARF_EOF(gimme,rs,io,sv) \
1926     (gimme != G_SCALAR || SvCUR(sv)                                     \
1927      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1928
1929     for (;;) {
1930         PUTBACK;
1931         if (!sv_gets(sv, fp, offset)
1932             && (type == OP_GLOB
1933                 || SNARF_EOF(gimme, PL_rs, io, sv)
1934                 || PerlIO_error(fp)))
1935         {
1936             PerlIO_clearerr(fp);
1937             if (IoFLAGS(io) & IOf_ARGV) {
1938                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1939                 if (fp)
1940                     continue;
1941                 (void)do_close(PL_last_in_gv, FALSE);
1942             }
1943             else if (type == OP_GLOB) {
1944                 if (!do_close(PL_last_in_gv, FALSE)) {
1945                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1946                                    "glob failed (child exited with status %d%s)",
1947                                    (int)(STATUS_CURRENT >> 8),
1948                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1949                 }
1950             }
1951             if (gimme == G_SCALAR) {
1952                 if (type != OP_RCATLINE) {
1953                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1954                     SvOK_off(TARG);
1955                 }
1956                 SPAGAIN;
1957                 PUSHTARG;
1958             }
1959             MAYBE_TAINT_LINE(io, sv);
1960             RETURN;
1961         }
1962         MAYBE_TAINT_LINE(io, sv);
1963         IoLINES(io)++;
1964         IoFLAGS(io) |= IOf_NOLINE;
1965         SvSETMAGIC(sv);
1966         SPAGAIN;
1967         XPUSHs(sv);
1968         if (type == OP_GLOB) {
1969             const char *t1;
1970             Stat_t statbuf;
1971
1972             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1973                 char * const tmps = SvEND(sv) - 1;
1974                 if (*tmps == *SvPVX_const(PL_rs)) {
1975                     *tmps = '\0';
1976                     SvCUR_set(sv, SvCUR(sv) - 1);
1977                 }
1978             }
1979             for (t1 = SvPVX_const(sv); *t1; t1++)
1980 #ifdef __VMS
1981                 if (strchr("*%?", *t1))
1982 #else
1983                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1984 #endif
1985                         break;
1986             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
1987                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1988                 continue;
1989             }
1990         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1991              if (ckWARN(WARN_UTF8)) {
1992                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1993                 const STRLEN len = SvCUR(sv) - offset;
1994                 const U8 *f;
1995
1996                 if (!is_utf8_string_loc(s, len, &f))
1997                     /* Emulate :encoding(utf8) warning in the same case. */
1998                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1999                                 "utf8 \"\\x%02X\" does not map to Unicode",
2000                                 f < (U8*)SvEND(sv) ? *f : 0);
2001              }
2002         }
2003         if (gimme == G_ARRAY) {
2004             if (SvLEN(sv) - SvCUR(sv) > 20) {
2005                 SvPV_shrink_to_cur(sv);
2006             }
2007             sv = sv_2mortal(newSV(80));
2008             continue;
2009         }
2010         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2011             /* try to reclaim a bit of scalar space (only on 1st alloc) */
2012             const STRLEN new_len
2013                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2014             SvPV_renew(sv, new_len);
2015         }
2016         RETURN;
2017     }
2018 }
2019
2020 PP(pp_helem)
2021 {
2022     dSP;
2023     HE* he;
2024     SV **svp;
2025     SV * const keysv = POPs;
2026     HV * const hv = MUTABLE_HV(POPs);
2027     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2028     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2029     SV *sv;
2030     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2031     bool preeminent = TRUE;
2032
2033     if (SvTYPE(hv) != SVt_PVHV)
2034         RETPUSHUNDEF;
2035
2036     if (localizing) {
2037         MAGIC *mg;
2038         HV *stash;
2039
2040         /* If we can determine whether the element exist,
2041          * Try to preserve the existenceness of a tied hash
2042          * element by using EXISTS and DELETE if possible.
2043          * Fallback to FETCH and STORE otherwise. */
2044         if (SvCANEXISTDELETE(hv))
2045             preeminent = hv_exists_ent(hv, keysv, 0);
2046     }
2047
2048     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2049     svp = he ? &HeVAL(he) : NULL;
2050     if (lval) {
2051         if (!svp || !*svp || *svp == &PL_sv_undef) {
2052             SV* lv;
2053             SV* key2;
2054             if (!defer) {
2055                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2056             }
2057             lv = sv_newmortal();
2058             sv_upgrade(lv, SVt_PVLV);
2059             LvTYPE(lv) = 'y';
2060             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2061             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
2062             LvTARG(lv) = SvREFCNT_inc_simple(hv);
2063             LvTARGLEN(lv) = 1;
2064             PUSHs(lv);
2065             RETURN;
2066         }
2067         if (localizing) {
2068             if (HvNAME_get(hv) && isGV(*svp))
2069                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2070             else if (preeminent)
2071                 save_helem_flags(hv, keysv, svp,
2072                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2073             else
2074                 SAVEHDELETE(hv, keysv);
2075         }
2076         else if (PL_op->op_private & OPpDEREF) {
2077             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2078             RETURN;
2079         }
2080     }
2081     sv = (svp && *svp ? *svp : &PL_sv_undef);
2082     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2083      * was to make C<local $tied{foo} = $tied{foo}> possible.
2084      * However, it seems no longer to be needed for that purpose, and
2085      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2086      * would loop endlessly since the pos magic is getting set on the
2087      * mortal copy and lost. However, the copy has the effect of
2088      * triggering the get magic, and losing it altogether made things like
2089      * c<$tied{foo};> in void context no longer do get magic, which some
2090      * code relied on. Also, delayed triggering of magic on @+ and friends
2091      * meant the original regex may be out of scope by now. So as a
2092      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2093      * being called too many times). */
2094     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2095         mg_get(sv);
2096     PUSHs(sv);
2097     RETURN;
2098 }
2099
2100
2101 /* a stripped-down version of Perl_softref2xv() for use by
2102  * pp_multideref(), which doesn't use PL_op->op_flags */
2103
2104 GV *
2105 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2106                 const svtype type)
2107 {
2108     if (PL_op->op_private & HINT_STRICT_REFS) {
2109         if (SvOK(sv))
2110             Perl_die(aTHX_ PL_no_symref_sv, sv,
2111                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2112         else
2113             Perl_die(aTHX_ PL_no_usym, what);
2114     }
2115     if (!SvOK(sv))
2116         Perl_die(aTHX_ PL_no_usym, what);
2117     return gv_fetchsv_nomg(sv, GV_ADD, type);
2118 }
2119
2120
2121 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2122  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
2123  *
2124  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2125  * Each of these either contains a set of actions, or an argument, such as
2126  * an IV to use as an array index, or a lexical var to retrieve.
2127  * Several actions re stored per UV; we keep shifting new actions off the
2128  * one UV, and only reload when it becomes zero.
2129  */
2130
2131 PP(pp_multideref)
2132 {
2133     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2134     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2135     UV actions = items->uv;
2136
2137     assert(actions);
2138     /* this tells find_uninit_var() where we're up to */
2139     PL_multideref_pc = items;
2140
2141     while (1) {
2142         /* there are three main classes of action; the first retrieve
2143          * the initial AV or HV from a variable or the stack; the second
2144          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2145          * the third an unrolled (/DREFHV, rv2hv, helem).
2146          */
2147         switch (actions & MDEREF_ACTION_MASK) {
2148
2149         case MDEREF_reload:
2150             actions = (++items)->uv;
2151             continue;
2152
2153         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
2154             sv = PAD_SVl((++items)->pad_offset);
2155             goto do_AV_aelem;
2156
2157         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
2158             sv = UNOP_AUX_item_sv(++items);
2159             assert(isGV_with_GP(sv));
2160             sv = (SV*)GvAVn((GV*)sv);
2161             goto do_AV_aelem;
2162
2163         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
2164             {
2165                 dSP;
2166                 sv = POPs;
2167                 PUTBACK;
2168                 goto do_AV_rv2av_aelem;
2169             }
2170
2171         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
2172             sv = UNOP_AUX_item_sv(++items);
2173             assert(isGV_with_GP(sv));
2174             sv = GvSVn((GV*)sv);
2175             goto do_AV_vivify_rv2av_aelem;
2176
2177         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
2178             sv = PAD_SVl((++items)->pad_offset);
2179             /* FALLTHROUGH */
2180
2181         do_AV_vivify_rv2av_aelem:
2182         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
2183             /* this is the OPpDEREF action normally found at the end of
2184              * ops like aelem, helem, rv2sv */
2185             sv = vivify_ref(sv, OPpDEREF_AV);
2186             /* FALLTHROUGH */
2187
2188         do_AV_rv2av_aelem:
2189             /* this is basically a copy of pp_rv2av when it just has the
2190              * sKR/1 flags */
2191             SvGETMAGIC(sv);
2192             if (LIKELY(SvROK(sv))) {
2193                 if (UNLIKELY(SvAMAGIC(sv))) {
2194                     sv = amagic_deref_call(sv, to_av_amg);
2195                 }
2196                 sv = SvRV(sv);
2197                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2198                     DIE(aTHX_ "Not an ARRAY reference");
2199             }
2200             else if (SvTYPE(sv) != SVt_PVAV) {
2201                 if (!isGV_with_GP(sv))
2202                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2203                 sv = MUTABLE_SV(GvAVn((GV*)sv));
2204             }
2205             /* FALLTHROUGH */
2206
2207         do_AV_aelem:
2208             {
2209                 /* retrieve the key; this may be either a lexical or package
2210                  * var (whose index/ptr is stored as an item) or a signed
2211                  * integer constant stored as an item.
2212                  */
2213                 SV *elemsv;
2214                 IV elem = 0; /* to shut up stupid compiler warnings */
2215
2216
2217                 assert(SvTYPE(sv) == SVt_PVAV);
2218
2219                 switch (actions & MDEREF_INDEX_MASK) {
2220                 case MDEREF_INDEX_none:
2221                     goto finish;
2222                 case MDEREF_INDEX_const:
2223                     elem  = (++items)->iv;
2224                     break;
2225                 case MDEREF_INDEX_padsv:
2226                     elemsv = PAD_SVl((++items)->pad_offset);
2227                     goto check_elem;
2228                 case MDEREF_INDEX_gvsv:
2229                     elemsv = UNOP_AUX_item_sv(++items);
2230                     assert(isGV_with_GP(elemsv));
2231                     elemsv = GvSVn((GV*)elemsv);
2232                 check_elem:
2233                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2234                                             && ckWARN(WARN_MISC)))
2235                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2236                                 "Use of reference \"%"SVf"\" as array index",
2237                                 SVfARG(elemsv));
2238                     /* the only time that S_find_uninit_var() needs this
2239                      * is to determine which index value triggered the
2240                      * undef warning. So just update it here. Note that
2241                      * since we don't save and restore this var (e.g. for
2242                      * tie or overload execution), its value will be
2243                      * meaningless apart from just here */
2244                     PL_multideref_pc = items;
2245                     elem = SvIV(elemsv);
2246                     break;
2247                 }
2248
2249
2250                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2251
2252                 if (!(actions & MDEREF_FLAG_last)) {
2253                     SV** svp = av_fetch((AV*)sv, elem, 1);
2254                     if (!svp || ! (sv=*svp))
2255                         DIE(aTHX_ PL_no_aelem, elem);
2256                     break;
2257                 }
2258
2259                 if (PL_op->op_private &
2260                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2261                 {
2262                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2263                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2264                     }
2265                     else {
2266                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2267                         sv = av_delete((AV*)sv, elem, discard);
2268                         if (discard)
2269                             return NORMAL;
2270                         if (!sv)
2271                             sv = &PL_sv_undef;
2272                     }
2273                 }
2274                 else {
2275                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2276                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2277                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2278                     bool preeminent = TRUE;
2279                     AV *const av = (AV*)sv;
2280                     SV** svp;
2281
2282                     if (UNLIKELY(localizing)) {
2283                         MAGIC *mg;
2284                         HV *stash;
2285
2286                         /* If we can determine whether the element exist,
2287                          * Try to preserve the existenceness of a tied array
2288                          * element by using EXISTS and DELETE if possible.
2289                          * Fallback to FETCH and STORE otherwise. */
2290                         if (SvCANEXISTDELETE(av))
2291                             preeminent = av_exists(av, elem);
2292                     }
2293
2294                     svp = av_fetch(av, elem, lval && !defer);
2295
2296                     if (lval) {
2297                         if (!svp || !(sv = *svp)) {
2298                             IV len;
2299                             if (!defer)
2300                                 DIE(aTHX_ PL_no_aelem, elem);
2301                             len = av_tindex(av);
2302                             sv = sv_2mortal(newSVavdefelem(av,
2303                             /* Resolve a negative index now, unless it points
2304                              * before the beginning of the array, in which
2305                              * case record it for error reporting in
2306                              * magic_setdefelem. */
2307                                 elem < 0 && len + elem >= 0
2308                                     ? len + elem : elem, 1));
2309                         }
2310                         else {
2311                             if (UNLIKELY(localizing)) {
2312                                 if (preeminent) {
2313                                     save_aelem(av, elem, svp);
2314                                     sv = *svp; /* may have changed */
2315                                 }
2316                                 else
2317                                     SAVEADELETE(av, elem);
2318                             }
2319                         }
2320                     }
2321                     else {
2322                         sv = (svp ? *svp : &PL_sv_undef);
2323                         /* see note in pp_helem() */
2324                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2325                             mg_get(sv);
2326                     }
2327                 }
2328
2329             }
2330           finish:
2331             {
2332                 dSP;
2333                 XPUSHs(sv);
2334                 RETURN;
2335             }
2336             /* NOTREACHED */
2337
2338
2339
2340
2341         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
2342             sv = PAD_SVl((++items)->pad_offset);
2343             goto do_HV_helem;
2344
2345         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
2346             sv = UNOP_AUX_item_sv(++items);
2347             assert(isGV_with_GP(sv));
2348             sv = (SV*)GvHVn((GV*)sv);
2349             goto do_HV_helem;
2350
2351         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
2352             {
2353                 dSP;
2354                 sv = POPs;
2355                 PUTBACK;
2356                 goto do_HV_rv2hv_helem;
2357             }
2358
2359         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
2360             sv = UNOP_AUX_item_sv(++items);
2361             assert(isGV_with_GP(sv));
2362             sv = GvSVn((GV*)sv);
2363             goto do_HV_vivify_rv2hv_helem;
2364
2365         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
2366             sv = PAD_SVl((++items)->pad_offset);
2367             /* FALLTHROUGH */
2368
2369         do_HV_vivify_rv2hv_helem:
2370         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
2371             /* this is the OPpDEREF action normally found at the end of
2372              * ops like aelem, helem, rv2sv */
2373             sv = vivify_ref(sv, OPpDEREF_HV);
2374             /* FALLTHROUGH */
2375
2376         do_HV_rv2hv_helem:
2377             /* this is basically a copy of pp_rv2hv when it just has the
2378              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2379
2380             SvGETMAGIC(sv);
2381             if (LIKELY(SvROK(sv))) {
2382                 if (UNLIKELY(SvAMAGIC(sv))) {
2383                     sv = amagic_deref_call(sv, to_hv_amg);
2384                 }
2385                 sv = SvRV(sv);
2386                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2387                     DIE(aTHX_ "Not a HASH reference");
2388             }
2389             else if (SvTYPE(sv) != SVt_PVHV) {
2390                 if (!isGV_with_GP(sv))
2391                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2392                 sv = MUTABLE_SV(GvHVn((GV*)sv));
2393             }
2394             /* FALLTHROUGH */
2395
2396         do_HV_helem:
2397             {
2398                 /* retrieve the key; this may be either a lexical / package
2399                  * var or a string constant, whose index/ptr is stored as an
2400                  * item
2401                  */
2402                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2403
2404                 assert(SvTYPE(sv) == SVt_PVHV);
2405
2406                 switch (actions & MDEREF_INDEX_MASK) {
2407                 case MDEREF_INDEX_none:
2408                     goto finish;
2409
2410                 case MDEREF_INDEX_const:
2411                     keysv = UNOP_AUX_item_sv(++items);
2412                     break;
2413
2414                 case MDEREF_INDEX_padsv:
2415                     keysv = PAD_SVl((++items)->pad_offset);
2416                     break;
2417
2418                 case MDEREF_INDEX_gvsv:
2419                     keysv = UNOP_AUX_item_sv(++items);
2420                     keysv = GvSVn((GV*)keysv);
2421                     break;
2422                 }
2423
2424                 /* see comment above about setting this var */
2425                 PL_multideref_pc = items;
2426
2427
2428                 /* ensure that candidate CONSTs have been HEKified */
2429                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2430                        || SvTYPE(keysv) >= SVt_PVMG
2431                        || !SvOK(keysv)
2432                        || SvROK(keysv)
2433                        || SvIsCOW_shared_hash(keysv));
2434
2435                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2436
2437                 if (!(actions & MDEREF_FLAG_last)) {
2438                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2439                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2440                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2441                     break;
2442                 }
2443
2444                 if (PL_op->op_private &
2445                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2446                 {
2447                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2448                         sv = hv_exists_ent((HV*)sv, keysv, 0)
2449                                                 ? &PL_sv_yes : &PL_sv_no;
2450                     }
2451                     else {
2452                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2453                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2454                         if (discard)
2455                             return NORMAL;
2456                         if (!sv)
2457                             sv = &PL_sv_undef;
2458                     }
2459                 }
2460                 else {
2461                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2462                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2463                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2464                     bool preeminent = TRUE;
2465                     SV **svp;
2466                     HV * const hv = (HV*)sv;
2467                     HE* he;
2468
2469                     if (UNLIKELY(localizing)) {
2470                         MAGIC *mg;
2471                         HV *stash;
2472
2473                         /* If we can determine whether the element exist,
2474                          * Try to preserve the existenceness of a tied hash
2475                          * element by using EXISTS and DELETE if possible.
2476                          * Fallback to FETCH and STORE otherwise. */
2477                         if (SvCANEXISTDELETE(hv))
2478                             preeminent = hv_exists_ent(hv, keysv, 0);
2479                     }
2480
2481                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2482                     svp = he ? &HeVAL(he) : NULL;
2483
2484
2485                     if (lval) {
2486                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2487                             SV* lv;
2488                             SV* key2;
2489                             if (!defer)
2490                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2491                             lv = sv_newmortal();
2492                             sv_upgrade(lv, SVt_PVLV);
2493                             LvTYPE(lv) = 'y';
2494                             sv_magic(lv, key2 = newSVsv(keysv),
2495                                                 PERL_MAGIC_defelem, NULL, 0);
2496                             /* sv_magic() increments refcount */
2497                             SvREFCNT_dec_NN(key2);
2498                             LvTARG(lv) = SvREFCNT_inc_simple(hv);
2499                             LvTARGLEN(lv) = 1;
2500                             sv = lv;
2501                         }
2502                         else {
2503                             if (localizing) {
2504                                 if (HvNAME_get(hv) && isGV(sv))
2505                                     save_gp(MUTABLE_GV(sv),
2506                                         !(PL_op->op_flags & OPf_SPECIAL));
2507                                 else if (preeminent) {
2508                                     save_helem_flags(hv, keysv, svp,
2509                                          (PL_op->op_flags & OPf_SPECIAL)
2510                                             ? 0 : SAVEf_SETMAGIC);
2511                                     sv = *svp; /* may have changed */
2512                                 }
2513                                 else
2514                                     SAVEHDELETE(hv, keysv);
2515                             }
2516                         }
2517                     }
2518                     else {
2519                         sv = (svp && *svp ? *svp : &PL_sv_undef);
2520                         /* see note in pp_helem() */
2521                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2522                             mg_get(sv);
2523                     }
2524                 }
2525                 goto finish;
2526             }
2527
2528         } /* switch */
2529
2530         actions >>= MDEREF_SHIFT;
2531     } /* while */
2532     /* NOTREACHED */
2533 }
2534
2535
2536 PP(pp_iter)
2537 {
2538     dSP;
2539     PERL_CONTEXT *cx;
2540     SV *oldsv;
2541     SV **itersvp;
2542
2543     EXTEND(SP, 1);
2544     cx = &cxstack[cxstack_ix];
2545     itersvp = CxITERVAR(cx);
2546
2547     switch (CxTYPE(cx)) {
2548
2549     case CXt_LOOP_LAZYSV: /* string increment */
2550     {
2551         SV* cur = cx->blk_loop.state_u.lazysv.cur;
2552         SV *end = cx->blk_loop.state_u.lazysv.end;
2553         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2554            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
2555         STRLEN maxlen = 0;
2556         const char *max = SvPV_const(end, maxlen);
2557         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2558             RETPUSHNO;
2559
2560         oldsv = *itersvp;
2561         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2562             /* safe to reuse old SV */
2563             sv_setsv(oldsv, cur);
2564         }
2565         else
2566         {
2567             /* we need a fresh SV every time so that loop body sees a
2568              * completely new SV for closures/references to work as
2569              * they used to */
2570             *itersvp = newSVsv(cur);
2571             SvREFCNT_dec_NN(oldsv);
2572         }
2573         if (strEQ(SvPVX_const(cur), max))
2574             sv_setiv(cur, 0); /* terminate next time */
2575         else
2576             sv_inc(cur);
2577         break;
2578     }
2579
2580     case CXt_LOOP_LAZYIV: /* integer increment */
2581     {
2582         IV cur = cx->blk_loop.state_u.lazyiv.cur;
2583         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2584             RETPUSHNO;
2585
2586         oldsv = *itersvp;
2587         /* don't risk potential race */
2588         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2589             /* safe to reuse old SV */
2590             sv_setiv(oldsv, cur);
2591         }
2592         else
2593         {
2594             /* we need a fresh SV every time so that loop body sees a
2595              * completely new SV for closures/references to work as they
2596              * used to */
2597             *itersvp = newSViv(cur);
2598             SvREFCNT_dec_NN(oldsv);
2599         }
2600
2601         if (UNLIKELY(cur == IV_MAX)) {
2602             /* Handle end of range at IV_MAX */
2603             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2604         } else
2605             ++cx->blk_loop.state_u.lazyiv.cur;
2606         break;
2607     }
2608
2609     case CXt_LOOP_FOR: /* iterate array */
2610     {
2611
2612         AV *av = cx->blk_loop.state_u.ary.ary;
2613         SV *sv;
2614         bool av_is_stack = FALSE;
2615         IV ix;
2616
2617         if (!av) {
2618             av_is_stack = TRUE;
2619             av = PL_curstack;
2620         }
2621         if (PL_op->op_private & OPpITER_REVERSED) {
2622             ix = --cx->blk_loop.state_u.ary.ix;
2623             if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
2624                 RETPUSHNO;
2625         }
2626         else {
2627             ix = ++cx->blk_loop.state_u.ary.ix;
2628             if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
2629                 RETPUSHNO;
2630         }
2631
2632         if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
2633             SV * const * const svp = av_fetch(av, ix, FALSE);
2634             sv = svp ? *svp : NULL;
2635         }
2636         else {
2637             sv = AvARRAY(av)[ix];
2638         }
2639
2640         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2641             SvSetMagicSV(*itersvp, sv);
2642             break;
2643         }
2644
2645         if (LIKELY(sv)) {
2646             if (UNLIKELY(SvIS_FREED(sv))) {
2647                 *itersvp = NULL;
2648                 Perl_croak(aTHX_ "Use of freed value in iteration");
2649             }
2650             if (SvPADTMP(sv)) {
2651                 sv = newSVsv(sv);
2652             }
2653             else {
2654                 SvTEMP_off(sv);
2655                 SvREFCNT_inc_simple_void_NN(sv);
2656             }
2657         }
2658         else if (!av_is_stack) {
2659             sv = newSVavdefelem(av, ix, 0);
2660         }
2661         else
2662             sv = &PL_sv_undef;
2663
2664         oldsv = *itersvp;
2665         *itersvp = sv;
2666         SvREFCNT_dec(oldsv);
2667         break;
2668     }
2669
2670     default:
2671         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2672     }
2673     RETPUSHYES;
2674 }
2675
2676 /*
2677 A description of how taint works in pattern matching and substitution.
2678
2679 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2680 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2681
2682 While the pattern is being assembled/concatenated and then compiled,
2683 PL_tainted will get set (via TAINT_set) if any component of the pattern
2684 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
2685 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2686 TAINT_get).  It will also be set if any component of the pattern matches
2687 based on locale-dependent behavior.
2688
2689 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2690 the pattern is marked as tainted. This means that subsequent usage, such
2691 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2692 on the new pattern too.
2693
2694 RXf_TAINTED_SEEN is used post-execution by the get magic code
2695 of $1 et al to indicate whether the returned value should be tainted.
2696 It is the responsibility of the caller of the pattern (i.e. pp_match,
2697 pp_subst etc) to set this flag for any other circumstances where $1 needs
2698 to be tainted.
2699
2700 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2701
2702 There are three possible sources of taint
2703     * the source string
2704     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2705     * the replacement string (or expression under /e)
2706
2707 There are four destinations of taint and they are affected by the sources
2708 according to the rules below:
2709
2710     * the return value (not including /r):
2711         tainted by the source string and pattern, but only for the
2712         number-of-iterations case; boolean returns aren't tainted;
2713     * the modified string (or modified copy under /r):
2714         tainted by the source string, pattern, and replacement strings;
2715     * $1 et al:
2716         tainted by the pattern, and under 'use re "taint"', by the source
2717         string too;
2718     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2719         should always be unset before executing subsequent code.
2720
2721 The overall action of pp_subst is:
2722
2723     * at the start, set bits in rxtainted indicating the taint status of
2724         the various sources.
2725
2726     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2727         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2728         pattern has subsequently become tainted via locale ops.
2729
2730     * If control is being passed to pp_substcont to execute a /e block,
2731         save rxtainted in the CXt_SUBST block, for future use by
2732         pp_substcont.
2733
2734     * Whenever control is being returned to perl code (either by falling
2735         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2736         use the flag bits in rxtainted to make all the appropriate types of
2737         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2738         et al will appear tainted.
2739
2740 pp_match is just a simpler version of the above.
2741
2742 */
2743
2744 PP(pp_subst)
2745 {
2746     dSP; dTARG;
2747     PMOP *pm = cPMOP;
2748     PMOP *rpm = pm;
2749     char *s;
2750     char *strend;
2751     const char *c;
2752     STRLEN clen;
2753     SSize_t iters = 0;
2754     SSize_t maxiters;
2755     bool once;
2756     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2757                         See "how taint works" above */
2758     char *orig;
2759     U8 r_flags;
2760     REGEXP *rx = PM_GETRE(pm);
2761     STRLEN len;
2762     int force_on_match = 0;
2763     const I32 oldsave = PL_savestack_ix;
2764     STRLEN slen;
2765     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2766 #ifdef PERL_ANY_COW
2767     bool is_cow;
2768 #endif
2769     SV *nsv = NULL;
2770     /* known replacement string? */
2771     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2772
2773     PERL_ASYNC_CHECK();
2774
2775     if (PL_op->op_flags & OPf_STACKED)
2776         TARG = POPs;
2777     else if (ARGTARG)
2778         GETTARGET;
2779     else {
2780         TARG = DEFSV;
2781         EXTEND(SP,1);
2782     }
2783
2784     SvGETMAGIC(TARG); /* must come before cow check */
2785 #ifdef PERL_ANY_COW
2786     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2787        because they make integers such as 256 "false".  */
2788     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2789 #else
2790     if (SvIsCOW(TARG))
2791         sv_force_normal_flags(TARG,0);
2792 #endif
2793     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2794         && (SvREADONLY(TARG)
2795             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2796                   || SvTYPE(TARG) > SVt_PVLV)
2797                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2798         Perl_croak_no_modify();
2799     PUTBACK;
2800
2801     orig = SvPV_nomg(TARG, len);
2802     /* note we don't (yet) force the var into being a string; if we fail
2803      * to match, we leave as-is; on successful match howeverm, we *will*
2804      * coerce into a string, then repeat the match */
2805     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2806         force_on_match = 1;
2807
2808     /* only replace once? */
2809     once = !(rpm->op_pmflags & PMf_GLOBAL);
2810
2811     /* See "how taint works" above */
2812     if (TAINTING_get) {
2813         rxtainted  = (
2814             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2815           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2816           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2817           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2818                 ? SUBST_TAINT_BOOLRET : 0));
2819         TAINT_NOT;
2820     }
2821
2822   force_it:
2823     if (!pm || !orig)
2824         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2825
2826     strend = orig + len;
2827     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2828     maxiters = 2 * slen + 10;   /* We can match twice at each
2829                                    position, once with zero-length,
2830                                    second time with non-zero. */
2831
2832     if (!RX_PRELEN(rx) && PL_curpm
2833      && !ReANY(rx)->mother_re) {
2834         pm = PL_curpm;
2835         rx = PM_GETRE(pm);
2836     }
2837
2838 #ifdef PERL_SAWAMPERSAND
2839     r_flags = (    RX_NPARENS(rx)
2840                 || PL_sawampersand
2841                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2842                 || (rpm->op_pmflags & PMf_KEEPCOPY)
2843               )
2844           ? REXEC_COPY_STR
2845           : 0;
2846 #else
2847     r_flags = REXEC_COPY_STR;
2848 #endif
2849
2850     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2851     {
2852         SPAGAIN;
2853         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2854         LEAVE_SCOPE(oldsave);
2855         RETURN;
2856     }
2857     PL_curpm = pm;
2858
2859     /* known replacement string? */
2860     if (dstr) {
2861         /* replacement needing upgrading? */
2862         if (DO_UTF8(TARG) && !doutf8) {
2863              nsv = sv_newmortal();
2864              SvSetSV(nsv, dstr);
2865              if (IN_ENCODING)
2866                   sv_recode_to_utf8(nsv, _get_encoding());
2867              else
2868                   sv_utf8_upgrade(nsv);
2869              c = SvPV_const(nsv, clen);
2870              doutf8 = TRUE;
2871         }
2872         else {
2873             c = SvPV_const(dstr, clen);
2874             doutf8 = DO_UTF8(dstr);
2875         }
2876
2877         if (SvTAINTED(dstr))
2878             rxtainted |= SUBST_TAINT_REPL;
2879     }
2880     else {
2881         c = NULL;
2882         doutf8 = FALSE;
2883     }
2884
2885     /* can do inplace substitution? */
2886     if (c
2887 #ifdef PERL_ANY_COW
2888         && !is_cow
2889 #endif
2890         && (I32)clen <= RX_MINLENRET(rx)
2891         && (  once
2892            || !(r_flags & REXEC_COPY_STR)
2893            || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2894            )
2895         && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2896         && (!doutf8 || SvUTF8(TARG))
2897         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2898     {
2899
2900 #ifdef PERL_ANY_COW
2901         if (SvIsCOW(TARG)) {
2902           if (!force_on_match)
2903             goto have_a_cow;
2904           assert(SvVOK(TARG));
2905         }
2906 #endif
2907         if (force_on_match) {
2908             /* redo the first match, this time with the orig var
2909              * forced into being a string */
2910             force_on_match = 0;
2911             orig = SvPV_force_nomg(TARG, len);
2912             goto force_it;
2913         }
2914
2915         if (once) {
2916             char *d, *m;
2917             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2918                 rxtainted |= SUBST_TAINT_PAT;
2919             m = orig + RX_OFFS(rx)[0].start;
2920             d = orig + RX_OFFS(rx)[0].end;
2921             s = orig;
2922             if (m - s > strend - d) {  /* faster to shorten from end */
2923                 I32 i;
2924                 if (clen) {
2925                     Copy(c, m, clen, char);
2926                     m += clen;
2927                 }
2928                 i = strend - d;
2929                 if (i > 0) {
2930                     Move(d, m, i, char);
2931                     m += i;
2932                 }
2933                 *m = '\0';
2934                 SvCUR_set(TARG, m - s);
2935             }
2936             else {      /* faster from front */
2937                 I32 i = m - s;
2938                 d -= clen;
2939                 if (i > 0)
2940                     Move(s, d - i, i, char);
2941                 sv_chop(TARG, d-i);
2942                 if (clen)
2943                     Copy(c, d, clen, char);
2944             }
2945             SPAGAIN;
2946             PUSHs(&PL_sv_yes);
2947         }
2948         else {
2949             char *d, *m;
2950             d = s = RX_OFFS(rx)[0].start + orig;
2951             do {
2952                 I32 i;
2953                 if (UNLIKELY(iters++ > maxiters))
2954                     DIE(aTHX_ "Substitution loop");
2955                 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2956                     rxtainted |= SUBST_TAINT_PAT;
2957                 m = RX_OFFS(rx)[0].start + orig;
2958                 if ((i = m - s)) {
2959                     if (s != d)
2960                         Move(s, d, i, char);
2961                     d += i;
2962                 }
2963                 if (clen) {
2964                     Copy(c, d, clen, char);
2965                     d += clen;
2966                 }
2967                 s = RX_OFFS(rx)[0].end + orig;
2968             } while (CALLREGEXEC(rx, s, strend, orig,
2969                                  s == m, /* don't match same null twice */
2970                                  TARG, NULL,
2971                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2972             if (s != d) {
2973                 I32 i = strend - s;
2974                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2975                 Move(s, d, i+1, char);          /* include the NUL */
2976             }
2977             SPAGAIN;
2978             mPUSHi(iters);
2979         }
2980     }
2981     else {
2982         bool first;
2983         char *m;
2984         SV *repl;
2985         if (force_on_match) {
2986             /* redo the first match, this time with the orig var
2987              * forced into being a string */
2988             force_on_match = 0;
2989             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2990                 /* I feel that it should be possible to avoid this mortal copy
2991                    given that the code below copies into a new destination.
2992                    However, I suspect it isn't worth the complexity of
2993                    unravelling the C<goto force_it> for the small number of
2994                    cases where it would be viable to drop into the copy code. */
2995                 TARG = sv_2mortal(newSVsv(TARG));
2996             }
2997             orig = SvPV_force_nomg(TARG, len);
2998             goto force_it;
2999         }
3000 #ifdef PERL_ANY_COW
3001       have_a_cow:
3002 #endif
3003         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
3004             rxtainted |= SUBST_TAINT_PAT;
3005         repl = dstr;
3006         s = RX_OFFS(rx)[0].start + orig;
3007         dstr = newSVpvn_flags(orig, s-orig,
3008                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3009         if (!c) {
3010             PERL_CONTEXT *cx;
3011             SPAGAIN;
3012             m = orig;
3013             /* note that a whole bunch of local vars are saved here for
3014              * use by pp_substcont: here's a list of them in case you're
3015              * searching for places in this sub that uses a particular var:
3016              * iters maxiters r_flags oldsave rxtainted orig dstr targ
3017              * s m strend rx once */
3018             PUSHSUBST(cx);
3019             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3020         }
3021         first = TRUE;
3022         do {
3023             if (UNLIKELY(iters++ > maxiters))
3024                 DIE(aTHX_ "Substitution loop");
3025             if (UNLIKELY(RX_MATCH_TAINTED(rx)))
3026                 rxtainted |= SUBST_TAINT_PAT;
3027             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
3028                 char *old_s    = s;
3029                 char *old_orig = orig;
3030                 assert(RX_SUBOFFSET(rx) == 0);
3031
3032                 orig = RX_SUBBEG(rx);
3033                 s = orig + (old_s - old_orig);
3034                 strend = s + (strend - old_s);
3035             }
3036             m = RX_OFFS(rx)[0].start + orig;
3037             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3038             s = RX_OFFS(rx)[0].end + orig;
3039             if (first) {
3040                 /* replacement already stringified */
3041               if (clen)
3042                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3043               first = FALSE;
3044             }
3045             else {
3046                 if (IN_ENCODING) {
3047                     if (!nsv) nsv = sv_newmortal();
3048                     sv_copypv(nsv, repl);
3049                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
3050                     sv_catsv(dstr, nsv);
3051                 }
3052                 else sv_catsv(dstr, repl);
3053                 if (UNLIKELY(SvTAINTED(repl)))
3054                     rxtainted |= SUBST_TAINT_REPL;
3055             }
3056             if (once)
3057                 break;
3058         } while (CALLREGEXEC(rx, s, strend, orig,
3059                              s == m,    /* Yields minend of 0 or 1 */
3060                              TARG, NULL,
3061                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3062         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3063
3064         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3065             /* From here on down we're using the copy, and leaving the original
3066                untouched.  */
3067             TARG = dstr;
3068             SPAGAIN;
3069             PUSHs(dstr);
3070         } else {
3071 #ifdef PERL_ANY_COW
3072             /* The match may make the string COW. If so, brilliant, because
3073                that's just saved us one malloc, copy and free - the regexp has
3074                donated the old buffer, and we malloc an entirely new one, rather
3075                than the regexp malloc()ing a buffer and copying our original,
3076                only for us to throw it away here during the substitution.  */
3077             if (SvIsCOW(TARG)) {
3078                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3079             } else
3080 #endif
3081             {
3082                 SvPV_free(TARG);
3083             }
3084             SvPV_set(TARG, SvPVX(dstr));
3085             SvCUR_set(TARG, SvCUR(dstr));
3086             SvLEN_set(TARG, SvLEN(dstr));
3087             SvFLAGS(TARG) |= SvUTF8(dstr);
3088             SvPV_set(dstr, NULL);
3089
3090             SPAGAIN;
3091             mPUSHi(iters);
3092         }
3093     }
3094
3095     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3096         (void)SvPOK_only_UTF8(TARG);
3097     }
3098
3099     /* See "how taint works" above */
3100     if (TAINTING_get) {
3101         if ((rxtainted & SUBST_TAINT_PAT) ||
3102             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3103                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3104         )
3105             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
3106
3107         if (!(rxtainted & SUBST_TAINT_BOOLRET)
3108             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3109         )
3110             SvTAINTED_on(TOPs);  /* taint return value */
3111         else
3112             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
3113
3114         /* needed for mg_set below */
3115         TAINT_set(
3116           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3117         );
3118         SvTAINT(TARG);
3119     }
3120     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3121     TAINT_NOT;
3122     LEAVE_SCOPE(oldsave);
3123     RETURN;
3124 }
3125
3126 PP(pp_grepwhile)
3127 {
3128     dSP;
3129
3130     if (SvTRUEx(POPs))
3131         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3132     ++*PL_markstack_ptr;
3133     FREETMPS;
3134     LEAVE_with_name("grep_item");                                       /* exit inner scope */
3135
3136     /* All done yet? */
3137     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3138         I32 items;
3139         const I32 gimme = GIMME_V;
3140
3141         LEAVE_with_name("grep");                                        /* exit outer scope */
3142         (void)POPMARK;                          /* pop src */
3143         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3144         (void)POPMARK;                          /* pop dst */
3145         SP = PL_stack_base + POPMARK;           /* pop original mark */
3146         if (gimme == G_SCALAR) {
3147                 dTARGET;
3148                 XPUSHi(items);
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         DEFSV_set(src);
3167
3168         RETURNOP(cLOGOP->op_other);
3169     }
3170 }
3171
3172 PP(pp_leavesub)
3173 {
3174     dSP;
3175     SV **mark;
3176     SV **newsp;
3177     PMOP *newpm;
3178     I32 gimme;
3179     PERL_CONTEXT *cx;
3180     SV *sv;
3181
3182     if (CxMULTICALL(&cxstack[cxstack_ix])) {
3183         /* entry zero of a stack is always PL_sv_undef, which
3184          * simplifies converting a '()' return into undef in scalar context */
3185         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
3186         return 0;
3187     }
3188
3189     POPBLOCK(cx,newpm);
3190     cxstack_ix++; /* temporarily protect top context */
3191
3192     TAINT_NOT;
3193     if (gimme == G_SCALAR) {
3194         MARK = newsp + 1;
3195         if (LIKELY(MARK <= SP)) {
3196             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
3197                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3198                      && !SvMAGICAL(TOPs)) {
3199                     *MARK = SvREFCNT_inc(TOPs);
3200                     FREETMPS;
3201                     sv_2mortal(*MARK);
3202                 }
3203                 else {
3204                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
3205                     FREETMPS;
3206                     *MARK = sv_mortalcopy(sv);
3207                     SvREFCNT_dec_NN(sv);
3208                 }
3209             }
3210             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3211                      && !SvMAGICAL(TOPs)) {
3212                 *MARK = TOPs;
3213             }
3214             else
3215                 *MARK = sv_mortalcopy(TOPs);
3216         }
3217         else {
3218             MEXTEND(MARK, 0);
3219             *MARK = &PL_sv_undef;
3220         }
3221         SP = MARK;
3222     }
3223     else if (gimme == G_ARRAY) {
3224         for (MARK = newsp + 1; MARK <= SP; MARK++) {
3225             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
3226                  || SvMAGICAL(*MARK)) {
3227                 *MARK = sv_mortalcopy(*MARK);
3228                 TAINT_NOT;      /* Each item is independent */
3229             }
3230         }
3231     }
3232     PUTBACK;
3233
3234     LEAVE;
3235     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
3236     cxstack_ix--;
3237     PL_curpm = newpm;   /* ... and pop $1 et al */
3238
3239     LEAVESUB(sv);
3240     return cx->blk_sub.retop;
3241 }
3242
3243 PP(pp_entersub)
3244 {
3245     dSP; dPOPss;
3246     GV *gv;
3247     CV *cv;
3248     PERL_CONTEXT *cx;
3249     I32 gimme;
3250     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
3251
3252     if (UNLIKELY(!sv))
3253         DIE(aTHX_ "Not a CODE reference");
3254     /* This is overwhelmingly the most common case:  */
3255     if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
3256         switch (SvTYPE(sv)) {
3257         case SVt_PVGV:
3258           we_have_a_glob:
3259             if (!(cv = GvCVu((const GV *)sv))) {
3260                 HV *stash;
3261                 cv = sv_2cv(sv, &stash, &gv, 0);
3262             }
3263             if (!cv) {
3264                 ENTER;
3265                 SAVETMPS;
3266                 goto try_autoload;
3267             }
3268             break;
3269         case SVt_PVLV:
3270             if(isGV_with_GP(sv)) goto we_have_a_glob;
3271             /* FALLTHROUGH */
3272         default:
3273             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
3274                 if (hasargs)
3275                     SP = PL_stack_base + POPMARK;
3276                 else
3277                     (void)POPMARK;
3278                 RETURN;
3279             }
3280             SvGETMAGIC(sv);
3281             if (SvROK(sv)) {
3282                 if (SvAMAGIC(sv)) {
3283                     sv = amagic_deref_call(sv, to_cv_amg);
3284                     /* Don't SPAGAIN here.  */
3285                 }
3286             }
3287             else {
3288                 const char *sym;
3289                 STRLEN len;
3290                 if (!SvOK(sv))
3291                     DIE(aTHX_ PL_no_usym, "a subroutine");
3292                 sym = SvPV_nomg_const(sv, len);
3293                 if (PL_op->op_private & HINT_STRICT_REFS)
3294                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3295                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3296                 break;
3297             }
3298             cv = MUTABLE_CV(SvRV(sv));
3299             if (SvTYPE(cv) == SVt_PVCV)
3300                 break;
3301             /* FALLTHROUGH */
3302         case SVt_PVHV:
3303         case SVt_PVAV:
3304             DIE(aTHX_ "Not a CODE reference");
3305             /* This is the second most common case:  */
3306         case SVt_PVCV:
3307             cv = MUTABLE_CV(sv);
3308             break;
3309         }
3310     }
3311
3312     ENTER;
3313
3314   retry:
3315     if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
3316         DIE(aTHX_ "Closure prototype called");
3317     if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
3318         GV* autogv;
3319         SV* sub_name;
3320
3321         /* anonymous or undef'd function leaves us no recourse */
3322         if (CvLEXICAL(cv) && CvHASGV(cv))
3323             DIE(aTHX_ "Undefined subroutine &%"SVf" called",
3324                        SVfARG(cv_name(cv, NULL, 0)));
3325         if (CvANON(cv) || !CvHASGV(cv)) {
3326             DIE(aTHX_ "Undefined subroutine called");
3327         }
3328
3329         /* autoloaded stub? */
3330         if (cv != GvCV(gv = CvGV(cv))) {
3331             cv = GvCV(gv);
3332         }
3333         /* should call AUTOLOAD now? */
3334         else {
3335           try_autoload:
3336             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3337                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
3338             {
3339                 cv = GvCV(autogv);
3340             }
3341             else {
3342                sorry:
3343                 sub_name = sv_newmortal();
3344                 gv_efullname3(sub_name, gv, NULL);
3345                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
3346             }
3347         }
3348         if (!cv)
3349             goto sorry;
3350         goto retry;
3351     }
3352
3353     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3354             && !CvNODEBUG(cv)))
3355     {
3356          Perl_get_db_sub(aTHX_ &sv, cv);
3357          if (CvISXSUB(cv))
3358              PL_curcopdb = PL_curcop;
3359          if (CvLVALUE(cv)) {
3360              /* check for lsub that handles lvalue subroutines */
3361              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
3362              /* if lsub not found then fall back to DB::sub */
3363              if (!cv) cv = GvCV(PL_DBsub);
3364          } else {
3365              cv = GvCV(PL_DBsub);
3366          }
3367
3368         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3369             DIE(aTHX_ "No DB::sub routine defined");
3370     }
3371
3372     gimme = GIMME_V;
3373
3374     if (!(CvISXSUB(cv))) {
3375         /* This path taken at least 75% of the time   */
3376         dMARK;
3377         PADLIST * const padlist = CvPADLIST(cv);
3378         I32 depth;
3379
3380         PUSHBLOCK(cx, CXt_SUB, MARK);
3381         PUSHSUB(cx);
3382         cx->blk_sub.retop = PL_op->op_next;
3383         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3384             PERL_STACK_OVERFLOW_CHECK();
3385             pad_push(padlist, depth);
3386         }
3387         SAVECOMPPAD();
3388         PAD_SET_CUR_NOSAVE(padlist, depth);
3389         if (LIKELY(hasargs)) {
3390             AV *const av = MUTABLE_AV(PAD_SVl(0));
3391             SSize_t items;
3392             AV **defavp;
3393
3394             if (UNLIKELY(AvREAL(av))) {
3395                 /* @_ is normally not REAL--this should only ever
3396                  * happen when DB::sub() calls things that modify @_ */
3397                 av_clear(av);
3398                 AvREAL_off(av);
3399                 AvREIFY_on(av);
3400             }
3401             defavp = &GvAV(PL_defgv);
3402             cx->blk_sub.savearray = *defavp;
3403             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
3404             CX_CURPAD_SAVE(cx->blk_sub);
3405             cx->blk_sub.argarray = av;
3406             items = SP - MARK;
3407
3408             if (UNLIKELY(items - 1 > AvMAX(av))) {
3409                 SV **ary = AvALLOC(av);
3410                 AvMAX(av) = items - 1;
3411                 Renew(ary, items, SV*);
3412                 AvALLOC(av) = ary;
3413                 AvARRAY(av) = ary;
3414             }
3415
3416             Copy(MARK+1,AvARRAY(av),items,SV*);
3417             AvFILLp(av) = items - 1;
3418
3419             MARK = AvARRAY(av);
3420             while (items--) {
3421                 if (*MARK)
3422                 {
3423                     if (SvPADTMP(*MARK)) {
3424                         *MARK = sv_mortalcopy(*MARK);
3425                     }
3426                     SvTEMP_off(*MARK);
3427                 }
3428                 MARK++;
3429             }
3430         }
3431         SAVETMPS;
3432         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3433             !CvLVALUE(cv)))
3434             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
3435                 SVfARG(cv_name(cv, NULL, 0)));
3436         /* warning must come *after* we fully set up the context
3437          * stuff so that __WARN__ handlers can safely dounwind()
3438          * if they want to
3439          */
3440         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
3441                 && ckWARN(WARN_RECURSION)
3442                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
3443             sub_crush_depth(cv);
3444         RETURNOP(CvSTART(cv));
3445     }
3446     else {
3447         SSize_t markix = TOPMARK;
3448
3449         SAVETMPS;
3450         PUTBACK;
3451
3452         if (UNLIKELY(((PL_op->op_private
3453                & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3454              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3455             !CvLVALUE(cv)))
3456             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
3457                 SVfARG(cv_name(cv, NULL, 0)));
3458
3459         if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3460             /* Need to copy @_ to stack. Alternative may be to
3461              * switch stack to @_, and copy return values
3462              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3463             AV * const av = GvAV(PL_defgv);
3464             const SSize_t items = AvFILL(av) + 1;
3465
3466             if (items) {
3467                 SSize_t i = 0;
3468                 const bool m = cBOOL(SvRMAGICAL(av));
3469                 /* Mark is at the end of the stack. */
3470                 EXTEND(SP, items);
3471                 for (; i < items; ++i)
3472                 {
3473                     SV *sv;
3474                     if (m) {
3475                         SV ** const svp = av_fetch(av, i, 0);
3476                         sv = svp ? *svp : NULL;
3477                     }
3478                     else sv = AvARRAY(av)[i];
3479                     if (sv) SP[i+1] = sv;
3480                     else {
3481                         SP[i+1] = newSVavdefelem(av, i, 1);
3482                     }
3483                 }
3484                 SP += items;
3485                 PUTBACK ;
3486             }
3487         }
3488         else {
3489             SV **mark = PL_stack_base + markix;
3490             SSize_t items = SP - mark;
3491             while (items--) {
3492                 mark++;
3493                 if (*mark && SvPADTMP(*mark)) {
3494                     *mark = sv_mortalcopy(*mark);
3495                 }
3496             }
3497         }
3498         /* We assume first XSUB in &DB::sub is the called one. */
3499         if (UNLIKELY(PL_curcopdb)) {
3500             SAVEVPTR(PL_curcop);
3501             PL_curcop = PL_curcopdb;
3502             PL_curcopdb = NULL;
3503         }
3504         /* Do we need to open block here? XXXX */
3505
3506         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3507         assert(CvXSUB(cv));
3508         CvXSUB(cv)(aTHX_ cv);
3509
3510         /* Enforce some sanity in scalar context. */
3511         if (gimme == G_SCALAR) {
3512             SV **svp = PL_stack_base + markix + 1;
3513             if (svp != PL_stack_sp) {
3514                 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3515                 PL_stack_sp = svp;
3516             }
3517         }
3518         LEAVE;
3519         return NORMAL;
3520     }
3521 }
3522
3523 void
3524 Perl_sub_crush_depth(pTHX_ CV *cv)
3525 {
3526     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3527
3528     if (CvANON(cv))
3529         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3530     else {
3531         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3532                     SVfARG(cv_name(cv,NULL,0)));
3533     }
3534 }
3535
3536 PP(pp_aelem)
3537 {
3538     dSP;
3539     SV** svp;
3540     SV* const elemsv = POPs;
3541     IV elem = SvIV(elemsv);
3542     AV *const av = MUTABLE_AV(POPs);
3543     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3544     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3545     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3546     bool preeminent = TRUE;
3547     SV *sv;
3548
3549     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
3550         Perl_warner(aTHX_ packWARN(WARN_MISC),
3551                     "Use of reference \"%"SVf"\" as array index",
3552                     SVfARG(elemsv));
3553     if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
3554         RETPUSHUNDEF;
3555
3556     if (UNLIKELY(localizing)) {
3557         MAGIC *mg;
3558         HV *stash;
3559
3560         /* If we can determine whether the element exist,
3561          * Try to preserve the existenceness of a tied array
3562          * element by using EXISTS and DELETE if possible.
3563          * Fallback to FETCH and STORE otherwise. */
3564         if (SvCANEXISTDELETE(av))
3565             preeminent = av_exists(av, elem);
3566     }
3567
3568     svp = av_fetch(av, elem, lval && !defer);
3569     if (lval) {
3570 #ifdef PERL_MALLOC_WRAP
3571          if (SvUOK(elemsv)) {
3572               const UV uv = SvUV(elemsv);
3573               elem = uv > IV_MAX ? IV_MAX : uv;
3574          }
3575          else if (SvNOK(elemsv))
3576               elem = (IV)SvNV(elemsv);
3577          if (elem > 0) {
3578               static const char oom_array_extend[] =
3579                 "Out of memory during array extend"; /* Duplicated in av.c */
3580               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3581          }
3582 #endif
3583         if (!svp || !*svp) {
3584             IV len;
3585             if (!defer)
3586                 DIE(aTHX_ PL_no_aelem, elem);
3587             len = av_tindex(av);
3588             mPUSHs(newSVavdefelem(av,
3589             /* Resolve a negative index now, unless it points before the
3590                beginning of the array, in which case record it for error
3591                reporting in magic_setdefelem. */
3592                 elem < 0 && len + elem >= 0 ? len + elem : elem,
3593                 1));
3594             RETURN;
3595         }
3596         if (UNLIKELY(localizing)) {
3597             if (preeminent)
3598                 save_aelem(av, elem, svp);
3599             else
3600                 SAVEADELETE(av, elem);
3601         }
3602         else if (PL_op->op_private & OPpDEREF) {
3603             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3604             RETURN;
3605         }
3606     }
3607     sv = (svp ? *svp : &PL_sv_undef);
3608     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3609         mg_get(sv);
3610     PUSHs(sv);
3611     RETURN;
3612 }
3613
3614 SV*
3615 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3616 {
3617     PERL_ARGS_ASSERT_VIVIFY_REF;
3618
3619     SvGETMAGIC(sv);
3620     if (!SvOK(sv)) {
3621         if (SvREADONLY(sv))
3622             Perl_croak_no_modify();
3623         prepare_SV_for_RV(sv);
3624         switch (to_what) {
3625         case OPpDEREF_SV:
3626             SvRV_set(sv, newSV(0));
3627             break;
3628         case OPpDEREF_AV:
3629             SvRV_set(sv, MUTABLE_SV(newAV()));
3630             break;
3631         case OPpDEREF_HV:
3632             SvRV_set(sv, MUTABLE_SV(newHV()));
3633             break;
3634         }
3635         SvROK_on(sv);
3636         SvSETMAGIC(sv);
3637         SvGETMAGIC(sv);
3638     }
3639     if (SvGMAGICAL(sv)) {
3640         /* copy the sv without magic to prevent magic from being
3641            executed twice */
3642         SV* msv = sv_newmortal();
3643         sv_setsv_nomg(msv, sv);
3644         return msv;
3645     }
3646     return sv;
3647 }
3648
3649 PERL_STATIC_INLINE HV *
3650 S_opmethod_stash(pTHX_ SV* meth)
3651 {
3652     SV* ob;
3653     HV* stash;
3654
3655     SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
3656         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3657                             "package or object reference", SVfARG(meth)),
3658            (SV *)NULL)
3659         : *(PL_stack_base + TOPMARK + 1);
3660
3661     PERL_ARGS_ASSERT_OPMETHOD_STASH;
3662
3663     if (UNLIKELY(!sv))
3664        undefined:
3665         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3666                    SVfARG(meth));
3667
3668     if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3669     else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3670         stash = gv_stashsv(sv, GV_CACHE_ONLY);
3671         if (stash) return stash;
3672     }
3673
3674     if (SvROK(sv))
3675         ob = MUTABLE_SV(SvRV(sv));
3676     else if (!SvOK(sv)) goto undefined;
3677     else if (isGV_with_GP(sv)) {
3678         if (!GvIO(sv))
3679             Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3680                              "without a package or object reference",
3681                               SVfARG(meth));
3682         ob = sv;
3683         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3684             assert(!LvTARGLEN(ob));
3685             ob = LvTARG(ob);
3686             assert(ob);
3687         }
3688         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3689     }
3690     else {
3691         /* this isn't a reference */
3692         GV* iogv;
3693         STRLEN packlen;
3694         const char * const packname = SvPV_nomg_const(sv, packlen);
3695         const U32 packname_utf8 = SvUTF8(sv);
3696         stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3697         if (stash) return stash;
3698
3699         if (!(iogv = gv_fetchpvn_flags(
3700                 packname, packlen, packname_utf8, SVt_PVIO
3701              )) ||
3702             !(ob=MUTABLE_SV(GvIO(iogv))))
3703         {
3704             /* this isn't the name of a filehandle either */
3705             if (!packlen)
3706             {
3707                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3708                                  "without a package or object reference",
3709                                   SVfARG(meth));
3710             }
3711             /* assume it's a package name */
3712             stash = gv_stashpvn(packname, packlen, packname_utf8);
3713             if (stash) return stash;
3714             else return MUTABLE_HV(sv);
3715         }
3716         /* it _is_ a filehandle name -- replace with a reference */
3717         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3718     }
3719
3720     /* if we got here, ob should be an object or a glob */
3721     if (!ob || !(SvOBJECT(ob)
3722                  || (isGV_with_GP(ob)
3723                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3724                      && SvOBJECT(ob))))
3725     {
3726         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3727                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3728                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3729                                         : meth));
3730     }
3731
3732     return SvSTASH(ob);
3733 }
3734
3735 PP(pp_method)
3736 {
3737     dSP;
3738     GV* gv;
3739     HV* stash;
3740     SV* const meth = TOPs;
3741
3742     if (SvROK(meth)) {
3743         SV* const rmeth = SvRV(meth);
3744         if (SvTYPE(rmeth) == SVt_PVCV) {
3745             SETs(rmeth);
3746             RETURN;
3747         }
3748     }
3749
3750     stash = opmethod_stash(meth);
3751
3752     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3753     assert(gv);
3754
3755     SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3756     RETURN;
3757 }
3758
3759 #define METHOD_CHECK_CACHE(stash,cache,meth)                            \
3760     const HE* const he = hv_fetch_ent(cache, meth, 0, 0);               \
3761     if (he) {                                                           \
3762         gv = MUTABLE_GV(HeVAL(he));                                     \
3763         if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv)        \
3764              == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))     \
3765         {                                                               \
3766             XPUSHs(MUTABLE_SV(GvCV(gv)));                               \
3767             RETURN;                                                     \
3768         }                                                               \
3769     }                                                                   \
3770
3771 PP(pp_method_named)
3772 {
3773     dSP;
3774     GV* gv;
3775     SV* const meth = cMETHOPx_meth(PL_op);
3776     HV* const stash = opmethod_stash(meth);
3777
3778     if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
3779         METHOD_CHECK_CACHE(stash, stash, meth);
3780     }
3781
3782     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3783     assert(gv);
3784
3785     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3786     RETURN;
3787 }
3788
3789 PP(pp_method_super)
3790 {
3791     dSP;
3792     GV* gv;
3793     HV* cache;
3794     SV* const meth = cMETHOPx_meth(PL_op);
3795     HV* const stash = CopSTASH(PL_curcop);
3796     /* Actually, SUPER doesn't need real object's (or class') stash at all,
3797      * as it uses CopSTASH. However, we must ensure that object(class) is
3798      * correct (this check is done by S_opmethod_stash) */
3799     opmethod_stash(meth);
3800
3801     if ((cache = HvMROMETA(stash)->super)) {
3802         METHOD_CHECK_CACHE(stash, cache, meth);
3803     }
3804
3805     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3806     assert(gv);
3807
3808     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3809     RETURN;
3810 }
3811
3812 PP(pp_method_redir)
3813 {
3814     dSP;
3815     GV* gv;
3816     SV* const meth = cMETHOPx_meth(PL_op);
3817     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3818     opmethod_stash(meth); /* not used but needed for error checks */
3819
3820     if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3821     else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3822
3823     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3824     assert(gv);
3825
3826     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3827     RETURN;
3828 }
3829
3830 PP(pp_method_redir_super)
3831 {
3832     dSP;
3833     GV* gv;
3834     HV* cache;
3835     SV* const meth = cMETHOPx_meth(PL_op);
3836     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3837     opmethod_stash(meth); /* not used but needed for error checks */
3838
3839     if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3840     else if ((cache = HvMROMETA(stash)->super)) {
3841          METHOD_CHECK_CACHE(stash, cache, meth);
3842     }
3843
3844     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3845     assert(gv);
3846
3847     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3848     RETURN;
3849 }
3850
3851 /*
3852  * ex: set ts=8 sts=4 sw=4 et:
3853  */