pp_hot.c

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