pp_hot.c

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