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 SSize_t maxarg = AvFILL(av) + 1;
 330     EXTEND(SP, maxarg);
 331     if (SvRMAGICAL(av)) {
 332         PADOFFSET i;
 333         for (i=0; i < (PADOFFSET)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         PADOFFSET i;
 343         for (i=0; i < (PADOFFSET)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 SSize_t 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             dTARG;
 943             TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
 944             SETTARG;
 945         }
 946     }
 947     RETURN;
 948
 949  croak_cant_return:
 950     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
 951                is_pp_rv2av ? "array" : "hash");
 952     RETURN;
 953 }
 954
 955 STATIC void
 956 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
 957 {
 958     dVAR;
 959
 960     PERL_ARGS_ASSERT_DO_ODDBALL;
 961
 962     if (*oddkey) {
 963         if (ckWARN(WARN_MISC)) {
 964             const char *err;
 965             if (oddkey == firstkey &&
 966                 SvROK(*oddkey) &&
 967                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
 968                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
 969             {
 970                 err = "Reference found where even-sized list expected";
 971             }
 972             else
 973                 err = "Odd number of elements in hash assignment";
 974             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
 975         }
 976
 977     }
 978 }
 979
 980 PP(pp_aassign)
 981 {
 982     dVAR; dSP;
 983     SV **lastlelem = PL_stack_sp;
 984     SV **lastrelem = PL_stack_base + POPMARK;
 985     SV **firstrelem = PL_stack_base + POPMARK + 1;
 986     SV **firstlelem = lastrelem + 1;
 987
 988     SV **relem;
 989     SV **lelem;
 990
 991     SV *sv;
 992     AV *ary;
 993
 994     I32 gimme;
 995     HV *hash;
 996     SSize_t i;
 997     int magic;
 998     U32 lval = 0;
 999
1000     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1001     gimme = GIMME_V;
1002     if (gimme == G_ARRAY)
1003         lval = PL_op->op_flags & OPf_MOD || LVRET;
1004
1005     /* If there's a common identifier on both sides we have to take
1006      * special care that assigning the identifier on the left doesn't
1007      * clobber a value on the right that's used later in the list.
1008      * Don't bother if LHS is just an empty hash or array.
1009      */
1010
1011     if (    (PL_op->op_private & OPpASSIGN_COMMON)
1012         &&  (
1013                firstlelem != lastlelem
1014             || ! ((sv = *firstlelem))
1015             || SvMAGICAL(sv)
1016             || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1017             || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1018             || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1019             )
1020     ) {
1021         EXTEND_MORTAL(lastrelem - firstrelem + 1);
1022         for (relem = firstrelem; relem <= lastrelem; relem++) {
1023             if ((sv = *relem)) {
1024                 TAINT_NOT;      /* Each item is independent */
1025
1026                 /* Dear TODO test in t/op/sort.t, I love you.
1027                    (It's relying on a panic, not a "semi-panic" from newSVsv()
1028                    and then an assertion failure below.)  */
1029                 if (SvIS_FREED(sv)) {
1030                     Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1031                                (void*)sv);
1032                 }
1033                 /* Not newSVsv(), as it does not allow copy-on-write,
1034                    resulting in wasteful copies.  We need a second copy of
1035                    a temp here, hence the SV_NOSTEAL.  */
1036                 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1037                                                |SV_NOSTEAL);
1038             }
1039         }
1040     }
1041
1042     relem = firstrelem;
1043     lelem = firstlelem;
1044     ary = NULL;
1045     hash = NULL;
1046
1047     while (lelem <= lastlelem) {
1048         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1049         sv = *lelem++;
1050         switch (SvTYPE(sv)) {
1051         case SVt_PVAV:
1052             ary = MUTABLE_AV(sv);
1053             magic = SvMAGICAL(ary) != 0;
1054             ENTER;
1055             SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1056             av_clear(ary);
1057             av_extend(ary, lastrelem - relem);
1058             i = 0;
1059             while (relem <= lastrelem) {        /* gobble up all the rest */
1060                 SV **didstore;
1061                 if (*relem)
1062                     SvGETMAGIC(*relem); /* before newSV, in case it dies */
1063                 sv = newSV(0);
1064                 sv_setsv_nomg(sv, *relem);
1065                 *(relem++) = sv;
1066                 didstore = av_store(ary,i++,sv);
1067                 if (magic) {
1068                     if (!didstore)
1069                         sv_2mortal(sv);
1070                     if (SvSMAGICAL(sv))
1071                         mg_set(sv);
1072                 }
1073                 TAINT_NOT;
1074             }
1075             if (PL_delaymagic & DM_ARRAY_ISA)
1076                 SvSETMAGIC(MUTABLE_SV(ary));
1077             LEAVE;
1078             break;
1079         case SVt_PVHV: {                                /* normal hash */
1080                 SV *tmpstr;
1081                 int odd;
1082                 int duplicates = 0;
1083                 SV** topelem = relem;
1084                 SV **firsthashrelem = relem;
1085
1086                 hash = MUTABLE_HV(sv);
1087                 magic = SvMAGICAL(hash) != 0;
1088
1089                 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1090                 if ( odd ) {
1091                     do_oddball(lastrelem, firsthashrelem);
1092                     /* we have firstlelem to reuse, it's not needed anymore
1093                      */
1094                     *(lastrelem+1) = &PL_sv_undef;
1095                 }
1096
1097                 ENTER;
1098                 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1099                 hv_clear(hash);
1100                 while (relem < lastrelem+odd) { /* gobble up all the rest */
1101                     HE *didstore;
1102                     assert(*relem);
1103                     /* Copy the key if aassign is called in lvalue context,
1104                        to avoid having the next op modify our rhs.  Copy
1105                        it also if it is gmagical, lest it make the
1106                        hv_store_ent call below croak, leaking the value. */
1107                     sv = lval || SvGMAGICAL(*relem)
1108                          ? sv_mortalcopy(*relem)
1109                          : *relem;
1110                     relem++;
1111                     assert(*relem);
1112                     SvGETMAGIC(*relem);
1113                     tmpstr = newSV(0);
1114                     sv_setsv_nomg(tmpstr,*relem++);     /* value */
1115                     if (gimme == G_ARRAY) {
1116                         if (hv_exists_ent(hash, sv, 0))
1117                             /* key overwrites an existing entry */
1118                             duplicates += 2;
1119                         else {
1120                             /* copy element back: possibly to an earlier
1121                              * stack location if we encountered dups earlier,
1122                              * possibly to a later stack location if odd */
1123                             *topelem++ = sv;
1124                             *topelem++ = tmpstr;
1125                         }
1126                     }
1127                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1128                     if (magic) {
1129                         if (!didstore) sv_2mortal(tmpstr);
1130                         SvSETMAGIC(tmpstr);
1131                     }
1132                     TAINT_NOT;
1133                 }
1134                 LEAVE;
1135                 if (duplicates && gimme == G_ARRAY) {
1136                     /* at this point we have removed the duplicate key/value
1137                      * pairs from the stack, but the remaining values may be
1138                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1139                      * the (a 2), but the stack now probably contains
1140                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1141                      * obliterates the earlier key. So refresh all values. */
1142                     lastrelem -= duplicates;
1143                     relem = firsthashrelem;
1144                     while (relem < lastrelem+odd) {
1145                         HE *he;
1146                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1147                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1148                     }
1149                 }
1150                 if (odd && gimme == G_ARRAY) lastrelem++;
1151             }
1152             break;
1153         default:
1154             if (SvIMMORTAL(sv)) {
1155                 if (relem <= lastrelem)
1156                     relem++;
1157                 break;
1158             }
1159             if (relem <= lastrelem) {
1160                 if (
1161                   SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1162                   (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1163                 )
1164                     Perl_warner(aTHX_
1165                        packWARN(WARN_MISC),
1166                       "Useless assignment to a temporary"
1167                     );
1168                 sv_setsv(sv, *relem);
1169                 *(relem++) = sv;
1170             }
1171             else
1172                 sv_setsv(sv, &PL_sv_undef);
1173             SvSETMAGIC(sv);
1174             break;
1175         }
1176     }
1177     if (PL_delaymagic & ~DM_DELAY) {
1178         /* Will be used to set PL_tainting below */
1179         Uid_t tmp_uid  = PerlProc_getuid();
1180         Uid_t tmp_euid = PerlProc_geteuid();
1181         Gid_t tmp_gid  = PerlProc_getgid();
1182         Gid_t tmp_egid = PerlProc_getegid();
1183
1184         if (PL_delaymagic & DM_UID) {
1185 #ifdef HAS_SETRESUID
1186             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1187                             (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1188                             (Uid_t)-1);
1189 #else
1190 #  ifdef HAS_SETREUID
1191             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1192                            (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1193 #  else
1194 #    ifdef HAS_SETRUID
1195             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1196                 (void)setruid(PL_delaymagic_uid);
1197                 PL_delaymagic &= ~DM_RUID;
1198             }
1199 #    endif /* HAS_SETRUID */
1200 #    ifdef HAS_SETEUID
1201             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1202                 (void)seteuid(PL_delaymagic_euid);
1203                 PL_delaymagic &= ~DM_EUID;
1204             }
1205 #    endif /* HAS_SETEUID */
1206             if (PL_delaymagic & DM_UID) {
1207                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1208                     DIE(aTHX_ "No setreuid available");
1209                 (void)PerlProc_setuid(PL_delaymagic_uid);
1210             }
1211 #  endif /* HAS_SETREUID */
1212 #endif /* HAS_SETRESUID */
1213             tmp_uid  = PerlProc_getuid();
1214             tmp_euid = PerlProc_geteuid();
1215         }
1216         if (PL_delaymagic & DM_GID) {
1217 #ifdef HAS_SETRESGID
1218             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1219                             (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1220                             (Gid_t)-1);
1221 #else
1222 #  ifdef HAS_SETREGID
1223             (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1224                            (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1225 #  else
1226 #    ifdef HAS_SETRGID
1227             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1228                 (void)setrgid(PL_delaymagic_gid);
1229                 PL_delaymagic &= ~DM_RGID;
1230             }
1231 #    endif /* HAS_SETRGID */
1232 #    ifdef HAS_SETEGID
1233             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1234                 (void)setegid(PL_delaymagic_egid);
1235                 PL_delaymagic &= ~DM_EGID;
1236             }
1237 #    endif /* HAS_SETEGID */
1238             if (PL_delaymagic & DM_GID) {
1239                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1240                     DIE(aTHX_ "No setregid available");
1241                 (void)PerlProc_setgid(PL_delaymagic_gid);
1242             }
1243 #  endif /* HAS_SETREGID */
1244 #endif /* HAS_SETRESGID */
1245             tmp_gid  = PerlProc_getgid();
1246             tmp_egid = PerlProc_getegid();
1247         }
1248         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1249 #ifdef NO_TAINT_SUPPORT
1250         PERL_UNUSED_VAR(tmp_uid);
1251         PERL_UNUSED_VAR(tmp_euid);
1252         PERL_UNUSED_VAR(tmp_gid);
1253         PERL_UNUSED_VAR(tmp_egid);
1254 #endif
1255     }
1256     PL_delaymagic = 0;
1257
1258     if (gimme == G_VOID)
1259         SP = firstrelem - 1;
1260     else if (gimme == G_SCALAR) {
1261         dTARGET;
1262         SP = firstrelem;
1263         SETi(lastrelem - firstrelem + 1);
1264     }
1265     else {
1266         if (ary || hash)
1267             /* note that in this case *firstlelem may have been overwritten
1268                by sv_undef in the odd hash case */
1269             SP = lastrelem;
1270         else {
1271             SP = firstrelem + (lastlelem - firstlelem);
1272             lelem = firstlelem + (relem - firstrelem);
1273             while (relem <= SP)
1274                 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1275         }
1276     }
1277
1278     RETURN;
1279 }
1280
1281 PP(pp_qr)
1282 {
1283     dVAR; dSP;
1284     PMOP * const pm = cPMOP;
1285     REGEXP * rx = PM_GETRE(pm);
1286     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1287     SV * const rv = sv_newmortal();
1288     CV **cvp;
1289     CV *cv;
1290
1291     SvUPGRADE(rv, SVt_IV);
1292     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1293        loathe to use it here, but it seems to be the right fix. Or close.
1294        The key part appears to be that it's essential for pp_qr to return a new
1295        object (SV), which implies that there needs to be an effective way to
1296        generate a new SV from the existing SV that is pre-compiled in the
1297        optree.  */
1298     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1299     SvROK_on(rv);
1300
1301     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1302     if ((cv = *cvp) && CvCLONE(*cvp)) {
1303         *cvp = cv_clone(cv);
1304         SvREFCNT_dec_NN(cv);
1305     }
1306
1307     if (pkg) {
1308         HV *const stash = gv_stashsv(pkg, GV_ADD);
1309         SvREFCNT_dec_NN(pkg);
1310         (void)sv_bless(rv, stash);
1311     }
1312
1313     if (RX_ISTAINTED(rx)) {
1314         SvTAINTED_on(rv);
1315         SvTAINTED_on(SvRV(rv));
1316     }
1317     XPUSHs(rv);
1318     RETURN;
1319 }
1320
1321 PP(pp_match)
1322 {
1323     dVAR; dSP; dTARG;
1324     PMOP *pm = cPMOP;
1325     PMOP *dynpm = pm;
1326     const char *s;
1327     const char *strend;
1328     SSize_t curpos = 0; /* initial pos() or current $+[0] */
1329     I32 global;
1330     U8 r_flags = 0;
1331     const char *truebase;                       /* Start of string  */
1332     REGEXP *rx = PM_GETRE(pm);
1333     bool rxtainted;
1334     const I32 gimme = GIMME;
1335     STRLEN len;
1336     const I32 oldsave = PL_savestack_ix;
1337     I32 had_zerolen = 0;
1338     MAGIC *mg = NULL;
1339
1340     if (PL_op->op_flags & OPf_STACKED)
1341         TARG = POPs;
1342     else if (PL_op->op_private & OPpTARGET_MY)
1343         GETTARGET;
1344     else {
1345         TARG = DEFSV;
1346         EXTEND(SP,1);
1347     }
1348
1349     PUTBACK;                            /* EVAL blocks need stack_sp. */
1350     /* Skip get-magic if this is a qr// clone, because regcomp has
1351        already done it. */
1352     truebase = ReANY(rx)->mother_re
1353          ? SvPV_nomg_const(TARG, len)
1354          : SvPV_const(TARG, len);
1355     if (!truebase)
1356         DIE(aTHX_ "panic: pp_match");
1357     strend = truebase + len;
1358     rxtainted = (RX_ISTAINTED(rx) ||
1359                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1360     TAINT_NOT;
1361
1362     /* We need to know this in case we fail out early - pos() must be reset */
1363     global = dynpm->op_pmflags & PMf_GLOBAL;
1364
1365     /* PMdf_USED is set after a ?? matches once */
1366     if (
1367 #ifdef USE_ITHREADS
1368         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1369 #else
1370         pm->op_pmflags & PMf_USED
1371 #endif
1372     ) {
1373         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1374         goto nope;
1375     }
1376
1377     /* empty pattern special-cased to use last successful pattern if
1378        possible, except for qr// */
1379     if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1380      && PL_curpm) {
1381         pm = PL_curpm;
1382         rx = PM_GETRE(pm);
1383     }
1384
1385     if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1386         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1387                                               UVuf" < %"IVdf")\n",
1388                                               (UV)len, (IV)RX_MINLEN(rx)));
1389         goto nope;
1390     }
1391
1392     /* get pos() if //g */
1393     if (global) {
1394         mg = mg_find_mglob(TARG);
1395         if (mg && mg->mg_len >= 0) {
1396             curpos = MgBYTEPOS(mg, TARG, truebase, len);
1397             /* last time pos() was set, it was zero-length match */
1398             if (mg->mg_flags & MGf_MINMATCH)
1399                 had_zerolen = 1;
1400         }
1401     }
1402
1403 #ifdef PERL_SAWAMPERSAND
1404     if (       RX_NPARENS(rx)
1405             || PL_sawampersand
1406             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1407             || (dynpm->op_pmflags & PMf_KEEPCOPY)
1408     )
1409 #endif
1410     {
1411         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1412         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1413          * only on the first iteration. Therefore we need to copy $' as well
1414          * as $&, to make the rest of the string available for captures in
1415          * subsequent iterations */
1416         if (! (global && gimme == G_ARRAY))
1417             r_flags |= REXEC_COPY_SKIP_POST;
1418     };
1419 #ifdef PERL_SAWAMPERSAND
1420     if (dynpm->op_pmflags & PMf_KEEPCOPY)
1421         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1422         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1423 #endif
1424
1425     s = truebase;
1426
1427   play_it_again:
1428     if (global)
1429         s = truebase + curpos;
1430
1431     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1432                      had_zerolen, TARG, NULL, r_flags))
1433         goto nope;
1434
1435     PL_curpm = pm;
1436     if (dynpm->op_pmflags & PMf_ONCE)
1437 #ifdef USE_ITHREADS
1438         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1439 #else
1440         dynpm->op_pmflags |= PMf_USED;
1441 #endif
1442
1443     if (rxtainted)
1444         RX_MATCH_TAINTED_on(rx);
1445     TAINT_IF(RX_MATCH_TAINTED(rx));
1446
1447     /* update pos */
1448
1449     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1450         if (!mg)
1451             mg = sv_magicext_mglob(TARG);
1452         MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1453         if (RX_ZERO_LEN(rx))
1454             mg->mg_flags |= MGf_MINMATCH;
1455         else
1456             mg->mg_flags &= ~MGf_MINMATCH;
1457     }
1458
1459     if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1460         LEAVE_SCOPE(oldsave);
1461         RETPUSHYES;
1462     }
1463
1464     /* push captures on stack */
1465
1466     {
1467         const I32 nparens = RX_NPARENS(rx);
1468         I32 i = (global && !nparens) ? 1 : 0;
1469
1470         SPAGAIN;                        /* EVAL blocks could move the stack. */
1471         EXTEND(SP, nparens + i);
1472         EXTEND_MORTAL(nparens + i);
1473         for (i = !i; i <= nparens; i++) {
1474             PUSHs(sv_newmortal());
1475             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1476                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1477                 const char * const s = RX_OFFS(rx)[i].start + truebase;
1478                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1479                     len < 0 || len > strend - s)
1480                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1481                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1482                         (long) i, (long) RX_OFFS(rx)[i].start,
1483                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1484                 sv_setpvn(*SP, s, len);
1485                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1486                     SvUTF8_on(*SP);
1487             }
1488         }
1489         if (global) {
1490             curpos = (UV)RX_OFFS(rx)[0].end;
1491             had_zerolen = RX_ZERO_LEN(rx);
1492             PUTBACK;                    /* EVAL blocks may use stack */
1493             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1494             goto play_it_again;
1495         }
1496         LEAVE_SCOPE(oldsave);
1497         RETURN;
1498     }
1499     /* NOTREACHED */
1500
1501 nope:
1502     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1503         if (!mg)
1504             mg = mg_find_mglob(TARG);
1505         if (mg)
1506             mg->mg_len = -1;
1507     }
1508     LEAVE_SCOPE(oldsave);
1509     if (gimme == G_ARRAY)
1510         RETURN;
1511     RETPUSHNO;
1512 }
1513
1514 OP *
1515 Perl_do_readline(pTHX)
1516 {
1517     dVAR; dSP; dTARGETSTACKED;
1518     SV *sv;
1519     STRLEN tmplen = 0;
1520     STRLEN offset;
1521     PerlIO *fp;
1522     IO * const io = GvIO(PL_last_in_gv);
1523     const I32 type = PL_op->op_type;
1524     const I32 gimme = GIMME_V;
1525
1526     if (io) {
1527         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1528         if (mg) {
1529             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1530             if (gimme == G_SCALAR) {
1531                 SPAGAIN;
1532                 SvSetSV_nosteal(TARG, TOPs);
1533                 SETTARG;
1534             }
1535             return NORMAL;
1536         }
1537     }
1538     fp = NULL;
1539     if (io) {
1540         fp = IoIFP(io);
1541         if (!fp) {
1542             if (IoFLAGS(io) & IOf_ARGV) {
1543                 if (IoFLAGS(io) & IOf_START) {
1544                     IoLINES(io) = 0;
1545                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1546                         IoFLAGS(io) &= ~IOf_START;
1547                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1548                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1549                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1550                         SvSETMAGIC(GvSV(PL_last_in_gv));
1551                         fp = IoIFP(io);
1552                         goto have_fp;
1553                     }
1554                 }
1555                 fp = nextargv(PL_last_in_gv);
1556                 if (!fp) { /* Note: fp != IoIFP(io) */
1557                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1558                 }
1559             }
1560             else if (type == OP_GLOB)
1561                 fp = Perl_start_glob(aTHX_ POPs, io);
1562         }
1563         else if (type == OP_GLOB)
1564             SP--;
1565         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1566             report_wrongway_fh(PL_last_in_gv, '>');
1567         }
1568     }
1569     if (!fp) {
1570         if ((!io || !(IoFLAGS(io) & IOf_START))
1571             && ckWARN(WARN_CLOSED)
1572             && type != OP_GLOB)
1573         {
1574             report_evil_fh(PL_last_in_gv);
1575         }
1576         if (gimme == G_SCALAR) {
1577             /* undef TARG, and push that undefined value */
1578             if (type != OP_RCATLINE) {
1579                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1580                 SvOK_off(TARG);
1581             }
1582             PUSHTARG;
1583         }
1584         RETURN;
1585     }
1586   have_fp:
1587     if (gimme == G_SCALAR) {
1588         sv = TARG;
1589         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1590             mg_get(sv);
1591         if (SvROK(sv)) {
1592             if (type == OP_RCATLINE)
1593                 SvPV_force_nomg_nolen(sv);
1594             else
1595                 sv_unref(sv);
1596         }
1597         else if (isGV_with_GP(sv)) {
1598             SvPV_force_nomg_nolen(sv);
1599         }
1600         SvUPGRADE(sv, SVt_PV);
1601         tmplen = SvLEN(sv);     /* remember if already alloced */
1602         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1603             /* try short-buffering it. Please update t/op/readline.t
1604              * if you change the growth length.
1605              */
1606             Sv_Grow(sv, 80);
1607         }
1608         offset = 0;
1609         if (type == OP_RCATLINE && SvOK(sv)) {
1610             if (!SvPOK(sv)) {
1611                 SvPV_force_nomg_nolen(sv);
1612             }
1613             offset = SvCUR(sv);
1614         }
1615     }
1616     else {
1617         sv = sv_2mortal(newSV(80));
1618         offset = 0;
1619     }
1620
1621     /* This should not be marked tainted if the fp is marked clean */
1622 #define MAYBE_TAINT_LINE(io, sv) \
1623     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1624         TAINT;                          \
1625         SvTAINTED_on(sv);               \
1626     }
1627
1628 /* delay EOF state for a snarfed empty file */
1629 #define SNARF_EOF(gimme,rs,io,sv) \
1630     (gimme != G_SCALAR || SvCUR(sv)                                     \
1631      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1632
1633     for (;;) {
1634         PUTBACK;
1635         if (!sv_gets(sv, fp, offset)
1636             && (type == OP_GLOB
1637                 || SNARF_EOF(gimme, PL_rs, io, sv)
1638                 || PerlIO_error(fp)))
1639         {
1640             PerlIO_clearerr(fp);
1641             if (IoFLAGS(io) & IOf_ARGV) {
1642                 fp = nextargv(PL_last_in_gv);
1643                 if (fp)
1644                     continue;
1645                 (void)do_close(PL_last_in_gv, FALSE);
1646             }
1647             else if (type == OP_GLOB) {
1648                 if (!do_close(PL_last_in_gv, FALSE)) {
1649                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1650                                    "glob failed (child exited with status %d%s)",
1651                                    (int)(STATUS_CURRENT >> 8),
1652                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1653                 }
1654             }
1655             if (gimme == G_SCALAR) {
1656                 if (type != OP_RCATLINE) {
1657                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1658                     SvOK_off(TARG);
1659                 }
1660                 SPAGAIN;
1661                 PUSHTARG;
1662             }
1663             MAYBE_TAINT_LINE(io, sv);
1664             RETURN;
1665         }
1666         MAYBE_TAINT_LINE(io, sv);
1667         IoLINES(io)++;
1668         IoFLAGS(io) |= IOf_NOLINE;
1669         SvSETMAGIC(sv);
1670         SPAGAIN;
1671         XPUSHs(sv);
1672         if (type == OP_GLOB) {
1673             const char *t1;
1674
1675             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1676                 char * const tmps = SvEND(sv) - 1;
1677                 if (*tmps == *SvPVX_const(PL_rs)) {
1678                     *tmps = '\0';
1679                     SvCUR_set(sv, SvCUR(sv) - 1);
1680                 }
1681             }
1682             for (t1 = SvPVX_const(sv); *t1; t1++)
1683                 if (!isALPHANUMERIC(*t1) &&
1684                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1685                         break;
1686             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1687                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1688                 continue;
1689             }
1690         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1691              if (ckWARN(WARN_UTF8)) {
1692                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1693                 const STRLEN len = SvCUR(sv) - offset;
1694                 const U8 *f;
1695
1696                 if (!is_utf8_string_loc(s, len, &f))
1697                     /* Emulate :encoding(utf8) warning in the same case. */
1698                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1699                                 "utf8 \"\\x%02X\" does not map to Unicode",
1700                                 f < (U8*)SvEND(sv) ? *f : 0);
1701              }
1702         }
1703         if (gimme == G_ARRAY) {
1704             if (SvLEN(sv) - SvCUR(sv) > 20) {
1705                 SvPV_shrink_to_cur(sv);
1706             }
1707             sv = sv_2mortal(newSV(80));
1708             continue;
1709         }
1710         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1711             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1712             const STRLEN new_len
1713                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1714             SvPV_renew(sv, new_len);
1715         }
1716         RETURN;
1717     }
1718 }
1719
1720 PP(pp_helem)
1721 {
1722     dVAR; dSP;
1723     HE* he;
1724     SV **svp;
1725     SV * const keysv = POPs;
1726     HV * const hv = MUTABLE_HV(POPs);
1727     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1728     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1729     SV *sv;
1730     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1731     bool preeminent = TRUE;
1732
1733     if (SvTYPE(hv) != SVt_PVHV)
1734         RETPUSHUNDEF;
1735
1736     if (localizing) {
1737         MAGIC *mg;
1738         HV *stash;
1739
1740         /* If we can determine whether the element exist,
1741          * Try to preserve the existenceness of a tied hash
1742          * element by using EXISTS and DELETE if possible.
1743          * Fallback to FETCH and STORE otherwise. */
1744         if (SvCANEXISTDELETE(hv))
1745             preeminent = hv_exists_ent(hv, keysv, 0);
1746     }
1747
1748     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1749     svp = he ? &HeVAL(he) : NULL;
1750     if (lval) {
1751         if (!svp || !*svp || *svp == &PL_sv_undef) {
1752             SV* lv;
1753             SV* key2;
1754             if (!defer) {
1755                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1756             }
1757             lv = sv_newmortal();
1758             sv_upgrade(lv, SVt_PVLV);
1759             LvTYPE(lv) = 'y';
1760             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1761             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
1762             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1763             LvTARGLEN(lv) = 1;
1764             PUSHs(lv);
1765             RETURN;
1766         }
1767         if (localizing) {
1768             if (HvNAME_get(hv) && isGV(*svp))
1769                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1770             else if (preeminent)
1771                 save_helem_flags(hv, keysv, svp,
1772                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1773             else
1774                 SAVEHDELETE(hv, keysv);
1775         }
1776         else if (PL_op->op_private & OPpDEREF) {
1777             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1778             RETURN;
1779         }
1780     }
1781     sv = (svp && *svp ? *svp : &PL_sv_undef);
1782     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1783      * was to make C<local $tied{foo} = $tied{foo}> possible.
1784      * However, it seems no longer to be needed for that purpose, and
1785      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1786      * would loop endlessly since the pos magic is getting set on the
1787      * mortal copy and lost. However, the copy has the effect of
1788      * triggering the get magic, and losing it altogether made things like
1789      * c<$tied{foo};> in void context no longer do get magic, which some
1790      * code relied on. Also, delayed triggering of magic on @+ and friends
1791      * meant the original regex may be out of scope by now. So as a
1792      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1793      * being called too many times). */
1794     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1795         mg_get(sv);
1796     PUSHs(sv);
1797     RETURN;
1798 }
1799
1800 PP(pp_iter)
1801 {
1802     dVAR; dSP;
1803     PERL_CONTEXT *cx;
1804     SV *oldsv;
1805     SV **itersvp;
1806
1807     EXTEND(SP, 1);
1808     cx = &cxstack[cxstack_ix];
1809     itersvp = CxITERVAR(cx);
1810
1811     switch (CxTYPE(cx)) {
1812
1813     case CXt_LOOP_LAZYSV: /* string increment */
1814     {
1815         SV* cur = cx->blk_loop.state_u.lazysv.cur;
1816         SV *end = cx->blk_loop.state_u.lazysv.end;
1817         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1818            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1819         STRLEN maxlen = 0;
1820         const char *max = SvPV_const(end, maxlen);
1821         if (SvNIOK(cur) || SvCUR(cur) > maxlen)
1822             RETPUSHNO;
1823
1824         oldsv = *itersvp;
1825         if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1826             /* safe to reuse old SV */
1827             sv_setsv(oldsv, cur);
1828         }
1829         else
1830         {
1831             /* we need a fresh SV every time so that loop body sees a
1832              * completely new SV for closures/references to work as
1833              * they used to */
1834             *itersvp = newSVsv(cur);
1835             SvREFCNT_dec_NN(oldsv);
1836         }
1837         if (strEQ(SvPVX_const(cur), max))
1838             sv_setiv(cur, 0); /* terminate next time */
1839         else
1840             sv_inc(cur);
1841         break;
1842     }
1843
1844     case CXt_LOOP_LAZYIV: /* integer increment */
1845     {
1846         IV cur = cx->blk_loop.state_u.lazyiv.cur;
1847         if (cur > cx->blk_loop.state_u.lazyiv.end)
1848             RETPUSHNO;
1849
1850         oldsv = *itersvp;
1851         /* don't risk potential race */
1852         if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1853             /* safe to reuse old SV */
1854             sv_setiv(oldsv, cur);
1855         }
1856         else
1857         {
1858             /* we need a fresh SV every time so that loop body sees a
1859              * completely new SV for closures/references to work as they
1860              * used to */
1861             *itersvp = newSViv(cur);
1862             SvREFCNT_dec_NN(oldsv);
1863         }
1864
1865         if (cur == IV_MAX) {
1866             /* Handle end of range at IV_MAX */
1867             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1868         } else
1869             ++cx->blk_loop.state_u.lazyiv.cur;
1870         break;
1871     }
1872
1873     case CXt_LOOP_FOR: /* iterate array */
1874     {
1875
1876         AV *av = cx->blk_loop.state_u.ary.ary;
1877         SV *sv;
1878         bool av_is_stack = FALSE;
1879         IV ix;
1880
1881         if (!av) {
1882             av_is_stack = TRUE;
1883             av = PL_curstack;
1884         }
1885         if (PL_op->op_private & OPpITER_REVERSED) {
1886             ix = --cx->blk_loop.state_u.ary.ix;
1887             if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
1888                 RETPUSHNO;
1889         }
1890         else {
1891             ix = ++cx->blk_loop.state_u.ary.ix;
1892             if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
1893                 RETPUSHNO;
1894         }
1895
1896         if (SvMAGICAL(av) || AvREIFY(av)) {
1897             SV * const * const svp = av_fetch(av, ix, FALSE);
1898             sv = svp ? *svp : NULL;
1899         }
1900         else {
1901             sv = AvARRAY(av)[ix];
1902         }
1903
1904         if (sv) {
1905             if (SvIS_FREED(sv)) {
1906                 *itersvp = NULL;
1907                 Perl_croak(aTHX_ "Use of freed value in iteration");
1908             }
1909             if (SvPADTMP(sv) && !IS_PADGV(sv))
1910                 sv = newSVsv(sv);
1911             else {
1912                 SvTEMP_off(sv);
1913                 SvREFCNT_inc_simple_void_NN(sv);
1914             }
1915         }
1916         else if (!av_is_stack) {
1917             sv = newSVavdefelem(av, ix, 0);
1918         }
1919         else
1920             sv = &PL_sv_undef;
1921
1922         oldsv = *itersvp;
1923         *itersvp = sv;
1924         SvREFCNT_dec(oldsv);
1925         break;
1926     }
1927
1928     default:
1929         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1930     }
1931     RETPUSHYES;
1932 }
1933
1934 /*
1935 A description of how taint works in pattern matching and substitution.
1936
1937 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1938 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1939
1940 While the pattern is being assembled/concatenated and then compiled,
1941 PL_tainted will get set (via TAINT_set) if any component of the pattern
1942 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
1943 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1944 TAINT_get).
1945
1946 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1947 the pattern is marked as tainted. This means that subsequent usage, such
1948 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1949 on the new pattern too.
1950
1951 At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the
1952 regex is cleared; during execution, locale-variant ops such as POSIXL may
1953 set RXf_TAINTED_SEEN.
1954
1955 RXf_TAINTED_SEEN is used post-execution by the get magic code
1956 of $1 et al to indicate whether the returned value should be tainted.
1957 It is the responsibility of the caller of the pattern (i.e. pp_match,
1958 pp_subst etc) to set this flag for any other circumstances where $1 needs
1959 to be tainted.
1960
1961 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1962
1963 There are three possible sources of taint
1964     * the source string
1965     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1966     * the replacement string (or expression under /e)
1967
1968 There are four destinations of taint and they are affected by the sources
1969 according to the rules below:
1970
1971     * the return value (not including /r):
1972         tainted by the source string and pattern, but only for the
1973         number-of-iterations case; boolean returns aren't tainted;
1974     * the modified string (or modified copy under /r):
1975         tainted by the source string, pattern, and replacement strings;
1976     * $1 et al:
1977         tainted by the pattern, and under 'use re "taint"', by the source
1978         string too;
1979     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
1980         should always be unset before executing subsequent code.
1981
1982 The overall action of pp_subst is:
1983
1984     * at the start, set bits in rxtainted indicating the taint status of
1985         the various sources.
1986
1987     * After each pattern execution, update the SUBST_TAINT_PAT bit in
1988         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
1989         pattern has subsequently become tainted via locale ops.
1990
1991     * If control is being passed to pp_substcont to execute a /e block,
1992         save rxtainted in the CXt_SUBST block, for future use by
1993         pp_substcont.
1994
1995     * Whenever control is being returned to perl code (either by falling
1996         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
1997         use the flag bits in rxtainted to make all the appropriate types of
1998         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
1999         et al will appear tainted.
2000
2001 pp_match is just a simpler version of the above.
2002
2003 */
2004
2005 PP(pp_subst)
2006 {
2007     dVAR; dSP; dTARG;
2008     PMOP *pm = cPMOP;
2009     PMOP *rpm = pm;
2010     char *s;
2011     char *strend;
2012     const char *c;
2013     STRLEN clen;
2014     I32 iters = 0;
2015     I32 maxiters;
2016     bool once;
2017     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2018                         See "how taint works" above */
2019     char *orig;
2020     U8 r_flags;
2021     REGEXP *rx = PM_GETRE(pm);
2022     STRLEN len;
2023     int force_on_match = 0;
2024     const I32 oldsave = PL_savestack_ix;
2025     STRLEN slen;
2026     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2027 #ifdef PERL_ANY_COW
2028     bool is_cow;
2029 #endif
2030     SV *nsv = NULL;
2031     /* known replacement string? */
2032     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2033
2034     PERL_ASYNC_CHECK();
2035
2036     if (PL_op->op_flags & OPf_STACKED)
2037         TARG = POPs;
2038     else if (PL_op->op_private & OPpTARGET_MY)
2039         GETTARGET;
2040     else {
2041         TARG = DEFSV;
2042         EXTEND(SP,1);
2043     }
2044
2045     SvGETMAGIC(TARG); /* must come before cow check */
2046 #ifdef PERL_ANY_COW
2047     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2048        because they make integers such as 256 "false".  */
2049     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2050 #else
2051     if (SvIsCOW(TARG))
2052         sv_force_normal_flags(TARG,0);
2053 #endif
2054     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2055         && (SvREADONLY(TARG)
2056             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2057                   || SvTYPE(TARG) > SVt_PVLV)
2058                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2059         Perl_croak_no_modify();
2060     PUTBACK;
2061
2062     orig = SvPV_nomg(TARG, len);
2063     /* note we don't (yet) force the var into being a string; if we fail
2064      * to match, we leave as-is; on successful match howeverm, we *will*
2065      * coerce into a string, then repeat the match */
2066     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2067         force_on_match = 1;
2068
2069     /* only replace once? */
2070     once = !(rpm->op_pmflags & PMf_GLOBAL);
2071
2072     /* See "how taint works" above */
2073     if (TAINTING_get) {
2074         rxtainted  = (
2075             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2076           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2077           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2078           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2079                 ? SUBST_TAINT_BOOLRET : 0));
2080         TAINT_NOT;
2081     }
2082
2083   force_it:
2084     if (!pm || !orig)
2085         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2086
2087     strend = orig + len;
2088     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2089     maxiters = 2 * slen + 10;   /* We can match twice at each
2090                                    position, once with zero-length,
2091                                    second time with non-zero. */
2092
2093     if (!RX_PRELEN(rx) && PL_curpm
2094      && !ReANY(rx)->mother_re) {
2095         pm = PL_curpm;
2096         rx = PM_GETRE(pm);
2097     }
2098
2099 #ifdef PERL_SAWAMPERSAND
2100     r_flags = (    RX_NPARENS(rx)
2101                 || PL_sawampersand
2102                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2103                 || (rpm->op_pmflags & PMf_KEEPCOPY)
2104               )
2105           ? REXEC_COPY_STR
2106           : 0;
2107 #else
2108     r_flags = REXEC_COPY_STR;
2109 #endif
2110
2111     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2112     {
2113         SPAGAIN;
2114         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2115         LEAVE_SCOPE(oldsave);
2116         RETURN;
2117     }
2118     PL_curpm = pm;
2119
2120     /* known replacement string? */
2121     if (dstr) {
2122         /* replacement needing upgrading? */
2123         if (DO_UTF8(TARG) && !doutf8) {
2124              nsv = sv_newmortal();
2125              SvSetSV(nsv, dstr);
2126              if (PL_encoding)
2127                   sv_recode_to_utf8(nsv, PL_encoding);
2128              else
2129                   sv_utf8_upgrade(nsv);
2130              c = SvPV_const(nsv, clen);
2131              doutf8 = TRUE;
2132         }
2133         else {
2134             c = SvPV_const(dstr, clen);
2135             doutf8 = DO_UTF8(dstr);
2136         }
2137
2138         if (SvTAINTED(dstr))
2139             rxtainted |= SUBST_TAINT_REPL;
2140     }
2141     else {
2142         c = NULL;
2143         doutf8 = FALSE;
2144     }
2145
2146     /* can do inplace substitution? */
2147     if (c
2148 #ifdef PERL_ANY_COW
2149         && !is_cow
2150 #endif
2151         && (I32)clen <= RX_MINLENRET(rx)
2152         && (  once
2153            || !(r_flags & REXEC_COPY_STR)
2154            || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2155            )
2156         && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2157         && (!doutf8 || SvUTF8(TARG))
2158         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2159     {
2160
2161 #ifdef PERL_ANY_COW
2162         if (SvIsCOW(TARG)) {
2163           if (!force_on_match)
2164             goto have_a_cow;
2165           assert(SvVOK(TARG));
2166         }
2167 #endif
2168         if (force_on_match) {
2169             /* redo the first match, this time with the orig var
2170              * forced into being a string */
2171             force_on_match = 0;
2172             orig = SvPV_force_nomg(TARG, len);
2173             goto force_it;
2174         }
2175
2176         if (once) {
2177             char *d, *m;
2178             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2179                 rxtainted |= SUBST_TAINT_PAT;
2180             m = orig + RX_OFFS(rx)[0].start;
2181             d = orig + RX_OFFS(rx)[0].end;
2182             s = orig;
2183             if (m - s > strend - d) {  /* faster to shorten from end */
2184                 I32 i;
2185                 if (clen) {
2186                     Copy(c, m, clen, char);
2187                     m += clen;
2188                 }
2189                 i = strend - d;
2190                 if (i > 0) {
2191                     Move(d, m, i, char);
2192                     m += i;
2193                 }
2194                 *m = '\0';
2195                 SvCUR_set(TARG, m - s);
2196             }
2197             else {      /* faster from front */
2198                 I32 i = m - s;
2199                 d -= clen;
2200                 if (i > 0)
2201                     Move(s, d - i, i, char);
2202                 sv_chop(TARG, d-i);
2203                 if (clen)
2204                     Copy(c, d, clen, char);
2205             }
2206             SPAGAIN;
2207             PUSHs(&PL_sv_yes);
2208         }
2209         else {
2210             char *d, *m;
2211             d = s = RX_OFFS(rx)[0].start + orig;
2212             do {
2213                 I32 i;
2214                 if (iters++ > maxiters)
2215                     DIE(aTHX_ "Substitution loop");
2216                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2217                     rxtainted |= SUBST_TAINT_PAT;
2218                 m = RX_OFFS(rx)[0].start + orig;
2219                 if ((i = m - s)) {
2220                     if (s != d)
2221                         Move(s, d, i, char);
2222                     d += i;
2223                 }
2224                 if (clen) {
2225                     Copy(c, d, clen, char);
2226                     d += clen;
2227                 }
2228                 s = RX_OFFS(rx)[0].end + orig;
2229             } while (CALLREGEXEC(rx, s, strend, orig,
2230                                  s == m, /* don't match same null twice */
2231                                  TARG, NULL,
2232                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2233             if (s != d) {
2234                 I32 i = strend - s;
2235                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2236                 Move(s, d, i+1, char);          /* include the NUL */
2237             }
2238             SPAGAIN;
2239             mPUSHi((I32)iters);
2240         }
2241     }
2242     else {
2243         bool first;
2244         char *m;
2245         SV *repl;
2246         if (force_on_match) {
2247             /* redo the first match, this time with the orig var
2248              * forced into being a string */
2249             force_on_match = 0;
2250             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2251                 /* I feel that it should be possible to avoid this mortal copy
2252                    given that the code below copies into a new destination.
2253                    However, I suspect it isn't worth the complexity of
2254                    unravelling the C<goto force_it> for the small number of
2255                    cases where it would be viable to drop into the copy code. */
2256                 TARG = sv_2mortal(newSVsv(TARG));
2257             }
2258             orig = SvPV_force_nomg(TARG, len);
2259             goto force_it;
2260         }
2261 #ifdef PERL_ANY_COW
2262       have_a_cow:
2263 #endif
2264         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2265             rxtainted |= SUBST_TAINT_PAT;
2266         repl = dstr;
2267         s = RX_OFFS(rx)[0].start + orig;
2268         dstr = newSVpvn_flags(orig, s-orig,
2269                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2270         if (!c) {
2271             PERL_CONTEXT *cx;
2272             SPAGAIN;
2273             m = orig;
2274             /* note that a whole bunch of local vars are saved here for
2275              * use by pp_substcont: here's a list of them in case you're
2276              * searching for places in this sub that uses a particular var:
2277              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2278              * s m strend rx once */
2279             PUSHSUBST(cx);
2280             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2281         }
2282         first = TRUE;
2283         do {
2284             if (iters++ > maxiters)
2285                 DIE(aTHX_ "Substitution loop");
2286             if (RX_MATCH_TAINTED(rx))
2287                 rxtainted |= SUBST_TAINT_PAT;
2288             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2289                 char *old_s    = s;
2290                 char *old_orig = orig;
2291                 assert(RX_SUBOFFSET(rx) == 0);
2292
2293                 orig = RX_SUBBEG(rx);
2294                 s = orig + (old_s - old_orig);
2295                 strend = s + (strend - old_s);
2296             }
2297             m = RX_OFFS(rx)[0].start + orig;
2298             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2299             s = RX_OFFS(rx)[0].end + orig;
2300             if (first) {
2301                 /* replacement already stringified */
2302               if (clen)
2303                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2304               first = FALSE;
2305             }
2306             else {
2307                 if (PL_encoding) {
2308                     if (!nsv) nsv = sv_newmortal();
2309                     sv_copypv(nsv, repl);
2310                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2311                     sv_catsv(dstr, nsv);
2312                 }
2313                 else sv_catsv(dstr, repl);
2314                 if (SvTAINTED(repl))
2315                     rxtainted |= SUBST_TAINT_REPL;
2316             }
2317             if (once)
2318                 break;
2319         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2320                              TARG, NULL,
2321                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2322         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2323
2324         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2325             /* From here on down we're using the copy, and leaving the original
2326                untouched.  */
2327             TARG = dstr;
2328             SPAGAIN;
2329             PUSHs(dstr);
2330         } else {
2331 #ifdef PERL_ANY_COW
2332             /* The match may make the string COW. If so, brilliant, because
2333                that's just saved us one malloc, copy and free - the regexp has
2334                donated the old buffer, and we malloc an entirely new one, rather
2335                than the regexp malloc()ing a buffer and copying our original,
2336                only for us to throw it away here during the substitution.  */
2337             if (SvIsCOW(TARG)) {
2338                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2339             } else
2340 #endif
2341             {
2342                 SvPV_free(TARG);
2343             }
2344             SvPV_set(TARG, SvPVX(dstr));
2345             SvCUR_set(TARG, SvCUR(dstr));
2346             SvLEN_set(TARG, SvLEN(dstr));
2347             SvFLAGS(TARG) |= SvUTF8(dstr);
2348             SvPV_set(dstr, NULL);
2349
2350             SPAGAIN;
2351             mPUSHi((I32)iters);
2352         }
2353     }
2354
2355     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2356         (void)SvPOK_only_UTF8(TARG);
2357     }
2358
2359     /* See "how taint works" above */
2360     if (TAINTING_get) {
2361         if ((rxtainted & SUBST_TAINT_PAT) ||
2362             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2363                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2364         )
2365             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2366
2367         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2368             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2369         )
2370             SvTAINTED_on(TOPs);  /* taint return value */
2371         else
2372             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2373
2374         /* needed for mg_set below */
2375         TAINT_set(
2376           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2377         );
2378         SvTAINT(TARG);
2379     }
2380     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2381     TAINT_NOT;
2382     LEAVE_SCOPE(oldsave);
2383     RETURN;
2384 }
2385
2386 PP(pp_grepwhile)
2387 {
2388     dVAR; dSP;
2389
2390     if (SvTRUEx(POPs))
2391         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2392     ++*PL_markstack_ptr;
2393     FREETMPS;
2394     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2395
2396     /* All done yet? */
2397     if (PL_stack_base + *PL_markstack_ptr > SP) {
2398         I32 items;
2399         const I32 gimme = GIMME_V;
2400
2401         LEAVE_with_name("grep");                                        /* exit outer scope */
2402         (void)POPMARK;                          /* pop src */
2403         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2404         (void)POPMARK;                          /* pop dst */
2405         SP = PL_stack_base + POPMARK;           /* pop original mark */
2406         if (gimme == G_SCALAR) {
2407             if (PL_op->op_private & OPpGREP_LEX) {
2408                 SV* const sv = sv_newmortal();
2409                 sv_setiv(sv, items);
2410                 PUSHs(sv);
2411             }
2412             else {
2413                 dTARGET;
2414                 XPUSHi(items);
2415             }
2416         }
2417         else if (gimme == G_ARRAY)
2418             SP += items;
2419         RETURN;
2420     }
2421     else {
2422         SV *src;
2423
2424         ENTER_with_name("grep_item");                                   /* enter inner scope */
2425         SAVEVPTR(PL_curpm);
2426
2427         src = PL_stack_base[*PL_markstack_ptr];
2428         if (SvPADTMP(src) && !IS_PADGV(src)) {
2429             src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2430             PL_tmps_floor++;
2431         }
2432         SvTEMP_off(src);
2433         if (PL_op->op_private & OPpGREP_LEX)
2434             PAD_SVl(PL_op->op_targ) = src;
2435         else
2436             DEFSV_set(src);
2437
2438         RETURNOP(cLOGOP->op_other);
2439     }
2440 }
2441
2442 PP(pp_leavesub)
2443 {
2444     dVAR; dSP;
2445     SV **mark;
2446     SV **newsp;
2447     PMOP *newpm;
2448     I32 gimme;
2449     PERL_CONTEXT *cx;
2450     SV *sv;
2451
2452     if (CxMULTICALL(&cxstack[cxstack_ix]))
2453         return 0;
2454
2455     POPBLOCK(cx,newpm);
2456     cxstack_ix++; /* temporarily protect top context */
2457
2458     TAINT_NOT;
2459     if (gimme == G_SCALAR) {
2460         MARK = newsp + 1;
2461         if (MARK <= SP) {
2462             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2463                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2464                      && !SvMAGICAL(TOPs)) {
2465                     *MARK = SvREFCNT_inc(TOPs);
2466                     FREETMPS;
2467                     sv_2mortal(*MARK);
2468                 }
2469                 else {
2470                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2471                     FREETMPS;
2472                     *MARK = sv_mortalcopy(sv);
2473                     SvREFCNT_dec_NN(sv);
2474                 }
2475             }
2476             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2477                      && !SvMAGICAL(TOPs)) {
2478                 *MARK = TOPs;
2479             }
2480             else
2481                 *MARK = sv_mortalcopy(TOPs);
2482         }
2483         else {
2484             MEXTEND(MARK, 0);
2485             *MARK = &PL_sv_undef;
2486         }
2487         SP = MARK;
2488     }
2489     else if (gimme == G_ARRAY) {
2490         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2491             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2492                  || SvMAGICAL(*MARK)) {
2493                 *MARK = sv_mortalcopy(*MARK);
2494                 TAINT_NOT;      /* Each item is independent */
2495             }
2496         }
2497     }
2498     PUTBACK;
2499
2500     LEAVE;
2501     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2502     cxstack_ix--;
2503     PL_curpm = newpm;   /* ... and pop $1 et al */
2504
2505     LEAVESUB(sv);
2506     return cx->blk_sub.retop;
2507 }
2508
2509 PP(pp_entersub)
2510 {
2511     dVAR; dSP; dPOPss;
2512     GV *gv;
2513     CV *cv;
2514     PERL_CONTEXT *cx;
2515     I32 gimme;
2516     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2517
2518     if (!sv)
2519         DIE(aTHX_ "Not a CODE reference");
2520     switch (SvTYPE(sv)) {
2521         /* This is overwhelming the most common case:  */
2522     case SVt_PVGV:
2523       we_have_a_glob:
2524         if (!(cv = GvCVu((const GV *)sv))) {
2525             HV *stash;
2526             cv = sv_2cv(sv, &stash, &gv, 0);
2527         }
2528         if (!cv) {
2529             ENTER;
2530             SAVETMPS;
2531             goto try_autoload;
2532         }
2533         break;
2534     case SVt_PVLV:
2535         if(isGV_with_GP(sv)) goto we_have_a_glob;
2536         /*FALLTHROUGH*/
2537     default:
2538         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2539             if (hasargs)
2540                 SP = PL_stack_base + POPMARK;
2541             else
2542                 (void)POPMARK;
2543             RETURN;
2544         }
2545         SvGETMAGIC(sv);
2546         if (SvROK(sv)) {
2547             if (SvAMAGIC(sv)) {
2548                 sv = amagic_deref_call(sv, to_cv_amg);
2549                 /* Don't SPAGAIN here.  */
2550             }
2551         }
2552         else {
2553             const char *sym;
2554             STRLEN len;
2555             if (!SvOK(sv))
2556                 DIE(aTHX_ PL_no_usym, "a subroutine");
2557             sym = SvPV_nomg_const(sv, len);
2558             if (PL_op->op_private & HINT_STRICT_REFS)
2559                 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2560             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2561             break;
2562         }
2563         cv = MUTABLE_CV(SvRV(sv));
2564         if (SvTYPE(cv) == SVt_PVCV)
2565             break;
2566         /* FALL THROUGH */
2567     case SVt_PVHV:
2568     case SVt_PVAV:
2569         DIE(aTHX_ "Not a CODE reference");
2570         /* This is the second most common case:  */
2571     case SVt_PVCV:
2572         cv = MUTABLE_CV(sv);
2573         break;
2574     }
2575
2576     ENTER;
2577
2578   retry:
2579     if (CvCLONE(cv) && ! CvCLONED(cv))
2580         DIE(aTHX_ "Closure prototype called");
2581     if (!CvROOT(cv) && !CvXSUB(cv)) {
2582         GV* autogv;
2583         SV* sub_name;
2584
2585         /* anonymous or undef'd function leaves us no recourse */
2586         if (CvANON(cv) || !(gv = CvGV(cv))) {
2587             if (CvNAMED(cv))
2588                 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2589                            HEKfARG(CvNAME_HEK(cv)));
2590             DIE(aTHX_ "Undefined subroutine called");
2591         }
2592
2593         /* autoloaded stub? */
2594         if (cv != GvCV(gv)) {
2595             cv = GvCV(gv);
2596         }
2597         /* should call AUTOLOAD now? */
2598         else {
2599 try_autoload:
2600             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2601                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2602             {
2603                 cv = GvCV(autogv);
2604             }
2605             else {
2606                sorry:
2607                 sub_name = sv_newmortal();
2608                 gv_efullname3(sub_name, gv, NULL);
2609                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2610             }
2611         }
2612         if (!cv)
2613             goto sorry;
2614         goto retry;
2615     }
2616
2617     gimme = GIMME_V;
2618     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2619          Perl_get_db_sub(aTHX_ &sv, cv);
2620          if (CvISXSUB(cv))
2621              PL_curcopdb = PL_curcop;
2622          if (CvLVALUE(cv)) {
2623              /* check for lsub that handles lvalue subroutines */
2624              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
2625              /* if lsub not found then fall back to DB::sub */
2626              if (!cv) cv = GvCV(PL_DBsub);
2627          } else {
2628              cv = GvCV(PL_DBsub);
2629          }
2630
2631         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2632             DIE(aTHX_ "No DB::sub routine defined");
2633     }
2634
2635     if (!(CvISXSUB(cv))) {
2636         /* This path taken at least 75% of the time   */
2637         dMARK;
2638         SSize_t items = SP - MARK;
2639         PADLIST * const padlist = CvPADLIST(cv);
2640         PUSHBLOCK(cx, CXt_SUB, MARK);
2641         PUSHSUB(cx);
2642         cx->blk_sub.retop = PL_op->op_next;
2643         CvDEPTH(cv)++;
2644         if (CvDEPTH(cv) >= 2) {
2645             PERL_STACK_OVERFLOW_CHECK();
2646             pad_push(padlist, CvDEPTH(cv));
2647         }
2648         SAVECOMPPAD();
2649         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2650         if (hasargs) {
2651             AV *const av = MUTABLE_AV(PAD_SVl(0));
2652             if (AvREAL(av)) {
2653                 /* @_ is normally not REAL--this should only ever
2654                  * happen when DB::sub() calls things that modify @_ */
2655                 av_clear(av);
2656                 AvREAL_off(av);
2657                 AvREIFY_on(av);
2658             }
2659             cx->blk_sub.savearray = GvAV(PL_defgv);
2660             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2661             CX_CURPAD_SAVE(cx->blk_sub);
2662             cx->blk_sub.argarray = av;
2663             ++MARK;
2664
2665             if (items - 1 > AvMAX(av)) {
2666                 SV **ary = AvALLOC(av);
2667                 AvMAX(av) = items - 1;
2668                 Renew(ary, items, SV*);
2669                 AvALLOC(av) = ary;
2670                 AvARRAY(av) = ary;
2671             }
2672
2673             Copy(MARK,AvARRAY(av),items,SV*);
2674             AvFILLp(av) = items - 1;
2675
2676             MARK = AvARRAY(av);
2677             while (items--) {
2678                 if (*MARK)
2679                 {
2680                     if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
2681                         *MARK = sv_mortalcopy(*MARK);
2682                     SvTEMP_off(*MARK);
2683                 }
2684                 MARK++;
2685             }
2686         }
2687         SAVETMPS;
2688         if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2689             !CvLVALUE(cv))
2690             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2691         /* warning must come *after* we fully set up the context
2692          * stuff so that __WARN__ handlers can safely dounwind()
2693          * if they want to
2694          */
2695         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2696             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2697             sub_crush_depth(cv);
2698         RETURNOP(CvSTART(cv));
2699     }
2700     else {
2701         SSize_t markix = TOPMARK;
2702
2703         SAVETMPS;
2704         PUTBACK;
2705
2706         if (((PL_op->op_private
2707                & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2708              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2709             !CvLVALUE(cv))
2710             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2711
2712         if (!hasargs && GvAV(PL_defgv)) {
2713             /* Need to copy @_ to stack. Alternative may be to
2714              * switch stack to @_, and copy return values
2715              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2716             AV * const av = GvAV(PL_defgv);
2717             const SSize_t items = AvFILL(av) + 1;
2718
2719             if (items) {
2720                 SSize_t i = 0;
2721                 const bool m = cBOOL(SvRMAGICAL(av));
2722                 /* Mark is at the end of the stack. */
2723                 EXTEND(SP, items);
2724                 for (; i < items; ++i)
2725                 {
2726                     SV *sv;
2727                     if (m) {
2728                         SV ** const svp = av_fetch(av, i, 0);
2729                         sv = svp ? *svp : NULL;
2730                     }
2731                     else sv = AvARRAY(av)[i];
2732                     if (sv) SP[i+1] = sv;
2733                     else {
2734                         SP[i+1] = newSVavdefelem(av, i, 1);
2735                     }
2736                 }
2737                 SP += items;
2738                 PUTBACK ;
2739             }
2740         }
2741         else {
2742             SV **mark = PL_stack_base + markix;
2743             SSize_t items = SP - mark;
2744             while (items--) {
2745                 mark++;
2746                 if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark))
2747                     *mark = sv_mortalcopy(*mark);
2748             }
2749         }
2750         /* We assume first XSUB in &DB::sub is the called one. */
2751         if (PL_curcopdb) {
2752             SAVEVPTR(PL_curcop);
2753             PL_curcop = PL_curcopdb;
2754             PL_curcopdb = NULL;
2755         }
2756         /* Do we need to open block here? XXXX */
2757
2758         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2759         assert(CvXSUB(cv));
2760         CvXSUB(cv)(aTHX_ cv);
2761
2762         /* Enforce some sanity in scalar context. */
2763         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2764             if (markix > PL_stack_sp - PL_stack_base)
2765                 *(PL_stack_base + markix) = &PL_sv_undef;
2766             else
2767                 *(PL_stack_base + markix) = *PL_stack_sp;
2768             PL_stack_sp = PL_stack_base + markix;
2769         }
2770         LEAVE;
2771         return NORMAL;
2772     }
2773 }
2774
2775 void
2776 Perl_sub_crush_depth(pTHX_ CV *cv)
2777 {
2778     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2779
2780     if (CvANON(cv))
2781         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2782     else {
2783         HEK *const hek = CvNAME_HEK(cv);
2784         SV *tmpstr;
2785         if (hek) {
2786             tmpstr = sv_2mortal(newSVhek(hek));
2787         }
2788         else {
2789             tmpstr = sv_newmortal();
2790             gv_efullname3(tmpstr, CvGV(cv), NULL);
2791         }
2792         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2793                     SVfARG(tmpstr));
2794     }
2795 }
2796
2797 PP(pp_aelem)
2798 {
2799     dVAR; dSP;
2800     SV** svp;
2801     SV* const elemsv = POPs;
2802     IV elem = SvIV(elemsv);
2803     AV *const av = MUTABLE_AV(POPs);
2804     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2805     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2806     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2807     bool preeminent = TRUE;
2808     SV *sv;
2809
2810     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2811         Perl_warner(aTHX_ packWARN(WARN_MISC),
2812                     "Use of reference \"%"SVf"\" as array index",
2813                     SVfARG(elemsv));
2814     if (SvTYPE(av) != SVt_PVAV)
2815         RETPUSHUNDEF;
2816
2817     if (localizing) {
2818         MAGIC *mg;
2819         HV *stash;
2820
2821         /* If we can determine whether the element exist,
2822          * Try to preserve the existenceness of a tied array
2823          * element by using EXISTS and DELETE if possible.
2824          * Fallback to FETCH and STORE otherwise. */
2825         if (SvCANEXISTDELETE(av))
2826             preeminent = av_exists(av, elem);
2827     }
2828
2829     svp = av_fetch(av, elem, lval && !defer);
2830     if (lval) {
2831 #ifdef PERL_MALLOC_WRAP
2832          if (SvUOK(elemsv)) {
2833               const UV uv = SvUV(elemsv);
2834               elem = uv > IV_MAX ? IV_MAX : uv;
2835          }
2836          else if (SvNOK(elemsv))
2837               elem = (IV)SvNV(elemsv);
2838          if (elem > 0) {
2839               static const char oom_array_extend[] =
2840                 "Out of memory during array extend"; /* Duplicated in av.c */
2841               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2842          }
2843 #endif
2844         if (!svp || !*svp) {
2845             IV len;
2846             if (!defer)
2847                 DIE(aTHX_ PL_no_aelem, elem);
2848             len = av_len(av);
2849             mPUSHs(newSVavdefelem(av,
2850             /* Resolve a negative index now, unless it points before the
2851                beginning of the array, in which case record it for error
2852                reporting in magic_setdefelem. */
2853                 elem < 0 && len + elem >= 0 ? len + elem : elem,
2854                 1));
2855             RETURN;
2856         }
2857         if (localizing) {
2858             if (preeminent)
2859                 save_aelem(av, elem, svp);
2860             else
2861                 SAVEADELETE(av, elem);
2862         }
2863         else if (PL_op->op_private & OPpDEREF) {
2864             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2865             RETURN;
2866         }
2867     }
2868     sv = (svp ? *svp : &PL_sv_undef);
2869     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2870         mg_get(sv);
2871     PUSHs(sv);
2872     RETURN;
2873 }
2874
2875 SV*
2876 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2877 {
2878     PERL_ARGS_ASSERT_VIVIFY_REF;
2879
2880     SvGETMAGIC(sv);
2881     if (!SvOK(sv)) {
2882         if (SvREADONLY(sv))
2883             Perl_croak_no_modify();
2884         prepare_SV_for_RV(sv);
2885         switch (to_what) {
2886         case OPpDEREF_SV:
2887             SvRV_set(sv, newSV(0));
2888             break;
2889         case OPpDEREF_AV:
2890             SvRV_set(sv, MUTABLE_SV(newAV()));
2891             break;
2892         case OPpDEREF_HV:
2893             SvRV_set(sv, MUTABLE_SV(newHV()));
2894             break;
2895         }
2896         SvROK_on(sv);
2897         SvSETMAGIC(sv);
2898         SvGETMAGIC(sv);
2899     }
2900     if (SvGMAGICAL(sv)) {
2901         /* copy the sv without magic to prevent magic from being
2902            executed twice */
2903         SV* msv = sv_newmortal();
2904         sv_setsv_nomg(msv, sv);
2905         return msv;
2906     }
2907     return sv;
2908 }
2909
2910 PP(pp_method)
2911 {
2912     dVAR; dSP;
2913     SV* const sv = TOPs;
2914
2915     if (SvROK(sv)) {
2916         SV* const rsv = SvRV(sv);
2917         if (SvTYPE(rsv) == SVt_PVCV) {
2918             SETs(rsv);
2919             RETURN;
2920         }
2921     }
2922
2923     SETs(method_common(sv, NULL));
2924     RETURN;
2925 }
2926
2927 PP(pp_method_named)
2928 {
2929     dVAR; dSP;
2930     SV* const sv = cSVOP_sv;
2931     U32 hash = SvSHARED_HASH(sv);
2932
2933     XPUSHs(method_common(sv, &hash));
2934     RETURN;
2935 }
2936
2937 STATIC SV *
2938 S_method_common(pTHX_ SV* meth, U32* hashp)
2939 {
2940     dVAR;
2941     SV* ob;
2942     GV* gv;
2943     HV* stash;
2944     SV *packsv = NULL;
2945     SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2946         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2947                             "package or object reference", SVfARG(meth)),
2948            (SV *)NULL)
2949         : *(PL_stack_base + TOPMARK + 1);
2950
2951     PERL_ARGS_ASSERT_METHOD_COMMON;
2952
2953     if (!sv)
2954        undefined:
2955         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2956                    SVfARG(meth));
2957
2958     SvGETMAGIC(sv);
2959     if (SvROK(sv))
2960         ob = MUTABLE_SV(SvRV(sv));
2961     else if (!SvOK(sv)) goto undefined;
2962     else if (isGV_with_GP(sv)) {
2963         if (!GvIO(sv))
2964             Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2965                              "without a package or object reference",
2966                               SVfARG(meth));
2967         ob = sv;
2968         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
2969             assert(!LvTARGLEN(ob));
2970             ob = LvTARG(ob);
2971             assert(ob);
2972         }
2973         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
2974     }
2975     else {
2976         /* this isn't a reference */
2977         GV* iogv;
2978         STRLEN packlen;
2979         const char * const packname = SvPV_nomg_const(sv, packlen);
2980         const bool packname_is_utf8 = !!SvUTF8(sv);
2981         const HE* const he =
2982             (const HE *)hv_common(
2983                 PL_stashcache, NULL, packname, packlen,
2984                 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
2985             );
2986
2987         if (he) {
2988             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2989             DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
2990                              stash, sv));
2991             goto fetch;
2992         }
2993
2994         if (!(iogv = gv_fetchpvn_flags(
2995                 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2996              )) ||
2997             !(ob=MUTABLE_SV(GvIO(iogv))))
2998         {
2999             /* this isn't the name of a filehandle either */
3000             if (!packlen)
3001             {
3002                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3003                                  "without a package or object reference",
3004                                   SVfARG(meth));
3005             }
3006             /* assume it's a package name */
3007             stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3008             if (!stash)
3009                 packsv = sv;
3010             else {
3011                 SV* const ref = newSViv(PTR2IV(stash));
3012                 (void)hv_store(PL_stashcache, packname,
3013                                 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3014                 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3015                                  stash, sv));
3016             }
3017             goto fetch;
3018         }
3019         /* it _is_ a filehandle name -- replace with a reference */
3020         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3021     }
3022
3023     /* if we got here, ob should be an object or a glob */
3024     if (!ob || !(SvOBJECT(ob)
3025                  || (isGV_with_GP(ob)
3026                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3027                      && SvOBJECT(ob))))
3028     {
3029         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3030                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3031                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3032                                         : meth));
3033     }
3034
3035     stash = SvSTASH(ob);
3036
3037   fetch:
3038     /* NOTE: stash may be null, hope hv_fetch_ent and
3039        gv_fetchmethod can cope (it seems they can) */
3040
3041     /* shortcut for simple names */
3042     if (hashp) {
3043         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3044         if (he) {
3045             gv = MUTABLE_GV(HeVAL(he));
3046             if (isGV(gv) && GvCV(gv) &&
3047                 (!GvCVGEN(gv) || GvCVGEN(gv)
3048                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3049                 return MUTABLE_SV(GvCV(gv));
3050         }
3051     }
3052
3053     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3054                                      meth, GV_AUTOLOAD | GV_CROAK);
3055
3056     assert(gv);
3057
3058     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3059 }
3060
3061 /*
3062  * Local variables:
3063  * c-indentation-style: bsd
3064  * c-basic-offset: 4
3065  * indent-tabs-mode: nil
3066  * End:
3067  *
3068  * ex: set ts=8 sts=4 sw=4 et:
3069  */