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