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