pp_hot.c

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