pp_hot.c

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