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     dVAR;
  43     dSP;
  44     XPUSHs(cSVOP_sv);
  45     RETURN;
  46 }
  47
  48 PP(pp_nextstate)
  49 {
  50     dVAR;
  51     PL_curcop = (COP*)PL_op;
  52     TAINT_NOT;          /* Each statement is presumed innocent */
  53     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  54     FREETMPS;
  55     PERL_ASYNC_CHECK();
  56     return NORMAL;
  57 }
  58
  59 PP(pp_gvsv)
  60 {
  61     dVAR;
  62     dSP;
  63     EXTEND(SP,1);
  64     if (PL_op->op_private & OPpLVAL_INTRO)
  65         PUSHs(save_scalar(cGVOP_gv));
  66     else
  67         PUSHs(GvSVn(cGVOP_gv));
  68     RETURN;
  69 }
  70
  71 PP(pp_null)
  72 {
  73     dVAR;
  74     return NORMAL;
  75 }
  76
  77 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
  78 PP(pp_pushmark)
  79 {
  80     dVAR;
  81     PUSHMARK(PL_stack_sp);
  82     return NORMAL;
  83 }
  84
  85 PP(pp_stringify)
  86 {
  87     dVAR; dSP; dTARGET;
  88     SV * const sv = TOPs;
  89     SETs(TARG);
  90     sv_copypv(TARG, sv);
  91     SvSETMAGIC(TARG);
  92     /* no PUTBACK, SETs doesn't inc/dec SP */
  93     return NORMAL;
  94 }
  95
  96 PP(pp_gv)
  97 {
  98     dVAR; dSP;
  99     XPUSHs(MUTABLE_SV(cGVOP_gv));
 100     RETURN;
 101 }
 102
 103 PP(pp_and)
 104 {
 105     dVAR;
 106     PERL_ASYNC_CHECK();
 107     {
 108         /* SP is not used to remove a variable that is saved across the
 109           sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
 110           register or load/store vs direct mem ops macro is introduced, this
 111           should be a define block between direct PL_stack_sp and dSP operations,
 112           presently, using PL_stack_sp is bias towards CISC cpus */
 113         SV * const sv = *PL_stack_sp;
 114         if (!SvTRUE_NN(sv))
 115             return NORMAL;
 116         else {
 117             if (PL_op->op_type == OP_AND)
 118                 --PL_stack_sp;
 119             return cLOGOP->op_other;
 120         }
 121     }
 122 }
 123
 124 PP(pp_sassign)
 125 {
 126     dVAR; dSP;
 127     /* sassign keeps its args in the optree traditionally backwards.
 128        So we pop them differently.
 129     */
 130     SV *left = POPs; SV *right = TOPs;
 131
 132     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
 133         SV * const temp = left;
 134         left = right; right = temp;
 135     }
 136     if (TAINTING_get && TAINT_get && !SvTAINTED(right))
 137         TAINT_NOT;
 138     if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
 139         SV * const cv = SvRV(right);
 140         const U32 cv_type = SvTYPE(cv);
 141         const bool is_gv = isGV_with_GP(left);
 142         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 143
 144         if (!got_coderef) {
 145             assert(SvROK(cv));
 146         }
 147
 148         /* Can do the optimisation if left (LVALUE) is not a typeglob,
 149            right (RVALUE) is a reference to something, and we're in void
 150            context. */
 151         if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
 152             /* Is the target symbol table currently empty?  */
 153             GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
 154             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 155                 /* Good. Create a new proxy constant subroutine in the target.
 156                    The gv becomes a(nother) reference to the constant.  */
 157                 SV *const value = SvRV(cv);
 158
 159                 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
 160                 SvPCS_IMPORTED_on(gv);
 161                 SvRV_set(gv, value);
 162                 SvREFCNT_inc_simple_void(value);
 163                 SETs(left);
 164                 RETURN;
 165             }
 166         }
 167
 168         /* Need to fix things up.  */
 169         if (!is_gv) {
 170             /* Need to fix GV.  */
 171             left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
 172         }
 173
 174         if (!got_coderef) {
 175             /* We've been returned a constant rather than a full subroutine,
 176                but they expect a subroutine reference to apply.  */
 177             if (SvROK(cv)) {
 178                 ENTER_with_name("sassign_coderef");
 179                 SvREFCNT_inc_void(SvRV(cv));
 180                 /* newCONSTSUB takes a reference count on the passed in SV
 181                    from us.  We set the name to NULL, otherwise we get into
 182                    all sorts of fun as the reference to our new sub is
 183                    donated to the GV that we're about to assign to.
 184                 */
 185                 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
 186                                                       SvRV(cv))));
 187                 SvREFCNT_dec_NN(cv);
 188                 LEAVE_with_name("sassign_coderef");
 189             } else {
 190                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
 191                    is that
 192                    First:   ops for \&{"BONK"}; return us the constant in the
 193                             symbol table
 194                    Second:  ops for *{"BONK"} cause that symbol table entry
 195                             (and our reference to it) to be upgraded from RV
 196                             to typeblob)
 197                    Thirdly: We get here. cv is actually PVGV now, and its
 198                             GvCV() is actually the subroutine we're looking for
 199
 200                    So change the reference so that it points to the subroutine
 201                    of that typeglob, as that's what they were after all along.
 202                 */
 203                 GV *const upgraded = MUTABLE_GV(cv);
 204                 CV *const source = GvCV(upgraded);
 205
 206                 assert(source);
 207                 assert(CvFLAGS(source) & CVf_CONST);
 208
 209                 SvREFCNT_inc_void(source);
 210                 SvREFCNT_dec_NN(upgraded);
 211                 SvRV_set(right, MUTABLE_SV(source));
 212             }
 213         }
 214
 215     }
 216     if (
 217       SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
 218       (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
 219     )
 220         Perl_warner(aTHX_
 221             packWARN(WARN_MISC), "Useless assignment to a temporary"
 222         );
 223     SvSetMagicSV(left, right);
 224     SETs(left);
 225     RETURN;
 226 }
 227
 228 PP(pp_cond_expr)
 229 {
 230     dVAR; dSP;
 231     PERL_ASYNC_CHECK();
 232     if (SvTRUEx(POPs))
 233         RETURNOP(cLOGOP->op_other);
 234     else
 235         RETURNOP(cLOGOP->op_next);
 236 }
 237
 238 PP(pp_unstack)
 239 {
 240     dVAR;
 241     PERL_ASYNC_CHECK();
 242     TAINT_NOT;          /* Each statement is presumed innocent */
 243     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 244     FREETMPS;
 245     if (!(PL_op->op_flags & OPf_SPECIAL)) {
 246         I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
 247         LEAVE_SCOPE(oldsave);
 248     }
 249     return NORMAL;
 250 }
 251
 252 PP(pp_concat)
 253 {
 254   dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
 255   {
 256     dPOPTOPssrl;
 257     bool lbyte;
 258     STRLEN rlen;
 259     const char *rpv = NULL;
 260     bool rbyte = FALSE;
 261     bool rcopied = FALSE;
 262
 263     if (TARG == right && right != left) { /* $r = $l.$r */
 264         rpv = SvPV_nomg_const(right, rlen);
 265         rbyte = !DO_UTF8(right);
 266         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 267         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 268         rcopied = TRUE;
 269     }
 270
 271     if (TARG != left) { /* not $l .= $r */
 272         STRLEN llen;
 273         const char* const lpv = SvPV_nomg_const(left, llen);
 274         lbyte = !DO_UTF8(left);
 275         sv_setpvn(TARG, lpv, llen);
 276         if (!lbyte)
 277             SvUTF8_on(TARG);
 278         else
 279             SvUTF8_off(TARG);
 280     }
 281     else { /* $l .= $r */
 282         if (!SvOK(TARG)) {
 283             if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
 284                 report_uninit(right);
 285             sv_setpvs(left, "");
 286         }
 287         SvPV_force_nomg_nolen(left);
 288         lbyte = !DO_UTF8(left);
 289         if (IN_BYTES)
 290             SvUTF8_off(TARG);
 291     }
 292
 293     if (!rcopied) {
 294         if (left == right)
 295             /* $r.$r: do magic twice: tied might return different 2nd time */
 296             SvGETMAGIC(right);
 297         rpv = SvPV_nomg_const(right, rlen);
 298         rbyte = !DO_UTF8(right);
 299     }
 300     if (lbyte != rbyte) {
 301         /* sv_utf8_upgrade_nomg() may reallocate the stack */
 302         PUTBACK;
 303         if (lbyte)
 304             sv_utf8_upgrade_nomg(TARG);
 305         else {
 306             if (!rcopied)
 307                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 308             sv_utf8_upgrade_nomg(right);
 309             rpv = SvPV_nomg_const(right, rlen);
 310         }
 311         SPAGAIN;
 312     }
 313     sv_catpvn_nomg(TARG, rpv, rlen);
 314
 315     SETTARG;
 316     RETURN;
 317   }
 318 }
 319
 320 /* push the elements of av onto the stack.
 321  * XXX Note that padav has similar code but without the mg_get().
 322  * I suspect that the mg_get is no longer needed, but while padav
 323  * differs, it can't share this function */
 324
 325 STATIC void
 326 S_pushav(pTHX_ AV* const av)
 327 {
 328     dSP;
 329     const I32 maxarg = AvFILL(av) + 1;
 330     EXTEND(SP, maxarg);
 331     if (SvRMAGICAL(av)) {
 332         U32 i;
 333         for (i=0; i < (U32)maxarg; i++) {
 334             SV ** const svp = av_fetch(av, i, FALSE);
 335             /* See note in pp_helem, and bug id #27839 */
 336             SP[i+1] = svp
 337                 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
 338                 : &PL_sv_undef;
 339         }
 340     }
 341     else {
 342         U32 i;
 343         for (i=0; i < (U32)maxarg; i++) {
 344             SV * const sv = AvARRAY(av)[i];
 345             SP[i+1] = sv ? sv : &PL_sv_undef;
 346         }
 347     }
 348     SP += maxarg;
 349     PUTBACK;
 350 }
 351
 352
 353 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
 354
 355 PP(pp_padrange)
 356 {
 357     dVAR; dSP;
 358     PADOFFSET base = PL_op->op_targ;
 359     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
 360     int i;
 361     if (PL_op->op_flags & OPf_SPECIAL) {
 362         /* fake the RHS of my ($x,$y,..) = @_ */
 363         PUSHMARK(SP);
 364         S_pushav(aTHX_ GvAVn(PL_defgv));
 365         SPAGAIN;
 366     }
 367
 368     /* note, this is only skipped for compile-time-known void cxt */
 369     if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
 370         EXTEND(SP, count);
 371         PUSHMARK(SP);
 372         for (i = 0; i <count; i++)
 373             *++SP = PAD_SV(base+i);
 374     }
 375     if (PL_op->op_private & OPpLVAL_INTRO) {
 376         SV **svp = &(PAD_SVl(base));
 377         const UV payload = (UV)(
 378                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
 379                     | (count << SAVE_TIGHT_SHIFT)
 380                     | SAVEt_CLEARPADRANGE);
 381         assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
 382         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
 383         {
 384             dSS_ADD;
 385             SS_ADD_UV(payload);
 386             SS_ADD_END(1);
 387         }
 388
 389         for (i = 0; i <count; i++)
 390             SvPADSTALE_off(*svp++); /* mark lexical as active */
 391     }
 392     RETURN;
 393 }
 394
 395
 396 PP(pp_padsv)
 397 {
 398     dVAR; dSP;
 399     EXTEND(SP, 1);
 400     {
 401         OP * const op = PL_op;
 402         /* access PL_curpad once */
 403         SV ** const padentry = &(PAD_SVl(op->op_targ));
 404         {
 405             dTARG;
 406             TARG = *padentry;
 407             PUSHs(TARG);
 408             PUTBACK; /* no pop/push after this, TOPs ok */
 409         }
 410         if (op->op_flags & OPf_MOD) {
 411             if (op->op_private & OPpLVAL_INTRO)
 412                 if (!(op->op_private & OPpPAD_STATE))
 413                     save_clearsv(padentry);
 414             if (op->op_private & OPpDEREF) {
 415                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
 416                    than TARG reduces the scope of TARG, so it does not
 417                    span the call to save_clearsv, resulting in smaller
 418                    machine code. */
 419                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
 420             }
 421         }
 422         return op->op_next;
 423     }
 424 }
 425
 426 PP(pp_readline)
 427 {
 428     dVAR;
 429     dSP;
 430     if (TOPs) {
 431         SvGETMAGIC(TOPs);
 432         tryAMAGICunTARGETlist(iter_amg, 0);
 433         PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
 434     }
 435     else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
 436     if (!isGV_with_GP(PL_last_in_gv)) {
 437         if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
 438             PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
 439         else {
 440             dSP;
 441             XPUSHs(MUTABLE_SV(PL_last_in_gv));
 442             PUTBACK;
 443             Perl_pp_rv2gv(aTHX);
 444             PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
 445         }
 446     }
 447     return do_readline();
 448 }
 449
 450 PP(pp_eq)
 451 {
 452     dVAR; dSP;
 453     SV *left, *right;
 454
 455     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
 456     right = POPs;
 457     left  = TOPs;
 458     SETs(boolSV(
 459         (SvIOK_notUV(left) && SvIOK_notUV(right))
 460         ? (SvIVX(left) == SvIVX(right))
 461         : ( do_ncmp(left, right) == 0)
 462     ));
 463     RETURN;
 464 }
 465
 466 PP(pp_preinc)
 467 {
 468     dVAR; dSP;
 469     const bool inc =
 470         PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
 471     if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
 472         Perl_croak_no_modify();
 473     if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 474         && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
 475     {
 476         SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
 477         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 478     }
 479     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 480         if (inc) sv_inc(TOPs);
 481         else sv_dec(TOPs);
 482     SvSETMAGIC(TOPs);
 483     return NORMAL;
 484 }
 485
 486 PP(pp_or)
 487 {
 488     dVAR; dSP;
 489     PERL_ASYNC_CHECK();
 490     if (SvTRUE(TOPs))
 491         RETURN;
 492     else {
 493         if (PL_op->op_type == OP_OR)
 494             --SP;
 495         RETURNOP(cLOGOP->op_other);
 496     }
 497 }
 498
 499 PP(pp_defined)
 500 {
 501     dVAR; dSP;
 502     SV* sv;
 503     bool defined;
 504     const int op_type = PL_op->op_type;
 505     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 506
 507     if (is_dor) {
 508         PERL_ASYNC_CHECK();
 509         sv = TOPs;
 510         if (!sv || !SvANY(sv)) {
 511             if (op_type == OP_DOR)
 512                 --SP;
 513             RETURNOP(cLOGOP->op_other);
 514         }
 515     }
 516     else {
 517         /* OP_DEFINED */
 518         sv = POPs;
 519         if (!sv || !SvANY(sv))
 520             RETPUSHNO;
 521     }
 522
 523     defined = FALSE;
 524     switch (SvTYPE(sv)) {
 525     case SVt_PVAV:
 526         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 527             defined = TRUE;
 528         break;
 529     case SVt_PVHV:
 530         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 531             defined = TRUE;
 532         break;
 533     case SVt_PVCV:
 534         if (CvROOT(sv) || CvXSUB(sv))
 535             defined = TRUE;
 536         break;
 537     default:
 538         SvGETMAGIC(sv);
 539         if (SvOK(sv))
 540             defined = TRUE;
 541         break;
 542     }
 543
 544     if (is_dor) {
 545         if(defined)
 546             RETURN;
 547         if(op_type == OP_DOR)
 548             --SP;
 549         RETURNOP(cLOGOP->op_other);
 550     }
 551     /* assuming OP_DEFINED */
 552     if(defined)
 553         RETPUSHYES;
 554     RETPUSHNO;
 555 }
 556
 557 PP(pp_add)
 558 {
 559     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
 560     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
 561     svr = TOPs;
 562     svl = TOPm1s;
 563
 564     useleft = USE_LEFT(svl);
 565 #ifdef PERL_PRESERVE_IVUV
 566     /* We must see if we can perform the addition with integers if possible,
 567        as the integer code detects overflow while the NV code doesn't.
 568        If either argument hasn't had a numeric conversion yet attempt to get
 569        the IV. It's important to do this now, rather than just assuming that
 570        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 571        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 572        integer in case the second argument is IV=9223372036854775806
 573        We can (now) rely on sv_2iv to do the right thing, only setting the
 574        public IOK flag if the value in the NV (or PV) slot is truly integer.
 575
 576        A side effect is that this also aggressively prefers integer maths over
 577        fp maths for integer values.
 578
 579        How to detect overflow?
 580
 581        C 99 section 6.2.6.1 says
 582
 583        The range of nonnegative values of a signed integer type is a subrange
 584        of the corresponding unsigned integer type, and the representation of
 585        the same value in each type is the same. A computation involving
 586        unsigned operands can never overflow, because a result that cannot be
 587        represented by the resulting unsigned integer type is reduced modulo
 588        the number that is one greater than the largest value that can be
 589        represented by the resulting type.
 590
 591        (the 9th paragraph)
 592
 593        which I read as "unsigned ints wrap."
 594
 595        signed integer overflow seems to be classed as "exception condition"
 596
 597        If an exceptional condition occurs during the evaluation of an
 598        expression (that is, if the result is not mathematically defined or not
 599        in the range of representable values for its type), the behavior is
 600        undefined.
 601
 602        (6.5, the 5th paragraph)
 603
 604        I had assumed that on 2s complement machines signed arithmetic would
 605        wrap, hence coded pp_add and pp_subtract on the assumption that
 606        everything perl builds on would be happy.  After much wailing and
 607        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 608        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 609        unsigned code below is actually shorter than the old code. :-)
 610     */
 611
 612     if (SvIV_please_nomg(svr)) {
 613         /* Unless the left argument is integer in range we are going to have to
 614            use NV maths. Hence only attempt to coerce the right argument if
 615            we know the left is integer.  */
 616         UV auv = 0;
 617         bool auvok = FALSE;
 618         bool a_valid = 0;
 619
 620         if (!useleft) {
 621             auv = 0;
 622             a_valid = auvok = 1;
 623             /* left operand is undef, treat as zero. + 0 is identity,
 624                Could SETi or SETu right now, but space optimise by not adding
 625                lots of code to speed up what is probably a rarish case.  */
 626         } else {
 627             /* Left operand is defined, so is it IV? */
 628             if (SvIV_please_nomg(svl)) {
 629                 if ((auvok = SvUOK(svl)))
 630                     auv = SvUVX(svl);
 631                 else {
 632                     const IV aiv = SvIVX(svl);
 633                     if (aiv >= 0) {
 634                         auv = aiv;
 635                         auvok = 1;      /* Now acting as a sign flag.  */
 636                     } else { /* 2s complement assumption for IV_MIN */
 637                         auv = (UV)-aiv;
 638                     }
 639                 }
 640                 a_valid = 1;
 641             }
 642         }
 643         if (a_valid) {
 644             bool result_good = 0;
 645             UV result;
 646             UV buv;
 647             bool buvok = SvUOK(svr);
 648
 649             if (buvok)
 650                 buv = SvUVX(svr);
 651             else {
 652                 const IV biv = SvIVX(svr);
 653                 if (biv >= 0) {
 654                     buv = biv;
 655                     buvok = 1;
 656                 } else
 657                     buv = (UV)-biv;
 658             }
 659             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 660                else "IV" now, independent of how it came in.
 661                if a, b represents positive, A, B negative, a maps to -A etc
 662                a + b =>  (a + b)
 663                A + b => -(a - b)
 664                a + B =>  (a - b)
 665                A + B => -(a + b)
 666                all UV maths. negate result if A negative.
 667                add if signs same, subtract if signs differ. */
 668
 669             if (auvok ^ buvok) {
 670                 /* Signs differ.  */
 671                 if (auv >= buv) {
 672                     result = auv - buv;
 673                     /* Must get smaller */
 674                     if (result <= auv)
 675                         result_good = 1;
 676                 } else {
 677                     result = buv - auv;
 678                     if (result <= buv) {
 679                         /* result really should be -(auv-buv). as its negation
 680                            of true value, need to swap our result flag  */
 681                         auvok = !auvok;
 682                         result_good = 1;
 683                     }
 684                 }
 685             } else {
 686                 /* Signs same */
 687                 result = auv + buv;
 688                 if (result >= auv)
 689                     result_good = 1;
 690             }
 691             if (result_good) {
 692                 SP--;
 693                 if (auvok)
 694                     SETu( result );
 695                 else {
 696                     /* Negate result */
 697                     if (result <= (UV)IV_MIN)
 698                         SETi( -(IV)result );
 699                     else {
 700                         /* result valid, but out of range for IV.  */
 701                         SETn( -(NV)result );
 702                     }
 703                 }
 704                 RETURN;
 705             } /* Overflow, drop through to NVs.  */
 706         }
 707     }
 708 #endif
 709     {
 710         NV value = SvNV_nomg(svr);
 711         (void)POPs;
 712         if (!useleft) {
 713             /* left operand is undef, treat as zero. + 0.0 is identity. */
 714             SETn(value);
 715             RETURN;
 716         }
 717         SETn( value + SvNV_nomg(svl) );
 718         RETURN;
 719     }
 720 }
 721
 722 PP(pp_aelemfast)
 723 {
 724     dVAR; dSP;
 725     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
 726         ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
 727     const U32 lval = PL_op->op_flags & OPf_MOD;
 728     SV** const svp = av_fetch(av, PL_op->op_private, lval);
 729     SV *sv = (svp ? *svp : &PL_sv_undef);
 730     EXTEND(SP, 1);
 731     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
 732         mg_get(sv);
 733     PUSHs(sv);
 734     RETURN;
 735 }
 736
 737 PP(pp_join)
 738 {
 739     dVAR; dSP; dMARK; dTARGET;
 740     MARK++;
 741     do_join(TARG, *MARK, MARK, SP);
 742     SP = MARK;
 743     SETs(TARG);
 744     RETURN;
 745 }
 746
 747 PP(pp_pushre)
 748 {
 749     dVAR; dSP;
 750 #ifdef DEBUGGING
 751     /*
 752      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 753      * will be enough to hold an OP*.
 754      */
 755     SV* const sv = sv_newmortal();
 756     sv_upgrade(sv, SVt_PVLV);
 757     LvTYPE(sv) = '/';
 758     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 759     XPUSHs(sv);
 760 #else
 761     XPUSHs(MUTABLE_SV(PL_op));
 762 #endif
 763     RETURN;
 764 }
 765
 766 /* Oversized hot code. */
 767
 768 PP(pp_print)
 769 {
 770     dVAR; dSP; dMARK; dORIGMARK;
 771     PerlIO *fp;
 772     MAGIC *mg;
 773     GV * const gv
 774         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
 775     IO *io = GvIO(gv);
 776
 777     if (io
 778         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
 779     {
 780       had_magic:
 781         if (MARK == ORIGMARK) {
 782             /* If using default handle then we need to make space to
 783              * pass object as 1st arg, so move other args up ...
 784              */
 785             MEXTEND(SP, 1);
 786             ++MARK;
 787             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 788             ++SP;
 789         }
 790         return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
 791                                 mg,
 792                                 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
 793                                  | (PL_op->op_type == OP_SAY
 794                                     ? TIED_METHOD_SAY : 0)), sp - mark);
 795     }
 796     if (!io) {
 797         if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
 798             && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
 799             goto had_magic;
 800         report_evil_fh(gv);
 801         SETERRNO(EBADF,RMS_IFI);
 802         goto just_say_no;
 803     }
 804     else if (!(fp = IoOFP(io))) {
 805         if (IoIFP(io))
 806             report_wrongway_fh(gv, '<');
 807         else
 808             report_evil_fh(gv);
 809         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 810         goto just_say_no;
 811     }
 812     else {
 813         SV * const ofs = GvSV(PL_ofsgv); /* $, */
 814         MARK++;
 815         if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
 816             while (MARK <= SP) {
 817                 if (!do_print(*MARK, fp))
 818                     break;
 819                 MARK++;
 820                 if (MARK <= SP) {
 821                     /* don't use 'ofs' here - it may be invalidated by magic callbacks */
 822                     if (!do_print(GvSV(PL_ofsgv), fp)) {
 823                         MARK--;
 824                         break;
 825                     }
 826                 }
 827             }
 828         }
 829         else {
 830             while (MARK <= SP) {
 831                 if (!do_print(*MARK, fp))
 832                     break;
 833                 MARK++;
 834             }
 835         }
 836         if (MARK <= SP)
 837             goto just_say_no;
 838         else {
 839             if (PL_op->op_type == OP_SAY) {
 840                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
 841                     goto just_say_no;
 842             }
 843             else if (PL_ors_sv && SvOK(PL_ors_sv))
 844                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 845                     goto just_say_no;
 846
 847             if (IoFLAGS(io) & IOf_FLUSH)
 848                 if (PerlIO_flush(fp) == EOF)
 849                     goto just_say_no;
 850         }
 851     }
 852     SP = ORIGMARK;
 853     XPUSHs(&PL_sv_yes);
 854     RETURN;
 855
 856   just_say_no:
 857     SP = ORIGMARK;
 858     XPUSHs(&PL_sv_undef);
 859     RETURN;
 860 }
 861
 862 PP(pp_rv2av)
 863 {
 864     dVAR; dSP; dTOPss;
 865     const I32 gimme = GIMME_V;
 866     static const char an_array[] = "an ARRAY";
 867     static const char a_hash[] = "a HASH";
 868     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
 869     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 870
 871     SvGETMAGIC(sv);
 872     if (SvROK(sv)) {
 873         if (SvAMAGIC(sv)) {
 874             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
 875         }
 876         sv = SvRV(sv);
 877         if (SvTYPE(sv) != type)
 878             /* diag_listed_as: Not an ARRAY reference */
 879             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
 880         else if (PL_op->op_flags & OPf_MOD
 881                 && PL_op->op_private & OPpLVAL_INTRO)
 882             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 883     }
 884     else if (SvTYPE(sv) != type) {
 885             GV *gv;
 886
 887             if (!isGV_with_GP(sv)) {
 888                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 889                                      type, &sp);
 890                 if (!gv)
 891                     RETURN;
 892             }
 893             else {
 894                 gv = MUTABLE_GV(sv);
 895             }
 896             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
 897             if (PL_op->op_private & OPpLVAL_INTRO)
 898                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
 899     }
 900     if (PL_op->op_flags & OPf_REF) {
 901                 SETs(sv);
 902                 RETURN;
 903     }
 904     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
 905               const I32 flags = is_lvalue_sub();
 906               if (flags && !(flags & OPpENTERSUB_INARGS)) {
 907                 if (gimme != G_ARRAY)
 908                     goto croak_cant_return;
 909                 SETs(sv);
 910                 RETURN;
 911               }
 912     }
 913
 914     if (is_pp_rv2av) {
 915         AV *const av = MUTABLE_AV(sv);
 916         /* The guts of pp_rv2av, with no intending change to preserve history
 917            (until such time as we get tools that can do blame annotation across
 918            whitespace changes.  */
 919         if (gimme == G_ARRAY) {
 920             SP--;
 921             PUTBACK;
 922             S_pushav(aTHX_ av);
 923             SPAGAIN;
 924         }
 925         else if (gimme == G_SCALAR) {
 926             dTARGET;
 927             const I32 maxarg = AvFILL(av) + 1;
 928             SETi(maxarg);
 929         }
 930     } else {
 931         /* The guts of pp_rv2hv  */
 932         if (gimme == G_ARRAY) { /* array wanted */
 933             *PL_stack_sp = sv;
 934             return Perl_do_kv(aTHX);
 935         }
 936         else if ((PL_op->op_private & OPpTRUEBOOL
 937               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
 938                  && block_gimme() == G_VOID  ))
 939               && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
 940             SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
 941         else if (gimme == G_SCALAR) {
 942             dTARGET;
 943             TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
 944             SPAGAIN;
 945             SETTARG;
 946         }
 947     }
 948     RETURN;
 949
 950  croak_cant_return:
 951     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
 952                is_pp_rv2av ? "array" : "hash");
 953     RETURN;
 954 }
 955
 956 STATIC void
 957 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
 958 {
 959     dVAR;
 960
 961     PERL_ARGS_ASSERT_DO_ODDBALL;
 962
 963     if (*oddkey) {
 964         if (ckWARN(WARN_MISC)) {
 965             const char *err;
 966             if (oddkey == firstkey &&
 967                 SvROK(*oddkey) &&
 968                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
 969                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
 970             {
 971                 err = "Reference found where even-sized list expected";
 972             }
 973             else
 974                 err = "Odd number of elements in hash assignment";
 975             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
 976         }
 977
 978     }
 979 }
 980
 981 PP(pp_aassign)
 982 {
 983     dVAR; dSP;
 984     SV **lastlelem = PL_stack_sp;
 985     SV **lastrelem = PL_stack_base + POPMARK;
 986     SV **firstrelem = PL_stack_base + POPMARK + 1;
 987     SV **firstlelem = lastrelem + 1;
 988
 989     SV **relem;
 990     SV **lelem;
 991
 992     SV *sv;
 993     AV *ary;
 994
 995     I32 gimme;
 996     HV *hash;
 997     I32 i;
 998     int magic;
 999     U32 lval = 0;
1000
1001     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1002     gimme = GIMME_V;
1003     if (gimme == G_ARRAY)
1004         lval = PL_op->op_flags & OPf_MOD || LVRET;
1005
1006     /* If there's a common identifier on both sides we have to take
1007      * special care that assigning the identifier on the left doesn't
1008      * clobber a value on the right that's used later in the list.
1009      * Don't bother if LHS is just an empty hash or array.
1010      */
1011
1012     if (    (PL_op->op_private & OPpASSIGN_COMMON)
1013         &&  (
1014                firstlelem != lastlelem
1015             || ! ((sv = *firstlelem))
1016             || SvMAGICAL(sv)
1017             || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1018             || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1019             || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1020             )
1021     ) {
1022         EXTEND_MORTAL(lastrelem - firstrelem + 1);
1023         for (relem = firstrelem; relem <= lastrelem; relem++) {
1024             if ((sv = *relem)) {
1025                 TAINT_NOT;      /* Each item is independent */
1026
1027                 /* Dear TODO test in t/op/sort.t, I love you.
1028                    (It's relying on a panic, not a "semi-panic" from newSVsv()
1029                    and then an assertion failure below.)  */
1030                 if (SvIS_FREED(sv)) {
1031                     Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1032                                (void*)sv);
1033                 }
1034                 /* Not newSVsv(), as it does not allow copy-on-write,
1035                    resulting in wasteful copies.  We need a second copy of
1036                    a temp here, hence the SV_NOSTEAL.  */
1037                 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1038                                                |SV_NOSTEAL);
1039             }
1040         }
1041     }
1042
1043     relem = firstrelem;
1044     lelem = firstlelem;
1045     ary = NULL;
1046     hash = NULL;
1047
1048     while (lelem <= lastlelem) {
1049         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1050         sv = *lelem++;
1051         switch (SvTYPE(sv)) {
1052         case SVt_PVAV:
1053             ary = MUTABLE_AV(sv);
1054             magic = SvMAGICAL(ary) != 0;
1055             ENTER;
1056             SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1057             av_clear(ary);
1058             av_extend(ary, lastrelem - relem);
1059             i = 0;
1060             while (relem <= lastrelem) {        /* gobble up all the rest */
1061                 SV **didstore;
1062                 if (*relem)
1063                     SvGETMAGIC(*relem); /* before newSV, in case it dies */
1064                 sv = newSV(0);
1065                 sv_setsv_nomg(sv, *relem);
1066                 *(relem++) = sv;
1067                 didstore = av_store(ary,i++,sv);
1068                 if (magic) {
1069                     if (!didstore)
1070                         sv_2mortal(sv);
1071                     if (SvSMAGICAL(sv))
1072                         mg_set(sv);
1073                 }
1074                 TAINT_NOT;
1075             }
1076             if (PL_delaymagic & DM_ARRAY_ISA)
1077                 SvSETMAGIC(MUTABLE_SV(ary));
1078             LEAVE;
1079             break;
1080         case SVt_PVHV: {                                /* normal hash */
1081                 SV *tmpstr;
1082                 int odd;
1083                 int duplicates = 0;
1084                 SV** topelem = relem;
1085                 SV **firsthashrelem = relem;
1086
1087                 hash = MUTABLE_HV(sv);
1088                 magic = SvMAGICAL(hash) != 0;
1089
1090                 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1091                 if ( odd ) {
1092                     do_oddball(lastrelem, firsthashrelem);
1093                     /* we have firstlelem to reuse, it's not needed anymore
1094                      */
1095                     *(lastrelem+1) = &PL_sv_undef;
1096                 }
1097
1098                 ENTER;
1099                 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1100                 hv_clear(hash);
1101                 while (relem < lastrelem+odd) { /* gobble up all the rest */
1102                     HE *didstore;
1103                     assert(*relem);
1104                     /* Copy the key if aassign is called in lvalue context,
1105                        to avoid having the next op modify our rhs.  Copy
1106                        it also if it is gmagical, lest it make the
1107                        hv_store_ent call below croak, leaking the value. */
1108                     sv = lval || SvGMAGICAL(*relem)
1109                          ? sv_mortalcopy(*relem)
1110                          : *relem;
1111                     relem++;
1112                     assert(*relem);
1113                     SvGETMAGIC(*relem);
1114                     tmpstr = newSV(0);
1115                     sv_setsv_nomg(tmpstr,*relem++);     /* value */
1116                     if (gimme == G_ARRAY) {
1117                         if (hv_exists_ent(hash, sv, 0))
1118                             /* key overwrites an existing entry */
1119                             duplicates += 2;
1120                         else {
1121                             /* copy element back: possibly to an earlier
1122                              * stack location if we encountered dups earlier,
1123                              * possibly to a later stack location if odd */
1124                             *topelem++ = sv;
1125                             *topelem++ = tmpstr;
1126                         }
1127                     }
1128                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1129                     if (magic) {
1130                         if (!didstore) sv_2mortal(tmpstr);
1131                         SvSETMAGIC(tmpstr);
1132                     }
1133                     TAINT_NOT;
1134                 }
1135                 LEAVE;
1136                 if (duplicates && gimme == G_ARRAY) {
1137                     /* at this point we have removed the duplicate key/value
1138                      * pairs from the stack, but the remaining values may be
1139                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1140                      * the (a 2), but the stack now probably contains
1141                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1142                      * obliterates the earlier key. So refresh all values. */
1143                     lastrelem -= duplicates;
1144                     relem = firsthashrelem;
1145                     while (relem < lastrelem+odd) {
1146                         HE *he;
1147                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1148                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1149                     }
1150                 }
1151                 if (odd && gimme == G_ARRAY) lastrelem++;
1152             }
1153             break;
1154         default:
1155             if (SvIMMORTAL(sv)) {
1156                 if (relem <= lastrelem)
1157                     relem++;
1158                 break;
1159             }
1160             if (relem <= lastrelem) {
1161                 if (
1162                   SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1163                   (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1164                 )
1165                     Perl_warner(aTHX_
1166                        packWARN(WARN_MISC),
1167                       "Useless assignment to a temporary"
1168                     );
1169                 sv_setsv(sv, *relem);
1170                 *(relem++) = sv;
1171             }
1172             else
1173                 sv_setsv(sv, &PL_sv_undef);
1174             SvSETMAGIC(sv);
1175             break;
1176         }
1177     }
1178     if (PL_delaymagic & ~DM_DELAY) {
1179         /* Will be used to set PL_tainting below */
1180         Uid_t tmp_uid  = PerlProc_getuid();
1181         Uid_t tmp_euid = PerlProc_geteuid();
1182         Gid_t tmp_gid  = PerlProc_getgid();
1183         Gid_t tmp_egid = PerlProc_getegid();
1184
1185         if (PL_delaymagic & DM_UID) {
1186 #ifdef HAS_SETRESUID
1187             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1188                             (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1189                             (Uid_t)-1);
1190 #else
1191 #  ifdef HAS_SETREUID
1192             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1193                            (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1194 #  else
1195 #    ifdef HAS_SETRUID
1196             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1197                 (void)setruid(PL_delaymagic_uid);
1198                 PL_delaymagic &= ~DM_RUID;
1199             }
1200 #    endif /* HAS_SETRUID */
1201 #    ifdef HAS_SETEUID
1202             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1203                 (void)seteuid(PL_delaymagic_euid);
1204                 PL_delaymagic &= ~DM_EUID;
1205             }
1206 #    endif /* HAS_SETEUID */
1207             if (PL_delaymagic & DM_UID) {
1208                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1209                     DIE(aTHX_ "No setreuid available");
1210                 (void)PerlProc_setuid(PL_delaymagic_uid);
1211             }
1212 #  endif /* HAS_SETREUID */
1213 #endif /* HAS_SETRESUID */
1214             tmp_uid  = PerlProc_getuid();
1215             tmp_euid = PerlProc_geteuid();
1216         }
1217         if (PL_delaymagic & DM_GID) {
1218 #ifdef HAS_SETRESGID
1219             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1220                             (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1221                             (Gid_t)-1);
1222 #else
1223 #  ifdef HAS_SETREGID
1224             (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1225                            (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1226 #  else
1227 #    ifdef HAS_SETRGID
1228             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1229                 (void)setrgid(PL_delaymagic_gid);
1230                 PL_delaymagic &= ~DM_RGID;
1231             }
1232 #    endif /* HAS_SETRGID */
1233 #    ifdef HAS_SETEGID
1234             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1235                 (void)setegid(PL_delaymagic_egid);
1236                 PL_delaymagic &= ~DM_EGID;
1237             }
1238 #    endif /* HAS_SETEGID */
1239             if (PL_delaymagic & DM_GID) {
1240                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1241                     DIE(aTHX_ "No setregid available");
1242                 (void)PerlProc_setgid(PL_delaymagic_gid);
1243             }
1244 #  endif /* HAS_SETREGID */
1245 #endif /* HAS_SETRESGID */
1246             tmp_gid  = PerlProc_getgid();
1247             tmp_egid = PerlProc_getegid();
1248         }
1249         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1250 #ifdef NO_TAINT_SUPPORT
1251         PERL_UNUSED_VAR(tmp_uid);
1252         PERL_UNUSED_VAR(tmp_euid);
1253         PERL_UNUSED_VAR(tmp_gid);
1254         PERL_UNUSED_VAR(tmp_egid);
1255 #endif
1256     }
1257     PL_delaymagic = 0;
1258
1259     if (gimme == G_VOID)
1260         SP = firstrelem - 1;
1261     else if (gimme == G_SCALAR) {
1262         dTARGET;
1263         SP = firstrelem;
1264         SETi(lastrelem - firstrelem + 1);
1265     }
1266     else {
1267         if (ary || hash)
1268             /* note that in this case *firstlelem may have been overwritten
1269                by sv_undef in the odd hash case */
1270             SP = lastrelem;
1271         else {
1272             SP = firstrelem + (lastlelem - firstlelem);
1273             lelem = firstlelem + (relem - firstrelem);
1274             while (relem <= SP)
1275                 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1276         }
1277     }
1278
1279     RETURN;
1280 }
1281
1282 PP(pp_qr)
1283 {
1284     dVAR; dSP;
1285     PMOP * const pm = cPMOP;
1286     REGEXP * rx = PM_GETRE(pm);
1287     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1288     SV * const rv = sv_newmortal();
1289     CV **cvp;
1290     CV *cv;
1291
1292     SvUPGRADE(rv, SVt_IV);
1293     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1294        loathe to use it here, but it seems to be the right fix. Or close.
1295        The key part appears to be that it's essential for pp_qr to return a new
1296        object (SV), which implies that there needs to be an effective way to
1297        generate a new SV from the existing SV that is pre-compiled in the
1298        optree.  */
1299     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1300     SvROK_on(rv);
1301
1302     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1303     if ((cv = *cvp) && CvCLONE(*cvp)) {
1304         *cvp = cv_clone(cv);
1305         SvREFCNT_dec_NN(cv);
1306     }
1307
1308     if (pkg) {
1309         HV *const stash = gv_stashsv(pkg, GV_ADD);
1310         SvREFCNT_dec_NN(pkg);
1311         (void)sv_bless(rv, stash);
1312     }
1313
1314     if (RX_ISTAINTED(rx)) {
1315         SvTAINTED_on(rv);
1316         SvTAINTED_on(SvRV(rv));
1317     }
1318     XPUSHs(rv);
1319     RETURN;
1320 }
1321
1322 PP(pp_match)
1323 {
1324     dVAR; dSP; dTARG;
1325     PMOP *pm = cPMOP;
1326     PMOP *dynpm = pm;
1327     const char *s;
1328     const char *strend;
1329     I32 curpos = 0; /* initial pos() or current $+[0] */
1330     I32 global;
1331     U8 r_flags = 0;
1332     const char *truebase;                       /* Start of string  */
1333     REGEXP *rx = PM_GETRE(pm);
1334     bool rxtainted;
1335     const I32 gimme = GIMME;
1336     STRLEN len;
1337     const I32 oldsave = PL_savestack_ix;
1338     I32 had_zerolen = 0;
1339     MAGIC *mg = NULL;
1340
1341     if (PL_op->op_flags & OPf_STACKED)
1342         TARG = POPs;
1343     else if (PL_op->op_private & OPpTARGET_MY)
1344         GETTARGET;
1345     else {
1346         TARG = DEFSV;
1347         EXTEND(SP,1);
1348     }
1349
1350     PUTBACK;                            /* EVAL blocks need stack_sp. */
1351     /* Skip get-magic if this is a qr// clone, because regcomp has
1352        already done it. */
1353     truebase = ReANY(rx)->mother_re
1354          ? SvPV_nomg_const(TARG, len)
1355          : SvPV_const(TARG, len);
1356     if (!truebase)
1357         DIE(aTHX_ "panic: pp_match");
1358     strend = truebase + len;
1359     rxtainted = (RX_ISTAINTED(rx) ||
1360                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1361     TAINT_NOT;
1362
1363     /* We need to know this in case we fail out early - pos() must be reset */
1364     global = dynpm->op_pmflags & PMf_GLOBAL;
1365
1366     /* PMdf_USED is set after a ?? matches once */
1367     if (
1368 #ifdef USE_ITHREADS
1369         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1370 #else
1371         pm->op_pmflags & PMf_USED
1372 #endif
1373     ) {
1374         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1375         goto nope;
1376     }
1377
1378     /* empty pattern special-cased to use last successful pattern if
1379        possible, except for qr// */
1380     if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1381      && PL_curpm) {
1382         pm = PL_curpm;
1383         rx = PM_GETRE(pm);
1384     }
1385
1386     if (RX_MINLEN(rx) > (I32)len) {
1387         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
1388         goto nope;
1389     }
1390
1391     /* get pos() if //g */
1392     if (global) {
1393         mg = mg_find_mglob(TARG);
1394         if (mg && mg->mg_len >= 0) {
1395             curpos = mg->mg_len;
1396             /* last time pos() was set, it was zero-length match */
1397             if (mg->mg_flags & MGf_MINMATCH)
1398                 had_zerolen = 1;
1399         }
1400     }
1401
1402 #ifdef PERL_SAWAMPERSAND
1403     if (       RX_NPARENS(rx)
1404             || PL_sawampersand
1405             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1406             || (dynpm->op_pmflags & PMf_KEEPCOPY)
1407     )
1408 #endif
1409     {
1410         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1411         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1412          * only on the first iteration. Therefore we need to copy $' as well
1413          * as $&, to make the rest of the string available for captures in
1414          * subsequent iterations */
1415         if (! (global && gimme == G_ARRAY))
1416             r_flags |= REXEC_COPY_SKIP_POST;
1417     };
1418 #ifdef PERL_SAWAMPERSAND
1419     if (dynpm->op_pmflags & PMf_KEEPCOPY)
1420         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1421         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1422 #endif
1423
1424     s = truebase;
1425
1426   play_it_again:
1427     if (global)
1428         s = truebase + curpos;
1429
1430     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1431                      had_zerolen, TARG, NULL, r_flags))
1432         goto nope;
1433
1434     PL_curpm = pm;
1435     if (dynpm->op_pmflags & PMf_ONCE)
1436 #ifdef USE_ITHREADS
1437         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1438 #else
1439         dynpm->op_pmflags |= PMf_USED;
1440 #endif
1441
1442     if (rxtainted)
1443         RX_MATCH_TAINTED_on(rx);
1444     TAINT_IF(RX_MATCH_TAINTED(rx));
1445
1446     /* update pos */
1447
1448     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1449         if (!mg)
1450             mg = sv_magicext_mglob(TARG);
1451         mg->mg_len = RX_OFFS(rx)[0].end;
1452         if (RX_ZERO_LEN(rx))
1453             mg->mg_flags |= MGf_MINMATCH;
1454         else
1455             mg->mg_flags &= ~MGf_MINMATCH;
1456     }
1457
1458     if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1459         LEAVE_SCOPE(oldsave);
1460         RETPUSHYES;
1461     }
1462
1463     /* push captures on stack */
1464
1465     {
1466         const I32 nparens = RX_NPARENS(rx);
1467         I32 i = (global && !nparens) ? 1 : 0;
1468
1469         SPAGAIN;                        /* EVAL blocks could move the stack. */
1470         EXTEND(SP, nparens + i);
1471         EXTEND_MORTAL(nparens + i);
1472         for (i = !i; i <= nparens; i++) {
1473             PUSHs(sv_newmortal());
1474             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1475                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1476                 const char * const s = RX_OFFS(rx)[i].start + truebase;
1477                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1478                     len < 0 || len > strend - s)
1479                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1480                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1481                         (long) i, (long) RX_OFFS(rx)[i].start,
1482                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1483                 sv_setpvn(*SP, s, len);
1484                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1485                     SvUTF8_on(*SP);
1486             }
1487         }
1488         if (global) {
1489             curpos = (UV)RX_OFFS(rx)[0].end;
1490             had_zerolen = RX_ZERO_LEN(rx);
1491             PUTBACK;                    /* EVAL blocks may use stack */
1492             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1493             goto play_it_again;
1494         }
1495         LEAVE_SCOPE(oldsave);
1496         RETURN;
1497     }
1498     /* NOTREACHED */
1499
1500 nope:
1501     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1502         if (!mg)
1503             mg = mg_find_mglob(TARG);
1504         if (mg)
1505             mg->mg_len = -1;
1506     }
1507     LEAVE_SCOPE(oldsave);
1508     if (gimme == G_ARRAY)
1509         RETURN;
1510     RETPUSHNO;
1511 }
1512
1513 OP *
1514 Perl_do_readline(pTHX)
1515 {
1516     dVAR; dSP; dTARGETSTACKED;
1517     SV *sv;
1518     STRLEN tmplen = 0;
1519     STRLEN offset;
1520     PerlIO *fp;
1521     IO * const io = GvIO(PL_last_in_gv);
1522     const I32 type = PL_op->op_type;
1523     const I32 gimme = GIMME_V;
1524
1525     if (io) {
1526         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1527         if (mg) {
1528             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1529             if (gimme == G_SCALAR) {
1530                 SPAGAIN;
1531                 SvSetSV_nosteal(TARG, TOPs);
1532                 SETTARG;
1533             }
1534             return NORMAL;
1535         }
1536     }
1537     fp = NULL;
1538     if (io) {
1539         fp = IoIFP(io);
1540         if (!fp) {
1541             if (IoFLAGS(io) & IOf_ARGV) {
1542                 if (IoFLAGS(io) & IOf_START) {
1543                     IoLINES(io) = 0;
1544                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1545                         IoFLAGS(io) &= ~IOf_START;
1546                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1547                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1548                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1549                         SvSETMAGIC(GvSV(PL_last_in_gv));
1550                         fp = IoIFP(io);
1551                         goto have_fp;
1552                     }
1553                 }
1554                 fp = nextargv(PL_last_in_gv);
1555                 if (!fp) { /* Note: fp != IoIFP(io) */
1556                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1557                 }
1558             }
1559             else if (type == OP_GLOB)
1560                 fp = Perl_start_glob(aTHX_ POPs, io);
1561         }
1562         else if (type == OP_GLOB)
1563             SP--;
1564         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1565             report_wrongway_fh(PL_last_in_gv, '>');
1566         }
1567     }
1568     if (!fp) {
1569         if ((!io || !(IoFLAGS(io) & IOf_START))
1570             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1571         {
1572             if (type == OP_GLOB)
1573                 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
1574                             "glob failed (can't start child: %s)",
1575                             Strerror(errno));
1576             else
1577                 report_evil_fh(PL_last_in_gv);
1578         }
1579         if (gimme == G_SCALAR) {
1580             /* undef TARG, and push that undefined value */
1581             if (type != OP_RCATLINE) {
1582                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1583                 SvOK_off(TARG);
1584             }
1585             PUSHTARG;
1586         }
1587         RETURN;
1588     }
1589   have_fp:
1590     if (gimme == G_SCALAR) {
1591         sv = TARG;
1592         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1593             mg_get(sv);
1594         if (SvROK(sv)) {
1595             if (type == OP_RCATLINE)
1596                 SvPV_force_nomg_nolen(sv);
1597             else
1598                 sv_unref(sv);
1599         }
1600         else if (isGV_with_GP(sv)) {
1601             SvPV_force_nomg_nolen(sv);
1602         }
1603         SvUPGRADE(sv, SVt_PV);
1604         tmplen = SvLEN(sv);     /* remember if already alloced */
1605         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1606             /* try short-buffering it. Please update t/op/readline.t
1607              * if you change the growth length.
1608              */
1609             Sv_Grow(sv, 80);
1610         }
1611         offset = 0;
1612         if (type == OP_RCATLINE && SvOK(sv)) {
1613             if (!SvPOK(sv)) {
1614                 SvPV_force_nomg_nolen(sv);
1615             }
1616             offset = SvCUR(sv);
1617         }
1618     }
1619     else {
1620         sv = sv_2mortal(newSV(80));
1621         offset = 0;
1622     }
1623
1624     /* This should not be marked tainted if the fp is marked clean */
1625 #define MAYBE_TAINT_LINE(io, sv) \
1626     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1627         TAINT;                          \
1628         SvTAINTED_on(sv);               \
1629     }
1630
1631 /* delay EOF state for a snarfed empty file */
1632 #define SNARF_EOF(gimme,rs,io,sv) \
1633     (gimme != G_SCALAR || SvCUR(sv)                                     \
1634      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1635
1636     for (;;) {
1637         PUTBACK;
1638         if (!sv_gets(sv, fp, offset)
1639             && (type == OP_GLOB
1640                 || SNARF_EOF(gimme, PL_rs, io, sv)
1641                 || PerlIO_error(fp)))
1642         {
1643             PerlIO_clearerr(fp);
1644             if (IoFLAGS(io) & IOf_ARGV) {
1645                 fp = nextargv(PL_last_in_gv);
1646                 if (fp)
1647                     continue;
1648                 (void)do_close(PL_last_in_gv, FALSE);
1649             }
1650             else if (type == OP_GLOB) {
1651                 if (!do_close(PL_last_in_gv, FALSE)) {
1652                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1653                                    "glob failed (child exited with status %d%s)",
1654                                    (int)(STATUS_CURRENT >> 8),
1655                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1656                 }
1657             }
1658             if (gimme == G_SCALAR) {
1659                 if (type != OP_RCATLINE) {
1660                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1661                     SvOK_off(TARG);
1662                 }
1663                 SPAGAIN;
1664                 PUSHTARG;
1665             }
1666             MAYBE_TAINT_LINE(io, sv);
1667             RETURN;
1668         }
1669         MAYBE_TAINT_LINE(io, sv);
1670         IoLINES(io)++;
1671         IoFLAGS(io) |= IOf_NOLINE;
1672         SvSETMAGIC(sv);
1673         SPAGAIN;
1674         XPUSHs(sv);
1675         if (type == OP_GLOB) {
1676             const char *t1;
1677
1678             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1679                 char * const tmps = SvEND(sv) - 1;
1680                 if (*tmps == *SvPVX_const(PL_rs)) {
1681                     *tmps = '\0';
1682                     SvCUR_set(sv, SvCUR(sv) - 1);
1683                 }
1684             }
1685             for (t1 = SvPVX_const(sv); *t1; t1++)
1686                 if (!isALPHANUMERIC(*t1) &&
1687                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1688                         break;
1689             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1690                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1691                 continue;
1692             }
1693         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1694              if (ckWARN(WARN_UTF8)) {
1695                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1696                 const STRLEN len = SvCUR(sv) - offset;
1697                 const U8 *f;
1698
1699                 if (!is_utf8_string_loc(s, len, &f))
1700                     /* Emulate :encoding(utf8) warning in the same case. */
1701                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1702                                 "utf8 \"\\x%02X\" does not map to Unicode",
1703                                 f < (U8*)SvEND(sv) ? *f : 0);
1704              }
1705         }
1706         if (gimme == G_ARRAY) {
1707             if (SvLEN(sv) - SvCUR(sv) > 20) {
1708                 SvPV_shrink_to_cur(sv);
1709             }
1710             sv = sv_2mortal(newSV(80));
1711             continue;
1712         }
1713         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1714             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1715             const STRLEN new_len
1716                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1717             SvPV_renew(sv, new_len);
1718         }
1719         RETURN;
1720     }
1721 }
1722
1723 PP(pp_helem)
1724 {
1725     dVAR; dSP;
1726     HE* he;
1727     SV **svp;
1728     SV * const keysv = POPs;
1729     HV * const hv = MUTABLE_HV(POPs);
1730     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1731     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1732     SV *sv;
1733     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1734     bool preeminent = TRUE;
1735
1736     if (SvTYPE(hv) != SVt_PVHV)
1737         RETPUSHUNDEF;
1738
1739     if (localizing) {
1740         MAGIC *mg;
1741         HV *stash;
1742
1743         /* If we can determine whether the element exist,
1744          * Try to preserve the existenceness of a tied hash
1745          * element by using EXISTS and DELETE if possible.
1746          * Fallback to FETCH and STORE otherwise. */
1747         if (SvCANEXISTDELETE(hv))
1748             preeminent = hv_exists_ent(hv, keysv, 0);
1749     }
1750
1751     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1752     svp = he ? &HeVAL(he) : NULL;
1753     if (lval) {
1754         if (!svp || !*svp || *svp == &PL_sv_undef) {
1755             SV* lv;
1756             SV* key2;
1757             if (!defer) {
1758                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1759             }
1760             lv = sv_newmortal();
1761             sv_upgrade(lv, SVt_PVLV);
1762             LvTYPE(lv) = 'y';
1763             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1764             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
1765             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1766             LvTARGLEN(lv) = 1;
1767             PUSHs(lv);
1768             RETURN;
1769         }
1770         if (localizing) {
1771             if (HvNAME_get(hv) && isGV(*svp))
1772                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1773             else if (preeminent)
1774                 save_helem_flags(hv, keysv, svp,
1775                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1776             else
1777                 SAVEHDELETE(hv, keysv);
1778         }
1779         else if (PL_op->op_private & OPpDEREF) {
1780             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1781             RETURN;
1782         }
1783     }
1784     sv = (svp && *svp ? *svp : &PL_sv_undef);
1785     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1786      * was to make C<local $tied{foo} = $tied{foo}> possible.
1787      * However, it seems no longer to be needed for that purpose, and
1788      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1789      * would loop endlessly since the pos magic is getting set on the
1790      * mortal copy and lost. However, the copy has the effect of
1791      * triggering the get magic, and losing it altogether made things like
1792      * c<$tied{foo};> in void context no longer do get magic, which some
1793      * code relied on. Also, delayed triggering of magic on @+ and friends
1794      * meant the original regex may be out of scope by now. So as a
1795      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1796      * being called too many times). */
1797     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1798         mg_get(sv);
1799     PUSHs(sv);
1800     RETURN;
1801 }
1802
1803 PP(pp_iter)
1804 {
1805     dVAR; dSP;
1806     PERL_CONTEXT *cx;
1807     SV *oldsv;
1808     SV **itersvp;
1809
1810     EXTEND(SP, 1);
1811     cx = &cxstack[cxstack_ix];
1812     itersvp = CxITERVAR(cx);
1813
1814     switch (CxTYPE(cx)) {
1815
1816     case CXt_LOOP_LAZYSV: /* string increment */
1817     {
1818         SV* cur = cx->blk_loop.state_u.lazysv.cur;
1819         SV *end = cx->blk_loop.state_u.lazysv.end;
1820         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1821            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1822         STRLEN maxlen = 0;
1823         const char *max = SvPV_const(end, maxlen);
1824         if (SvNIOK(cur) || SvCUR(cur) > maxlen)
1825             RETPUSHNO;
1826
1827         oldsv = *itersvp;
1828         if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1829             /* safe to reuse old SV */
1830             sv_setsv(oldsv, cur);
1831         }
1832         else
1833         {
1834             /* we need a fresh SV every time so that loop body sees a
1835              * completely new SV for closures/references to work as
1836              * they used to */
1837             *itersvp = newSVsv(cur);
1838             SvREFCNT_dec_NN(oldsv);
1839         }
1840         if (strEQ(SvPVX_const(cur), max))
1841             sv_setiv(cur, 0); /* terminate next time */
1842         else
1843             sv_inc(cur);
1844         break;
1845     }
1846
1847     case CXt_LOOP_LAZYIV: /* integer increment */
1848     {
1849         IV cur = cx->blk_loop.state_u.lazyiv.cur;
1850         if (cur > cx->blk_loop.state_u.lazyiv.end)
1851             RETPUSHNO;
1852
1853         oldsv = *itersvp;
1854         /* don't risk potential race */
1855         if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1856             /* safe to reuse old SV */
1857             sv_setiv(oldsv, cur);
1858         }
1859         else
1860         {
1861             /* we need a fresh SV every time so that loop body sees a
1862              * completely new SV for closures/references to work as they
1863              * used to */
1864             *itersvp = newSViv(cur);
1865             SvREFCNT_dec_NN(oldsv);
1866         }
1867
1868         if (cur == IV_MAX) {
1869             /* Handle end of range at IV_MAX */
1870             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1871         } else
1872             ++cx->blk_loop.state_u.lazyiv.cur;
1873         break;
1874     }
1875
1876     case CXt_LOOP_FOR: /* iterate array */
1877     {
1878
1879         AV *av = cx->blk_loop.state_u.ary.ary;
1880         SV *sv;
1881         bool av_is_stack = FALSE;
1882         IV ix;
1883
1884         if (!av) {
1885             av_is_stack = TRUE;
1886             av = PL_curstack;
1887         }
1888         if (PL_op->op_private & OPpITER_REVERSED) {
1889             ix = --cx->blk_loop.state_u.ary.ix;
1890             if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
1891                 RETPUSHNO;
1892         }
1893         else {
1894             ix = ++cx->blk_loop.state_u.ary.ix;
1895             if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
1896                 RETPUSHNO;
1897         }
1898
1899         if (SvMAGICAL(av) || AvREIFY(av)) {
1900             SV * const * const svp = av_fetch(av, ix, FALSE);
1901             sv = svp ? *svp : NULL;
1902         }
1903         else {
1904             sv = AvARRAY(av)[ix];
1905         }
1906
1907         if (sv) {
1908             if (SvIS_FREED(sv)) {
1909                 *itersvp = NULL;
1910                 Perl_croak(aTHX_ "Use of freed value in iteration");
1911             }
1912             if (SvPADTMP(sv) && !IS_PADGV(sv))
1913                 sv = newSVsv(sv);
1914             else {
1915                 SvTEMP_off(sv);
1916                 SvREFCNT_inc_simple_void_NN(sv);
1917             }
1918         }
1919         else
1920             sv = &PL_sv_undef;
1921
1922         if (!av_is_stack && sv == &PL_sv_undef) {
1923             SV *lv = newSV_type(SVt_PVLV);
1924             LvTYPE(lv) = 'y';
1925             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1926             LvTARG(lv) = SvREFCNT_inc_simple(av);
1927             LvTARGOFF(lv) = ix;
1928             LvTARGLEN(lv) = (STRLEN)UV_MAX;
1929             sv = lv;
1930         }
1931
1932         oldsv = *itersvp;
1933         *itersvp = sv;
1934         SvREFCNT_dec(oldsv);
1935         break;
1936     }
1937
1938     default:
1939         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1940     }
1941     RETPUSHYES;
1942 }
1943
1944 /*
1945 A description of how taint works in pattern matching and substitution.
1946
1947 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1948 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1949
1950 While the pattern is being assembled/concatenated and then compiled,
1951 PL_tainted will get set (via TAINT_set) if any component of the pattern
1952 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
1953 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1954 TAINT_get).
1955
1956 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1957 the pattern is marked as tainted. This means that subsequent usage, such
1958 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1959 on the new pattern too.
1960
1961 At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the
1962 regex is cleared; during execution, locale-variant ops such as POSIXL may
1963 set RXf_TAINTED_SEEN.
1964
1965 RXf_TAINTED_SEEN is used post-execution by the get magic code
1966 of $1 et al to indicate whether the returned value should be tainted.
1967 It is the responsibility of the caller of the pattern (i.e. pp_match,
1968 pp_subst etc) to set this flag for any other circumstances where $1 needs
1969 to be tainted.
1970
1971 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1972
1973 There are three possible sources of taint
1974     * the source string
1975     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1976     * the replacement string (or expression under /e)
1977
1978 There are four destinations of taint and they are affected by the sources
1979 according to the rules below:
1980
1981     * the return value (not including /r):
1982         tainted by the source string and pattern, but only for the
1983         number-of-iterations case; boolean returns aren't tainted;
1984     * the modified string (or modified copy under /r):
1985         tainted by the source string, pattern, and replacement strings;
1986     * $1 et al:
1987         tainted by the pattern, and under 'use re "taint"', by the source
1988         string too;
1989     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
1990         should always be unset before executing subsequent code.
1991
1992 The overall action of pp_subst is:
1993
1994     * at the start, set bits in rxtainted indicating the taint status of
1995         the various sources.
1996
1997     * After each pattern execution, update the SUBST_TAINT_PAT bit in
1998         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
1999         pattern has subsequently become tainted via locale ops.
2000
2001     * If control is being passed to pp_substcont to execute a /e block,
2002         save rxtainted in the CXt_SUBST block, for future use by
2003         pp_substcont.
2004
2005     * Whenever control is being returned to perl code (either by falling
2006         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2007         use the flag bits in rxtainted to make all the appropriate types of
2008         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2009         et al will appear tainted.
2010
2011 pp_match is just a simpler version of the above.
2012
2013 */
2014
2015 PP(pp_subst)
2016 {
2017     dVAR; dSP; dTARG;
2018     PMOP *pm = cPMOP;
2019     PMOP *rpm = pm;
2020     char *s;
2021     char *strend;
2022     const char *c;
2023     STRLEN clen;
2024     I32 iters = 0;
2025     I32 maxiters;
2026     bool once;
2027     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2028                         See "how taint works" above */
2029     char *orig;
2030     U8 r_flags;
2031     REGEXP *rx = PM_GETRE(pm);
2032     STRLEN len;
2033     int force_on_match = 0;
2034     const I32 oldsave = PL_savestack_ix;
2035     STRLEN slen;
2036     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2037 #ifdef PERL_ANY_COW
2038     bool is_cow;
2039 #endif
2040     SV *nsv = NULL;
2041     /* known replacement string? */
2042     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2043
2044     PERL_ASYNC_CHECK();
2045
2046     if (PL_op->op_flags & OPf_STACKED)
2047         TARG = POPs;
2048     else if (PL_op->op_private & OPpTARGET_MY)
2049         GETTARGET;
2050     else {
2051         TARG = DEFSV;
2052         EXTEND(SP,1);
2053     }
2054
2055     SvGETMAGIC(TARG); /* must come before cow check */
2056 #ifdef PERL_ANY_COW
2057     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2058        because they make integers such as 256 "false".  */
2059     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2060 #else
2061     if (SvIsCOW(TARG))
2062         sv_force_normal_flags(TARG,0);
2063 #endif
2064     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2065         && (SvREADONLY(TARG)
2066             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2067                   || SvTYPE(TARG) > SVt_PVLV)
2068                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2069         Perl_croak_no_modify();
2070     PUTBACK;
2071
2072     orig = SvPV_nomg(TARG, len);
2073     /* note we don't (yet) force the var into being a string; if we fail
2074      * to match, we leave as-is; on successful match howeverm, we *will*
2075      * coerce into a string, then repeat the match */
2076     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2077         force_on_match = 1;
2078
2079     /* only replace once? */
2080     once = !(rpm->op_pmflags & PMf_GLOBAL);
2081
2082     /* See "how taint works" above */
2083     if (TAINTING_get) {
2084         rxtainted  = (
2085             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2086           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2087           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2088           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2089                 ? SUBST_TAINT_BOOLRET : 0));
2090         TAINT_NOT;
2091     }
2092
2093   force_it:
2094     if (!pm || !orig)
2095         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2096
2097     strend = orig + len;
2098     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2099     maxiters = 2 * slen + 10;   /* We can match twice at each
2100                                    position, once with zero-length,
2101                                    second time with non-zero. */
2102
2103     if (!RX_PRELEN(rx) && PL_curpm
2104      && !ReANY(rx)->mother_re) {
2105         pm = PL_curpm;
2106         rx = PM_GETRE(pm);
2107     }
2108
2109 #ifdef PERL_SAWAMPERSAND
2110     r_flags = (    RX_NPARENS(rx)
2111                 || PL_sawampersand
2112                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2113                 || (rpm->op_pmflags & PMf_KEEPCOPY)
2114               )
2115           ? REXEC_COPY_STR
2116           : 0;
2117 #else
2118     r_flags = REXEC_COPY_STR;
2119 #endif
2120
2121     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2122     {
2123         SPAGAIN;
2124         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2125         LEAVE_SCOPE(oldsave);
2126         RETURN;
2127     }
2128     PL_curpm = pm;
2129
2130     /* known replacement string? */
2131     if (dstr) {
2132         /* replacement needing upgrading? */
2133         if (DO_UTF8(TARG) && !doutf8) {
2134              nsv = sv_newmortal();
2135              SvSetSV(nsv, dstr);
2136              if (PL_encoding)
2137                   sv_recode_to_utf8(nsv, PL_encoding);
2138              else
2139                   sv_utf8_upgrade(nsv);
2140              c = SvPV_const(nsv, clen);
2141              doutf8 = TRUE;
2142         }
2143         else {
2144             c = SvPV_const(dstr, clen);
2145             doutf8 = DO_UTF8(dstr);
2146         }
2147
2148         if (SvTAINTED(dstr))
2149             rxtainted |= SUBST_TAINT_REPL;
2150     }
2151     else {
2152         c = NULL;
2153         doutf8 = FALSE;
2154     }
2155
2156     /* can do inplace substitution? */
2157     if (c
2158 #ifdef PERL_ANY_COW
2159         && !is_cow
2160 #endif
2161         && (I32)clen <= RX_MINLENRET(rx)
2162         && (once || !(r_flags & REXEC_COPY_STR))
2163         && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2164         && (!doutf8 || SvUTF8(TARG))
2165         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2166     {
2167
2168 #ifdef PERL_ANY_COW
2169         if (SvIsCOW(TARG)) {
2170           if (!force_on_match)
2171             goto have_a_cow;
2172           assert(SvVOK(TARG));
2173         }
2174 #endif
2175         if (force_on_match) {
2176             /* redo the first match, this time with the orig var
2177              * forced into being a string */
2178             force_on_match = 0;
2179             orig = SvPV_force_nomg(TARG, len);
2180             goto force_it;
2181         }
2182
2183         if (once) {
2184             char *d, *m;
2185             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2186                 rxtainted |= SUBST_TAINT_PAT;
2187             m = orig + RX_OFFS(rx)[0].start;
2188             d = orig + RX_OFFS(rx)[0].end;
2189             s = orig;
2190             if (m - s > strend - d) {  /* faster to shorten from end */
2191                 I32 i;
2192                 if (clen) {
2193                     Copy(c, m, clen, char);
2194                     m += clen;
2195                 }
2196                 i = strend - d;
2197                 if (i > 0) {
2198                     Move(d, m, i, char);
2199                     m += i;
2200                 }
2201                 *m = '\0';
2202                 SvCUR_set(TARG, m - s);
2203             }
2204             else {      /* faster from front */
2205                 I32 i = m - s;
2206                 d -= clen;
2207                 if (i > 0)
2208                     Move(s, d - i, i, char);
2209                 sv_chop(TARG, d-i);
2210                 if (clen)
2211                     Copy(c, d, clen, char);
2212             }
2213             SPAGAIN;
2214             PUSHs(&PL_sv_yes);
2215         }
2216         else {
2217             char *d, *m;
2218             d = s = RX_OFFS(rx)[0].start + orig;
2219             do {
2220                 I32 i;
2221                 if (iters++ > maxiters)
2222                     DIE(aTHX_ "Substitution loop");
2223                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2224                     rxtainted |= SUBST_TAINT_PAT;
2225                 m = RX_OFFS(rx)[0].start + orig;
2226                 if ((i = m - s)) {
2227                     if (s != d)
2228                         Move(s, d, i, char);
2229                     d += i;
2230                 }
2231                 if (clen) {
2232                     Copy(c, d, clen, char);
2233                     d += clen;
2234                 }
2235                 s = RX_OFFS(rx)[0].end + orig;
2236             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2237                                  TARG, NULL,
2238                                  /* don't match same null twice */
2239                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2240             if (s != d) {
2241                 I32 i = strend - s;
2242                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2243                 Move(s, d, i+1, char);          /* include the NUL */
2244             }
2245             SPAGAIN;
2246             mPUSHi((I32)iters);
2247         }
2248     }
2249     else {
2250         bool first;
2251         char *m;
2252         SV *repl;
2253         if (force_on_match) {
2254             /* redo the first match, this time with the orig var
2255              * forced into being a string */
2256             force_on_match = 0;
2257             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2258                 /* I feel that it should be possible to avoid this mortal copy
2259                    given that the code below copies into a new destination.
2260                    However, I suspect it isn't worth the complexity of
2261                    unravelling the C<goto force_it> for the small number of
2262                    cases where it would be viable to drop into the copy code. */
2263                 TARG = sv_2mortal(newSVsv(TARG));
2264             }
2265             orig = SvPV_force_nomg(TARG, len);
2266             goto force_it;
2267         }
2268 #ifdef PERL_ANY_COW
2269       have_a_cow:
2270 #endif
2271         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2272             rxtainted |= SUBST_TAINT_PAT;
2273         repl = dstr;
2274         s = RX_OFFS(rx)[0].start + orig;
2275         dstr = newSVpvn_flags(orig, s-orig,
2276                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2277         if (!c) {
2278             PERL_CONTEXT *cx;
2279             SPAGAIN;
2280             m = orig;
2281             /* note that a whole bunch of local vars are saved here for
2282              * use by pp_substcont: here's a list of them in case you're
2283              * searching for places in this sub that uses a particular var:
2284              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2285              * s m strend rx once */
2286             PUSHSUBST(cx);
2287             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2288         }
2289         first = TRUE;
2290         do {
2291             if (iters++ > maxiters)
2292                 DIE(aTHX_ "Substitution loop");
2293             if (RX_MATCH_TAINTED(rx))
2294                 rxtainted |= SUBST_TAINT_PAT;
2295             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2296                 char *old_s    = s;
2297                 char *old_orig = orig;
2298                 assert(RX_SUBOFFSET(rx) == 0);
2299
2300                 orig = RX_SUBBEG(rx);
2301                 s = orig + (old_s - old_orig);
2302                 strend = s + (strend - old_s);
2303             }
2304             m = RX_OFFS(rx)[0].start + orig;
2305             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2306             s = RX_OFFS(rx)[0].end + orig;
2307             if (first) {
2308                 /* replacement already stringified */
2309               if (clen)
2310                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2311               first = FALSE;
2312             }
2313             else {
2314                 if (PL_encoding) {
2315                     if (!nsv) nsv = sv_newmortal();
2316                     sv_copypv(nsv, repl);
2317                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2318                     sv_catsv(dstr, nsv);
2319                 }
2320                 else sv_catsv(dstr, repl);
2321                 if (SvTAINTED(repl))
2322                     rxtainted |= SUBST_TAINT_REPL;
2323             }
2324             if (once)
2325                 break;
2326         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2327                              TARG, NULL,
2328                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2329         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2330
2331         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2332             /* From here on down we're using the copy, and leaving the original
2333                untouched.  */
2334             TARG = dstr;
2335             SPAGAIN;
2336             PUSHs(dstr);
2337         } else {
2338 #ifdef PERL_ANY_COW
2339             /* The match may make the string COW. If so, brilliant, because
2340                that's just saved us one malloc, copy and free - the regexp has
2341                donated the old buffer, and we malloc an entirely new one, rather
2342                than the regexp malloc()ing a buffer and copying our original,
2343                only for us to throw it away here during the substitution.  */
2344             if (SvIsCOW(TARG)) {
2345                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2346             } else
2347 #endif
2348             {
2349                 SvPV_free(TARG);
2350             }
2351             SvPV_set(TARG, SvPVX(dstr));
2352             SvCUR_set(TARG, SvCUR(dstr));
2353             SvLEN_set(TARG, SvLEN(dstr));
2354             SvFLAGS(TARG) |= SvUTF8(dstr);
2355             SvPV_set(dstr, NULL);
2356
2357             SPAGAIN;
2358             mPUSHi((I32)iters);
2359         }
2360     }
2361
2362     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2363         (void)SvPOK_only_UTF8(TARG);
2364     }
2365
2366     /* See "how taint works" above */
2367     if (TAINTING_get) {
2368         if ((rxtainted & SUBST_TAINT_PAT) ||
2369             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2370                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2371         )
2372             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2373
2374         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2375             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2376         )
2377             SvTAINTED_on(TOPs);  /* taint return value */
2378         else
2379             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2380
2381         /* needed for mg_set below */
2382         TAINT_set(
2383           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2384         );
2385         SvTAINT(TARG);
2386     }
2387     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2388     TAINT_NOT;
2389     LEAVE_SCOPE(oldsave);
2390     RETURN;
2391 }
2392
2393 PP(pp_grepwhile)
2394 {
2395     dVAR; dSP;
2396
2397     if (SvTRUEx(POPs))
2398         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2399     ++*PL_markstack_ptr;
2400     FREETMPS;
2401     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2402
2403     /* All done yet? */
2404     if (PL_stack_base + *PL_markstack_ptr > SP) {
2405         I32 items;
2406         const I32 gimme = GIMME_V;
2407
2408         LEAVE_with_name("grep");                                        /* exit outer scope */
2409         (void)POPMARK;                          /* pop src */
2410         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2411         (void)POPMARK;                          /* pop dst */
2412         SP = PL_stack_base + POPMARK;           /* pop original mark */
2413         if (gimme == G_SCALAR) {
2414             if (PL_op->op_private & OPpGREP_LEX) {
2415                 SV* const sv = sv_newmortal();
2416                 sv_setiv(sv, items);
2417                 PUSHs(sv);
2418             }
2419             else {
2420                 dTARGET;
2421                 XPUSHi(items);
2422             }
2423         }
2424         else if (gimme == G_ARRAY)
2425             SP += items;
2426         RETURN;
2427     }
2428     else {
2429         SV *src;
2430
2431         ENTER_with_name("grep_item");                                   /* enter inner scope */
2432         SAVEVPTR(PL_curpm);
2433
2434         src = PL_stack_base[*PL_markstack_ptr];
2435         if (SvPADTMP(src) && !IS_PADGV(src)) {
2436             src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2437             PL_tmps_floor++;
2438         }
2439         SvTEMP_off(src);
2440         if (PL_op->op_private & OPpGREP_LEX)
2441             PAD_SVl(PL_op->op_targ) = src;
2442         else
2443             DEFSV_set(src);
2444
2445         RETURNOP(cLOGOP->op_other);
2446     }
2447 }
2448
2449 PP(pp_leavesub)
2450 {
2451     dVAR; dSP;
2452     SV **mark;
2453     SV **newsp;
2454     PMOP *newpm;
2455     I32 gimme;
2456     PERL_CONTEXT *cx;
2457     SV *sv;
2458
2459     if (CxMULTICALL(&cxstack[cxstack_ix]))
2460         return 0;
2461
2462     POPBLOCK(cx,newpm);
2463     cxstack_ix++; /* temporarily protect top context */
2464
2465     TAINT_NOT;
2466     if (gimme == G_SCALAR) {
2467         MARK = newsp + 1;
2468         if (MARK <= SP) {
2469             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2470                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2471                      && !SvMAGICAL(TOPs)) {
2472                     *MARK = SvREFCNT_inc(TOPs);
2473                     FREETMPS;
2474                     sv_2mortal(*MARK);
2475                 }
2476                 else {
2477                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2478                     FREETMPS;
2479                     *MARK = sv_mortalcopy(sv);
2480                     SvREFCNT_dec_NN(sv);
2481                 }
2482             }
2483             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2484                      && !SvMAGICAL(TOPs)) {
2485                 *MARK = TOPs;
2486             }
2487             else
2488                 *MARK = sv_mortalcopy(TOPs);
2489         }
2490         else {
2491             MEXTEND(MARK, 0);
2492             *MARK = &PL_sv_undef;
2493         }
2494         SP = MARK;
2495     }
2496     else if (gimme == G_ARRAY) {
2497         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2498             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2499                  || SvMAGICAL(*MARK)) {
2500                 *MARK = sv_mortalcopy(*MARK);
2501                 TAINT_NOT;      /* Each item is independent */
2502             }
2503         }
2504     }
2505     PUTBACK;
2506
2507     LEAVE;
2508     cxstack_ix--;
2509     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2510     PL_curpm = newpm;   /* ... and pop $1 et al */
2511
2512     LEAVESUB(sv);
2513     return cx->blk_sub.retop;
2514 }
2515
2516 PP(pp_entersub)
2517 {
2518     dVAR; dSP; dPOPss;
2519     GV *gv;
2520     CV *cv;
2521     PERL_CONTEXT *cx;
2522     I32 gimme;
2523     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2524
2525     if (!sv)
2526         DIE(aTHX_ "Not a CODE reference");
2527     switch (SvTYPE(sv)) {
2528         /* This is overwhelming the most common case:  */
2529     case SVt_PVGV:
2530       we_have_a_glob:
2531         if (!(cv = GvCVu((const GV *)sv))) {
2532             HV *stash;
2533             cv = sv_2cv(sv, &stash, &gv, 0);
2534         }
2535         if (!cv) {
2536             ENTER;
2537             SAVETMPS;
2538             goto try_autoload;
2539         }
2540         break;
2541     case SVt_PVLV:
2542         if(isGV_with_GP(sv)) goto we_have_a_glob;
2543         /*FALLTHROUGH*/
2544     default:
2545         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2546             if (hasargs)
2547                 SP = PL_stack_base + POPMARK;
2548             else
2549                 (void)POPMARK;
2550             RETURN;
2551         }
2552         SvGETMAGIC(sv);
2553         if (SvROK(sv)) {
2554             if (SvAMAGIC(sv)) {
2555                 sv = amagic_deref_call(sv, to_cv_amg);
2556                 /* Don't SPAGAIN here.  */
2557             }
2558         }
2559         else {
2560             const char *sym;
2561             STRLEN len;
2562             if (!SvOK(sv))
2563                 DIE(aTHX_ PL_no_usym, "a subroutine");
2564             sym = SvPV_nomg_const(sv, len);
2565             if (PL_op->op_private & HINT_STRICT_REFS)
2566                 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2567             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2568             break;
2569         }
2570         cv = MUTABLE_CV(SvRV(sv));
2571         if (SvTYPE(cv) == SVt_PVCV)
2572             break;
2573         /* FALL THROUGH */
2574     case SVt_PVHV:
2575     case SVt_PVAV:
2576         DIE(aTHX_ "Not a CODE reference");
2577         /* This is the second most common case:  */
2578     case SVt_PVCV:
2579         cv = MUTABLE_CV(sv);
2580         break;
2581     }
2582
2583     ENTER;
2584
2585   retry:
2586     if (CvCLONE(cv) && ! CvCLONED(cv))
2587         DIE(aTHX_ "Closure prototype called");
2588     if (!CvROOT(cv) && !CvXSUB(cv)) {
2589         GV* autogv;
2590         SV* sub_name;
2591
2592         /* anonymous or undef'd function leaves us no recourse */
2593         if (CvANON(cv) || !(gv = CvGV(cv))) {
2594             if (CvNAMED(cv))
2595                 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2596                            HEKfARG(CvNAME_HEK(cv)));
2597             DIE(aTHX_ "Undefined subroutine called");
2598         }
2599
2600         /* autoloaded stub? */
2601         if (cv != GvCV(gv)) {
2602             cv = GvCV(gv);
2603         }
2604         /* should call AUTOLOAD now? */
2605         else {
2606 try_autoload:
2607             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2608                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2609             {
2610                 cv = GvCV(autogv);
2611             }
2612             else {
2613                sorry:
2614                 sub_name = sv_newmortal();
2615                 gv_efullname3(sub_name, gv, NULL);
2616                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2617             }
2618         }
2619         if (!cv)
2620             goto sorry;
2621         goto retry;
2622     }
2623
2624     gimme = GIMME_V;
2625     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2626          Perl_get_db_sub(aTHX_ &sv, cv);
2627          if (CvISXSUB(cv))
2628              PL_curcopdb = PL_curcop;
2629          if (CvLVALUE(cv)) {
2630              /* check for lsub that handles lvalue subroutines */
2631              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2632              /* if lsub not found then fall back to DB::sub */
2633              if (!cv) cv = GvCV(PL_DBsub);
2634          } else {
2635              cv = GvCV(PL_DBsub);
2636          }
2637
2638         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2639             DIE(aTHX_ "No DB::sub routine defined");
2640     }
2641
2642     if (!(CvISXSUB(cv))) {
2643         /* This path taken at least 75% of the time   */
2644         dMARK;
2645         I32 items = SP - MARK;
2646         PADLIST * const padlist = CvPADLIST(cv);
2647         PUSHBLOCK(cx, CXt_SUB, MARK);
2648         PUSHSUB(cx);
2649         cx->blk_sub.retop = PL_op->op_next;
2650         CvDEPTH(cv)++;
2651         if (CvDEPTH(cv) >= 2) {
2652             PERL_STACK_OVERFLOW_CHECK();
2653             pad_push(padlist, CvDEPTH(cv));
2654         }
2655         SAVECOMPPAD();
2656         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2657         if (hasargs) {
2658             AV *const av = MUTABLE_AV(PAD_SVl(0));
2659             if (AvREAL(av)) {
2660                 /* @_ is normally not REAL--this should only ever
2661                  * happen when DB::sub() calls things that modify @_ */
2662                 av_clear(av);
2663                 AvREAL_off(av);
2664                 AvREIFY_on(av);
2665             }
2666             cx->blk_sub.savearray = GvAV(PL_defgv);
2667             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2668             CX_CURPAD_SAVE(cx->blk_sub);
2669             cx->blk_sub.argarray = av;
2670             ++MARK;
2671
2672             if (items - 1 > AvMAX(av)) {
2673                 SV **ary = AvALLOC(av);
2674                 AvMAX(av) = items - 1;
2675                 Renew(ary, items, SV*);
2676                 AvALLOC(av) = ary;
2677                 AvARRAY(av) = ary;
2678             }
2679
2680             Copy(MARK,AvARRAY(av),items,SV*);
2681             AvFILLp(av) = items - 1;
2682
2683             MARK = AvARRAY(av);
2684             while (items--) {
2685                 if (*MARK)
2686                 {
2687                     if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
2688                         *MARK = sv_mortalcopy(*MARK);
2689                     SvTEMP_off(*MARK);
2690                 }
2691                 MARK++;
2692             }
2693         }
2694         SAVETMPS;
2695         if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2696             !CvLVALUE(cv))
2697             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2698         /* warning must come *after* we fully set up the context
2699          * stuff so that __WARN__ handlers can safely dounwind()
2700          * if they want to
2701          */
2702         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2703             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2704             sub_crush_depth(cv);
2705         RETURNOP(CvSTART(cv));
2706     }
2707     else {
2708         I32 markix = TOPMARK;
2709
2710         SAVETMPS;
2711         PUTBACK;
2712
2713         if (((PL_op->op_private
2714                & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2715              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2716             !CvLVALUE(cv))
2717             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2718
2719         if (!hasargs) {
2720             /* Need to copy @_ to stack. Alternative may be to
2721              * switch stack to @_, and copy return values
2722              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2723             AV * const av = GvAV(PL_defgv);
2724             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2725
2726             if (items) {
2727                 /* Mark is at the end of the stack. */
2728                 EXTEND(SP, items);
2729                 Copy(AvARRAY(av), SP + 1, items, SV*);
2730                 SP += items;
2731                 PUTBACK ;
2732             }
2733         }
2734         else {
2735             SV **mark = PL_stack_base + markix;
2736             I32 items = SP - mark;
2737             while (items--) {
2738                 mark++;
2739                 if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark))
2740                     *mark = sv_mortalcopy(*mark);
2741             }
2742         }
2743         /* We assume first XSUB in &DB::sub is the called one. */
2744         if (PL_curcopdb) {
2745             SAVEVPTR(PL_curcop);
2746             PL_curcop = PL_curcopdb;
2747             PL_curcopdb = NULL;
2748         }
2749         /* Do we need to open block here? XXXX */
2750
2751         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2752         assert(CvXSUB(cv));
2753         CvXSUB(cv)(aTHX_ cv);
2754
2755         /* Enforce some sanity in scalar context. */
2756         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2757             if (markix > PL_stack_sp - PL_stack_base)
2758                 *(PL_stack_base + markix) = &PL_sv_undef;
2759             else
2760                 *(PL_stack_base + markix) = *PL_stack_sp;
2761             PL_stack_sp = PL_stack_base + markix;
2762         }
2763         LEAVE;
2764         return NORMAL;
2765     }
2766 }
2767
2768 void
2769 Perl_sub_crush_depth(pTHX_ CV *cv)
2770 {
2771     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2772
2773     if (CvANON(cv))
2774         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2775     else {
2776         HEK *const hek = CvNAME_HEK(cv);
2777         SV *tmpstr;
2778         if (hek) {
2779             tmpstr = sv_2mortal(newSVhek(hek));
2780         }
2781         else {
2782             tmpstr = sv_newmortal();
2783             gv_efullname3(tmpstr, CvGV(cv), NULL);
2784         }
2785         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2786                     SVfARG(tmpstr));
2787     }
2788 }
2789
2790 PP(pp_aelem)
2791 {
2792     dVAR; dSP;
2793     SV** svp;
2794     SV* const elemsv = POPs;
2795     IV elem = SvIV(elemsv);
2796     AV *const av = MUTABLE_AV(POPs);
2797     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2798     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2799     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2800     bool preeminent = TRUE;
2801     SV *sv;
2802
2803     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2804         Perl_warner(aTHX_ packWARN(WARN_MISC),
2805                     "Use of reference \"%"SVf"\" as array index",
2806                     SVfARG(elemsv));
2807     if (SvTYPE(av) != SVt_PVAV)
2808         RETPUSHUNDEF;
2809
2810     if (localizing) {
2811         MAGIC *mg;
2812         HV *stash;
2813
2814         /* If we can determine whether the element exist,
2815          * Try to preserve the existenceness of a tied array
2816          * element by using EXISTS and DELETE if possible.
2817          * Fallback to FETCH and STORE otherwise. */
2818         if (SvCANEXISTDELETE(av))
2819             preeminent = av_exists(av, elem);
2820     }
2821
2822     svp = av_fetch(av, elem, lval && !defer);
2823     if (lval) {
2824 #ifdef PERL_MALLOC_WRAP
2825          if (SvUOK(elemsv)) {
2826               const UV uv = SvUV(elemsv);
2827               elem = uv > IV_MAX ? IV_MAX : uv;
2828          }
2829          else if (SvNOK(elemsv))
2830               elem = (IV)SvNV(elemsv);
2831          if (elem > 0) {
2832               static const char oom_array_extend[] =
2833                 "Out of memory during array extend"; /* Duplicated in av.c */
2834               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2835          }
2836 #endif
2837         if (!svp || !*svp) {
2838             SV* lv;
2839             if (!defer)
2840                 DIE(aTHX_ PL_no_aelem, elem);
2841             lv = sv_newmortal();
2842             sv_upgrade(lv, SVt_PVLV);
2843             LvTYPE(lv) = 'y';
2844             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2845             LvTARG(lv) = SvREFCNT_inc_simple(av);
2846             LvTARGOFF(lv) = elem;
2847             LvTARGLEN(lv) = 1;
2848             PUSHs(lv);
2849             RETURN;
2850         }
2851         if (localizing) {
2852             if (preeminent)
2853                 save_aelem(av, elem, svp);
2854             else
2855                 SAVEADELETE(av, elem);
2856         }
2857         else if (PL_op->op_private & OPpDEREF) {
2858             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2859             RETURN;
2860         }
2861     }
2862     sv = (svp ? *svp : &PL_sv_undef);
2863     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2864         mg_get(sv);
2865     PUSHs(sv);
2866     RETURN;
2867 }
2868
2869 SV*
2870 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2871 {
2872     PERL_ARGS_ASSERT_VIVIFY_REF;
2873
2874     SvGETMAGIC(sv);
2875     if (!SvOK(sv)) {
2876         if (SvREADONLY(sv))
2877             Perl_croak_no_modify();
2878         prepare_SV_for_RV(sv);
2879         switch (to_what) {
2880         case OPpDEREF_SV:
2881             SvRV_set(sv, newSV(0));
2882             break;
2883         case OPpDEREF_AV:
2884             SvRV_set(sv, MUTABLE_SV(newAV()));
2885             break;
2886         case OPpDEREF_HV:
2887             SvRV_set(sv, MUTABLE_SV(newHV()));
2888             break;
2889         }
2890         SvROK_on(sv);
2891         SvSETMAGIC(sv);
2892         SvGETMAGIC(sv);
2893     }
2894     if (SvGMAGICAL(sv)) {
2895         /* copy the sv without magic to prevent magic from being
2896            executed twice */
2897         SV* msv = sv_newmortal();
2898         sv_setsv_nomg(msv, sv);
2899         return msv;
2900     }
2901     return sv;
2902 }
2903
2904 PP(pp_method)
2905 {
2906     dVAR; dSP;
2907     SV* const sv = TOPs;
2908
2909     if (SvROK(sv)) {
2910         SV* const rsv = SvRV(sv);
2911         if (SvTYPE(rsv) == SVt_PVCV) {
2912             SETs(rsv);
2913             RETURN;
2914         }
2915     }
2916
2917     SETs(method_common(sv, NULL));
2918     RETURN;
2919 }
2920
2921 PP(pp_method_named)
2922 {
2923     dVAR; dSP;
2924     SV* const sv = cSVOP_sv;
2925     U32 hash = SvSHARED_HASH(sv);
2926
2927     XPUSHs(method_common(sv, &hash));
2928     RETURN;
2929 }
2930
2931 STATIC SV *
2932 S_method_common(pTHX_ SV* meth, U32* hashp)
2933 {
2934     dVAR;
2935     SV* ob;
2936     GV* gv;
2937     HV* stash;
2938     SV *packsv = NULL;
2939     SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2940         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2941                             "package or object reference", SVfARG(meth)),
2942            (SV *)NULL)
2943         : *(PL_stack_base + TOPMARK + 1);
2944
2945     PERL_ARGS_ASSERT_METHOD_COMMON;
2946
2947     if (!sv)
2948        undefined:
2949         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2950                    SVfARG(meth));
2951
2952     SvGETMAGIC(sv);
2953     if (SvROK(sv))
2954         ob = MUTABLE_SV(SvRV(sv));
2955     else if (!SvOK(sv)) goto undefined;
2956     else if (isGV_with_GP(sv)) {
2957         if (!GvIO(sv))
2958             Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2959                              "without a package or object reference",
2960                               SVfARG(meth));
2961         ob = sv;
2962         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
2963             assert(!LvTARGLEN(ob));
2964             ob = LvTARG(ob);
2965             assert(ob);
2966         }
2967         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
2968     }
2969     else {
2970         /* this isn't a reference */
2971         GV* iogv;
2972         STRLEN packlen;
2973         const char * const packname = SvPV_nomg_const(sv, packlen);
2974         const bool packname_is_utf8 = !!SvUTF8(sv);
2975         const HE* const he =
2976             (const HE *)hv_common(
2977                 PL_stashcache, NULL, packname, packlen,
2978                 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
2979             );
2980
2981         if (he) {
2982             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2983             DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
2984                              stash, sv));
2985             goto fetch;
2986         }
2987
2988         if (!(iogv = gv_fetchpvn_flags(
2989                 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2990              )) ||
2991             !(ob=MUTABLE_SV(GvIO(iogv))))
2992         {
2993             /* this isn't the name of a filehandle either */
2994             if (!packlen)
2995             {
2996                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2997                                  "without a package or object reference",
2998                                   SVfARG(meth));
2999             }
3000             /* assume it's a package name */
3001             stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3002             if (!stash)
3003                 packsv = sv;
3004             else {
3005                 SV* const ref = newSViv(PTR2IV(stash));
3006                 (void)hv_store(PL_stashcache, packname,
3007                                 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3008                 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3009                                  stash, sv));
3010             }
3011             goto fetch;
3012         }
3013         /* it _is_ a filehandle name -- replace with a reference */
3014         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3015     }
3016
3017     /* if we got here, ob should be an object or a glob */
3018     if (!ob || !(SvOBJECT(ob)
3019                  || (isGV_with_GP(ob)
3020                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3021                      && SvOBJECT(ob))))
3022     {
3023         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3024                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3025                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3026                                         : meth));
3027     }
3028
3029     stash = SvSTASH(ob);
3030
3031   fetch:
3032     /* NOTE: stash may be null, hope hv_fetch_ent and
3033        gv_fetchmethod can cope (it seems they can) */
3034
3035     /* shortcut for simple names */
3036     if (hashp) {
3037         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3038         if (he) {
3039             gv = MUTABLE_GV(HeVAL(he));
3040             if (isGV(gv) && GvCV(gv) &&
3041                 (!GvCVGEN(gv) || GvCVGEN(gv)
3042                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3043                 return MUTABLE_SV(GvCV(gv));
3044         }
3045     }
3046
3047     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3048                                      meth, GV_AUTOLOAD | GV_CROAK);
3049
3050     assert(gv);
3051
3052     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3053 }
3054
3055 /*
3056  * Local variables:
3057  * c-indentation-style: bsd
3058  * c-basic-offset: 4
3059  * indent-tabs-mode: nil
3060  * End:
3061  *
3062  * ex: set ts=8 sts=4 sw=4 et:
3063  */