pp_hot.c

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