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