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 /* also called directly by pp_lvavref */
 890
 891 PP(pp_rv2av)
 892 {
 893     dSP; dTOPss;
 894     const I32 gimme = GIMME_V;
 895     static const char an_array[] = "an ARRAY";
 896     static const char a_hash[] = "a HASH";
 897     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
 898                           || PL_op->op_type == OP_LVAVREF;
 899     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 900
 901     SvGETMAGIC(sv);
 902     if (SvROK(sv)) {
 903         if (UNLIKELY(SvAMAGIC(sv))) {
 904             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
 905         }
 906         sv = SvRV(sv);
 907         if (UNLIKELY(SvTYPE(sv) != type))
 908             /* diag_listed_as: Not an ARRAY reference */
 909             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
 910         else if (UNLIKELY(PL_op->op_flags & OPf_MOD
 911                 && PL_op->op_private & OPpLVAL_INTRO))
 912             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 913     }
 914     else if (UNLIKELY(SvTYPE(sv) != type)) {
 915             GV *gv;
 916
 917             if (!isGV_with_GP(sv)) {
 918                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 919                                      type, &sp);
 920                 if (!gv)
 921                     RETURN;
 922             }
 923             else {
 924                 gv = MUTABLE_GV(sv);
 925             }
 926             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
 927             if (PL_op->op_private & OPpLVAL_INTRO)
 928                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
 929     }
 930     if (PL_op->op_flags & OPf_REF) {
 931                 SETs(sv);
 932                 RETURN;
 933     }
 934     else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
 935               const I32 flags = is_lvalue_sub();
 936               if (flags && !(flags & OPpENTERSUB_INARGS)) {
 937                 if (gimme != G_ARRAY)
 938                     goto croak_cant_return;
 939                 SETs(sv);
 940                 RETURN;
 941               }
 942     }
 943
 944     if (is_pp_rv2av) {
 945         AV *const av = MUTABLE_AV(sv);
 946         /* The guts of pp_rv2av  */
 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         bool alias = FALSE;
1075         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1076         sv = *lelem++;
1077         if (UNLIKELY(!sv)) {
1078             alias = TRUE;
1079             sv = *lelem++;
1080             ASSUME(SvTYPE(sv) == SVt_PVAV);
1081         }
1082         switch (SvTYPE(sv)) {
1083         case SVt_PVAV:
1084             ary = MUTABLE_AV(sv);
1085             magic = SvMAGICAL(ary) != 0;
1086             ENTER;
1087             SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1088             av_clear(ary);
1089             av_extend(ary, lastrelem - relem);
1090             i = 0;
1091             while (relem <= lastrelem) {        /* gobble up all the rest */
1092                 SV **didstore;
1093                 if (LIKELY(*relem))
1094                     SvGETMAGIC(*relem); /* before newSV, in case it dies */
1095                 if (LIKELY(!alias)) {
1096                     sv = newSV(0);
1097                     sv_setsv_nomg(sv, *relem);
1098                     *relem = sv;
1099                 }
1100                 else {
1101                     if (!SvROK(*relem))
1102                         DIE(aTHX_ "Assigned value is not a reference");
1103                     if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1104                    /* diag_listed_as: Assigned value is not %s reference */
1105                         DIE(aTHX_
1106                            "Assigned value is not a SCALAR reference");
1107                     if (lval)
1108                         *relem = sv_mortalcopy(*relem);
1109                     /* XXX else check for weak refs?  */
1110                     sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1111                 }
1112                 relem++;
1113                 didstore = av_store(ary,i++,sv);
1114                 if (magic) {
1115                     if (!didstore)
1116                         sv_2mortal(sv);
1117                     if (SvSMAGICAL(sv))
1118                         mg_set(sv);
1119                 }
1120                 TAINT_NOT;
1121             }
1122             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1123                 SvSETMAGIC(MUTABLE_SV(ary));
1124             LEAVE;
1125             break;
1126         case SVt_PVHV: {                                /* normal hash */
1127                 SV *tmpstr;
1128                 int odd;
1129                 int duplicates = 0;
1130                 SV** topelem = relem;
1131                 SV **firsthashrelem = relem;
1132
1133                 hash = MUTABLE_HV(sv);
1134                 magic = SvMAGICAL(hash) != 0;
1135
1136                 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1137                 if (UNLIKELY(odd)) {
1138                     do_oddball(lastrelem, firsthashrelem);
1139                     /* we have firstlelem to reuse, it's not needed anymore
1140                      */
1141                     *(lastrelem+1) = &PL_sv_undef;
1142                 }
1143
1144                 ENTER;
1145                 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1146                 hv_clear(hash);
1147                 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1148                     HE *didstore;
1149                     assert(*relem);
1150                     /* Copy the key if aassign is called in lvalue context,
1151                        to avoid having the next op modify our rhs.  Copy
1152                        it also if it is gmagical, lest it make the
1153                        hv_store_ent call below croak, leaking the value. */
1154                     sv = lval || SvGMAGICAL(*relem)
1155                          ? sv_mortalcopy(*relem)
1156                          : *relem;
1157                     relem++;
1158                     assert(*relem);
1159                     SvGETMAGIC(*relem);
1160                     tmpstr = newSV(0);
1161                     sv_setsv_nomg(tmpstr,*relem++);     /* value */
1162                     if (gimme == G_ARRAY) {
1163                         if (hv_exists_ent(hash, sv, 0))
1164                             /* key overwrites an existing entry */
1165                             duplicates += 2;
1166                         else {
1167                             /* copy element back: possibly to an earlier
1168                              * stack location if we encountered dups earlier,
1169                              * possibly to a later stack location if odd */
1170                             *topelem++ = sv;
1171                             *topelem++ = tmpstr;
1172                         }
1173                     }
1174                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1175                     if (magic) {
1176                         if (!didstore) sv_2mortal(tmpstr);
1177                         SvSETMAGIC(tmpstr);
1178                     }
1179                     TAINT_NOT;
1180                 }
1181                 LEAVE;
1182                 if (duplicates && gimme == G_ARRAY) {
1183                     /* at this point we have removed the duplicate key/value
1184                      * pairs from the stack, but the remaining values may be
1185                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1186                      * the (a 2), but the stack now probably contains
1187                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1188                      * obliterates the earlier key. So refresh all values. */
1189                     lastrelem -= duplicates;
1190                     relem = firsthashrelem;
1191                     while (relem < lastrelem+odd) {
1192                         HE *he;
1193                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1194                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1195                     }
1196                 }
1197                 if (odd && gimme == G_ARRAY) lastrelem++;
1198             }
1199             break;
1200         default:
1201             if (SvIMMORTAL(sv)) {
1202                 if (relem <= lastrelem)
1203                     relem++;
1204                 break;
1205             }
1206             if (relem <= lastrelem) {
1207                 if (UNLIKELY(
1208                   SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1209                   (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1210                 ))
1211                     Perl_warner(aTHX_
1212                        packWARN(WARN_MISC),
1213                       "Useless assignment to a temporary"
1214                     );
1215                 sv_setsv(sv, *relem);
1216                 *(relem++) = sv;
1217             }
1218             else
1219                 sv_setsv(sv, &PL_sv_undef);
1220             SvSETMAGIC(sv);
1221             break;
1222         }
1223     }
1224     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1225         /* Will be used to set PL_tainting below */
1226         Uid_t tmp_uid  = PerlProc_getuid();
1227         Uid_t tmp_euid = PerlProc_geteuid();
1228         Gid_t tmp_gid  = PerlProc_getgid();
1229         Gid_t tmp_egid = PerlProc_getegid();
1230
1231         /* XXX $> et al currently silently ignore failures */
1232         if (PL_delaymagic & DM_UID) {
1233 #ifdef HAS_SETRESUID
1234             PERL_UNUSED_RESULT(
1235                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1236                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1237                          (Uid_t)-1));
1238 #else
1239 #  ifdef HAS_SETREUID
1240             PERL_UNUSED_RESULT(
1241                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1242                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1243 #  else
1244 #    ifdef HAS_SETRUID
1245             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1246                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1247                 PL_delaymagic &= ~DM_RUID;
1248             }
1249 #    endif /* HAS_SETRUID */
1250 #    ifdef HAS_SETEUID
1251             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1252                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1253                 PL_delaymagic &= ~DM_EUID;
1254             }
1255 #    endif /* HAS_SETEUID */
1256             if (PL_delaymagic & DM_UID) {
1257                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1258                     DIE(aTHX_ "No setreuid available");
1259                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1260             }
1261 #  endif /* HAS_SETREUID */
1262 #endif /* HAS_SETRESUID */
1263
1264             tmp_uid  = PerlProc_getuid();
1265             tmp_euid = PerlProc_geteuid();
1266         }
1267         /* XXX $> et al currently silently ignore failures */
1268         if (PL_delaymagic & DM_GID) {
1269 #ifdef HAS_SETRESGID
1270             PERL_UNUSED_RESULT(
1271                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1272                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1273                           (Gid_t)-1));
1274 #else
1275 #  ifdef HAS_SETREGID
1276             PERL_UNUSED_RESULT(
1277                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1278                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1279 #  else
1280 #    ifdef HAS_SETRGID
1281             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1282                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1283                 PL_delaymagic &= ~DM_RGID;
1284             }
1285 #    endif /* HAS_SETRGID */
1286 #    ifdef HAS_SETEGID
1287             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1288                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1289                 PL_delaymagic &= ~DM_EGID;
1290             }
1291 #    endif /* HAS_SETEGID */
1292             if (PL_delaymagic & DM_GID) {
1293                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1294                     DIE(aTHX_ "No setregid available");
1295                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1296             }
1297 #  endif /* HAS_SETREGID */
1298 #endif /* HAS_SETRESGID */
1299
1300             tmp_gid  = PerlProc_getgid();
1301             tmp_egid = PerlProc_getegid();
1302         }
1303         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1304 #ifdef NO_TAINT_SUPPORT
1305         PERL_UNUSED_VAR(tmp_uid);
1306         PERL_UNUSED_VAR(tmp_euid);
1307         PERL_UNUSED_VAR(tmp_gid);
1308         PERL_UNUSED_VAR(tmp_egid);
1309 #endif
1310     }
1311     PL_delaymagic = 0;
1312
1313     if (gimme == G_VOID)
1314         SP = firstrelem - 1;
1315     else if (gimme == G_SCALAR) {
1316         dTARGET;
1317         SP = firstrelem;
1318         SETi(lastrelem - firstrelem + 1);
1319     }
1320     else {
1321         if (ary || hash)
1322             /* note that in this case *firstlelem may have been overwritten
1323                by sv_undef in the odd hash case */
1324             SP = lastrelem;
1325         else {
1326             SP = firstrelem + (lastlelem - firstlelem);
1327             lelem = firstlelem + (relem - firstrelem);
1328             while (relem <= SP)
1329                 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1330         }
1331     }
1332
1333     RETURN;
1334 }
1335
1336 PP(pp_qr)
1337 {
1338     dSP;
1339     PMOP * const pm = cPMOP;
1340     REGEXP * rx = PM_GETRE(pm);
1341     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1342     SV * const rv = sv_newmortal();
1343     CV **cvp;
1344     CV *cv;
1345
1346     SvUPGRADE(rv, SVt_IV);
1347     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1348        loathe to use it here, but it seems to be the right fix. Or close.
1349        The key part appears to be that it's essential for pp_qr to return a new
1350        object (SV), which implies that there needs to be an effective way to
1351        generate a new SV from the existing SV that is pre-compiled in the
1352        optree.  */
1353     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1354     SvROK_on(rv);
1355
1356     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1357     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1358         *cvp = cv_clone(cv);
1359         SvREFCNT_dec_NN(cv);
1360     }
1361
1362     if (pkg) {
1363         HV *const stash = gv_stashsv(pkg, GV_ADD);
1364         SvREFCNT_dec_NN(pkg);
1365         (void)sv_bless(rv, stash);
1366     }
1367
1368     if (UNLIKELY(RX_ISTAINTED(rx))) {
1369         SvTAINTED_on(rv);
1370         SvTAINTED_on(SvRV(rv));
1371     }
1372     XPUSHs(rv);
1373     RETURN;
1374 }
1375
1376 PP(pp_match)
1377 {
1378     dSP; dTARG;
1379     PMOP *pm = cPMOP;
1380     PMOP *dynpm = pm;
1381     const char *s;
1382     const char *strend;
1383     SSize_t curpos = 0; /* initial pos() or current $+[0] */
1384     I32 global;
1385     U8 r_flags = 0;
1386     const char *truebase;                       /* Start of string  */
1387     REGEXP *rx = PM_GETRE(pm);
1388     bool rxtainted;
1389     const I32 gimme = GIMME;
1390     STRLEN len;
1391     const I32 oldsave = PL_savestack_ix;
1392     I32 had_zerolen = 0;
1393     MAGIC *mg = NULL;
1394
1395     if (PL_op->op_flags & OPf_STACKED)
1396         TARG = POPs;
1397     else if (ARGTARG)
1398         GETTARGET;
1399     else {
1400         TARG = DEFSV;
1401         EXTEND(SP,1);
1402     }
1403
1404     PUTBACK;                            /* EVAL blocks need stack_sp. */
1405     /* Skip get-magic if this is a qr// clone, because regcomp has
1406        already done it. */
1407     truebase = ReANY(rx)->mother_re
1408          ? SvPV_nomg_const(TARG, len)
1409          : SvPV_const(TARG, len);
1410     if (!truebase)
1411         DIE(aTHX_ "panic: pp_match");
1412     strend = truebase + len;
1413     rxtainted = (RX_ISTAINTED(rx) ||
1414                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1415     TAINT_NOT;
1416
1417     /* We need to know this in case we fail out early - pos() must be reset */
1418     global = dynpm->op_pmflags & PMf_GLOBAL;
1419
1420     /* PMdf_USED is set after a ?? matches once */
1421     if (
1422 #ifdef USE_ITHREADS
1423         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1424 #else
1425         pm->op_pmflags & PMf_USED
1426 #endif
1427     ) {
1428         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1429         goto nope;
1430     }
1431
1432     /* empty pattern special-cased to use last successful pattern if
1433        possible, except for qr// */
1434     if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1435      && PL_curpm) {
1436         pm = PL_curpm;
1437         rx = PM_GETRE(pm);
1438     }
1439
1440     if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1441         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1442                                               UVuf" < %"IVdf")\n",
1443                                               (UV)len, (IV)RX_MINLEN(rx)));
1444         goto nope;
1445     }
1446
1447     /* get pos() if //g */
1448     if (global) {
1449         mg = mg_find_mglob(TARG);
1450         if (mg && mg->mg_len >= 0) {
1451             curpos = MgBYTEPOS(mg, TARG, truebase, len);
1452             /* last time pos() was set, it was zero-length match */
1453             if (mg->mg_flags & MGf_MINMATCH)
1454                 had_zerolen = 1;
1455         }
1456     }
1457
1458 #ifdef PERL_SAWAMPERSAND
1459     if (       RX_NPARENS(rx)
1460             || PL_sawampersand
1461             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1462             || (dynpm->op_pmflags & PMf_KEEPCOPY)
1463     )
1464 #endif
1465     {
1466         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1467         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1468          * only on the first iteration. Therefore we need to copy $' as well
1469          * as $&, to make the rest of the string available for captures in
1470          * subsequent iterations */
1471         if (! (global && gimme == G_ARRAY))
1472             r_flags |= REXEC_COPY_SKIP_POST;
1473     };
1474 #ifdef PERL_SAWAMPERSAND
1475     if (dynpm->op_pmflags & PMf_KEEPCOPY)
1476         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1477         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1478 #endif
1479
1480     s = truebase;
1481
1482   play_it_again:
1483     if (global)
1484         s = truebase + curpos;
1485
1486     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1487                      had_zerolen, TARG, NULL, r_flags))
1488         goto nope;
1489
1490     PL_curpm = pm;
1491     if (dynpm->op_pmflags & PMf_ONCE)
1492 #ifdef USE_ITHREADS
1493         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1494 #else
1495         dynpm->op_pmflags |= PMf_USED;
1496 #endif
1497
1498     if (rxtainted)
1499         RX_MATCH_TAINTED_on(rx);
1500     TAINT_IF(RX_MATCH_TAINTED(rx));
1501
1502     /* update pos */
1503
1504     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1505         if (!mg)
1506             mg = sv_magicext_mglob(TARG);
1507         MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1508         if (RX_ZERO_LEN(rx))
1509             mg->mg_flags |= MGf_MINMATCH;
1510         else
1511             mg->mg_flags &= ~MGf_MINMATCH;
1512     }
1513
1514     if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1515         LEAVE_SCOPE(oldsave);
1516         RETPUSHYES;
1517     }
1518
1519     /* push captures on stack */
1520
1521     {
1522         const I32 nparens = RX_NPARENS(rx);
1523         I32 i = (global && !nparens) ? 1 : 0;
1524
1525         SPAGAIN;                        /* EVAL blocks could move the stack. */
1526         EXTEND(SP, nparens + i);
1527         EXTEND_MORTAL(nparens + i);
1528         for (i = !i; i <= nparens; i++) {
1529             PUSHs(sv_newmortal());
1530             if (LIKELY((RX_OFFS(rx)[i].start != -1)
1531                      && RX_OFFS(rx)[i].end   != -1 ))
1532             {
1533                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1534                 const char * const s = RX_OFFS(rx)[i].start + truebase;
1535                 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1536                         || len < 0 || len > strend - s))
1537                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1538                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1539                         (long) i, (long) RX_OFFS(rx)[i].start,
1540                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1541                 sv_setpvn(*SP, s, len);
1542                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1543                     SvUTF8_on(*SP);
1544             }
1545         }
1546         if (global) {
1547             curpos = (UV)RX_OFFS(rx)[0].end;
1548             had_zerolen = RX_ZERO_LEN(rx);
1549             PUTBACK;                    /* EVAL blocks may use stack */
1550             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1551             goto play_it_again;
1552         }
1553         LEAVE_SCOPE(oldsave);
1554         RETURN;
1555     }
1556     /* NOTREACHED */
1557
1558 nope:
1559     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1560         if (!mg)
1561             mg = mg_find_mglob(TARG);
1562         if (mg)
1563             mg->mg_len = -1;
1564     }
1565     LEAVE_SCOPE(oldsave);
1566     if (gimme == G_ARRAY)
1567         RETURN;
1568     RETPUSHNO;
1569 }
1570
1571 OP *
1572 Perl_do_readline(pTHX)
1573 {
1574     dSP; dTARGETSTACKED;
1575     SV *sv;
1576     STRLEN tmplen = 0;
1577     STRLEN offset;
1578     PerlIO *fp;
1579     IO * const io = GvIO(PL_last_in_gv);
1580     const I32 type = PL_op->op_type;
1581     const I32 gimme = GIMME_V;
1582
1583     if (io) {
1584         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1585         if (mg) {
1586             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1587             if (gimme == G_SCALAR) {
1588                 SPAGAIN;
1589                 SvSetSV_nosteal(TARG, TOPs);
1590                 SETTARG;
1591             }
1592             return NORMAL;
1593         }
1594     }
1595     fp = NULL;
1596     if (io) {
1597         fp = IoIFP(io);
1598         if (!fp) {
1599             if (IoFLAGS(io) & IOf_ARGV) {
1600                 if (IoFLAGS(io) & IOf_START) {
1601                     IoLINES(io) = 0;
1602                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1603                         IoFLAGS(io) &= ~IOf_START;
1604                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1605                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1606                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1607                         SvSETMAGIC(GvSV(PL_last_in_gv));
1608                         fp = IoIFP(io);
1609                         goto have_fp;
1610                     }
1611                 }
1612                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1613                 if (!fp) { /* Note: fp != IoIFP(io) */
1614                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1615                 }
1616             }
1617             else if (type == OP_GLOB)
1618                 fp = Perl_start_glob(aTHX_ POPs, io);
1619         }
1620         else if (type == OP_GLOB)
1621             SP--;
1622         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1623             report_wrongway_fh(PL_last_in_gv, '>');
1624         }
1625     }
1626     if (!fp) {
1627         if ((!io || !(IoFLAGS(io) & IOf_START))
1628             && ckWARN(WARN_CLOSED)
1629             && type != OP_GLOB)
1630         {
1631             report_evil_fh(PL_last_in_gv);
1632         }
1633         if (gimme == G_SCALAR) {
1634             /* undef TARG, and push that undefined value */
1635             if (type != OP_RCATLINE) {
1636                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1637                 SvOK_off(TARG);
1638             }
1639             PUSHTARG;
1640         }
1641         RETURN;
1642     }
1643   have_fp:
1644     if (gimme == G_SCALAR) {
1645         sv = TARG;
1646         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1647             mg_get(sv);
1648         if (SvROK(sv)) {
1649             if (type == OP_RCATLINE)
1650                 SvPV_force_nomg_nolen(sv);
1651             else
1652                 sv_unref(sv);
1653         }
1654         else if (isGV_with_GP(sv)) {
1655             SvPV_force_nomg_nolen(sv);
1656         }
1657         SvUPGRADE(sv, SVt_PV);
1658         tmplen = SvLEN(sv);     /* remember if already alloced */
1659         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1660             /* try short-buffering it. Please update t/op/readline.t
1661              * if you change the growth length.
1662              */
1663             Sv_Grow(sv, 80);
1664         }
1665         offset = 0;
1666         if (type == OP_RCATLINE && SvOK(sv)) {
1667             if (!SvPOK(sv)) {
1668                 SvPV_force_nomg_nolen(sv);
1669             }
1670             offset = SvCUR(sv);
1671         }
1672     }
1673     else {
1674         sv = sv_2mortal(newSV(80));
1675         offset = 0;
1676     }
1677
1678     /* This should not be marked tainted if the fp is marked clean */
1679 #define MAYBE_TAINT_LINE(io, sv) \
1680     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1681         TAINT;                          \
1682         SvTAINTED_on(sv);               \
1683     }
1684
1685 /* delay EOF state for a snarfed empty file */
1686 #define SNARF_EOF(gimme,rs,io,sv) \
1687     (gimme != G_SCALAR || SvCUR(sv)                                     \
1688      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1689
1690     for (;;) {
1691         PUTBACK;
1692         if (!sv_gets(sv, fp, offset)
1693             && (type == OP_GLOB
1694                 || SNARF_EOF(gimme, PL_rs, io, sv)
1695                 || PerlIO_error(fp)))
1696         {
1697             PerlIO_clearerr(fp);
1698             if (IoFLAGS(io) & IOf_ARGV) {
1699                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1700                 if (fp)
1701                     continue;
1702                 (void)do_close(PL_last_in_gv, FALSE);
1703             }
1704             else if (type == OP_GLOB) {
1705                 if (!do_close(PL_last_in_gv, FALSE)) {
1706                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1707                                    "glob failed (child exited with status %d%s)",
1708                                    (int)(STATUS_CURRENT >> 8),
1709                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1710                 }
1711             }
1712             if (gimme == G_SCALAR) {
1713                 if (type != OP_RCATLINE) {
1714                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1715                     SvOK_off(TARG);
1716                 }
1717                 SPAGAIN;
1718                 PUSHTARG;
1719             }
1720             MAYBE_TAINT_LINE(io, sv);
1721             RETURN;
1722         }
1723         MAYBE_TAINT_LINE(io, sv);
1724         IoLINES(io)++;
1725         IoFLAGS(io) |= IOf_NOLINE;
1726         SvSETMAGIC(sv);
1727         SPAGAIN;
1728         XPUSHs(sv);
1729         if (type == OP_GLOB) {
1730             const char *t1;
1731
1732             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1733                 char * const tmps = SvEND(sv) - 1;
1734                 if (*tmps == *SvPVX_const(PL_rs)) {
1735                     *tmps = '\0';
1736                     SvCUR_set(sv, SvCUR(sv) - 1);
1737                 }
1738             }
1739             for (t1 = SvPVX_const(sv); *t1; t1++)
1740 #ifdef __VMS
1741                 if (strchr("*%?", *t1))
1742 #else
1743                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1744 #endif
1745                         break;
1746             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1747                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1748                 continue;
1749             }
1750         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1751              if (ckWARN(WARN_UTF8)) {
1752                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1753                 const STRLEN len = SvCUR(sv) - offset;
1754                 const U8 *f;
1755
1756                 if (!is_utf8_string_loc(s, len, &f))
1757                     /* Emulate :encoding(utf8) warning in the same case. */
1758                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1759                                 "utf8 \"\\x%02X\" does not map to Unicode",
1760                                 f < (U8*)SvEND(sv) ? *f : 0);
1761              }
1762         }
1763         if (gimme == G_ARRAY) {
1764             if (SvLEN(sv) - SvCUR(sv) > 20) {
1765                 SvPV_shrink_to_cur(sv);
1766             }
1767             sv = sv_2mortal(newSV(80));
1768             continue;
1769         }
1770         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1771             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1772             const STRLEN new_len
1773                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1774             SvPV_renew(sv, new_len);
1775         }
1776         RETURN;
1777     }
1778 }
1779
1780 PP(pp_helem)
1781 {
1782     dSP;
1783     HE* he;
1784     SV **svp;
1785     SV * const keysv = POPs;
1786     HV * const hv = MUTABLE_HV(POPs);
1787     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1788     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1789     SV *sv;
1790     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1791     bool preeminent = TRUE;
1792
1793     if (SvTYPE(hv) != SVt_PVHV)
1794         RETPUSHUNDEF;
1795
1796     if (localizing) {
1797         MAGIC *mg;
1798         HV *stash;
1799
1800         /* If we can determine whether the element exist,
1801          * Try to preserve the existenceness of a tied hash
1802          * element by using EXISTS and DELETE if possible.
1803          * Fallback to FETCH and STORE otherwise. */
1804         if (SvCANEXISTDELETE(hv))
1805             preeminent = hv_exists_ent(hv, keysv, 0);
1806     }
1807
1808     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1809     svp = he ? &HeVAL(he) : NULL;
1810     if (lval) {
1811         if (!svp || !*svp || *svp == &PL_sv_undef) {
1812             SV* lv;
1813             SV* key2;
1814             if (!defer) {
1815                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1816             }
1817             lv = sv_newmortal();
1818             sv_upgrade(lv, SVt_PVLV);
1819             LvTYPE(lv) = 'y';
1820             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1821             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
1822             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1823             LvTARGLEN(lv) = 1;
1824             PUSHs(lv);
1825             RETURN;
1826         }
1827         if (localizing) {
1828             if (HvNAME_get(hv) && isGV(*svp))
1829                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1830             else if (preeminent)
1831                 save_helem_flags(hv, keysv, svp,
1832                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1833             else
1834                 SAVEHDELETE(hv, keysv);
1835         }
1836         else if (PL_op->op_private & OPpDEREF) {
1837             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1838             RETURN;
1839         }
1840     }
1841     sv = (svp && *svp ? *svp : &PL_sv_undef);
1842     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1843      * was to make C<local $tied{foo} = $tied{foo}> possible.
1844      * However, it seems no longer to be needed for that purpose, and
1845      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1846      * would loop endlessly since the pos magic is getting set on the
1847      * mortal copy and lost. However, the copy has the effect of
1848      * triggering the get magic, and losing it altogether made things like
1849      * c<$tied{foo};> in void context no longer do get magic, which some
1850      * code relied on. Also, delayed triggering of magic on @+ and friends
1851      * meant the original regex may be out of scope by now. So as a
1852      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1853      * being called too many times). */
1854     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1855         mg_get(sv);
1856     PUSHs(sv);
1857     RETURN;
1858 }
1859
1860 PP(pp_iter)
1861 {
1862     dSP;
1863     PERL_CONTEXT *cx;
1864     SV *oldsv;
1865     SV **itersvp;
1866
1867     EXTEND(SP, 1);
1868     cx = &cxstack[cxstack_ix];
1869     itersvp = CxITERVAR(cx);
1870
1871     switch (CxTYPE(cx)) {
1872
1873     case CXt_LOOP_LAZYSV: /* string increment */
1874     {
1875         SV* cur = cx->blk_loop.state_u.lazysv.cur;
1876         SV *end = cx->blk_loop.state_u.lazysv.end;
1877         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1878            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1879         STRLEN maxlen = 0;
1880         const char *max = SvPV_const(end, maxlen);
1881         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
1882             RETPUSHNO;
1883
1884         oldsv = *itersvp;
1885         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1886             /* safe to reuse old SV */
1887             sv_setsv(oldsv, cur);
1888         }
1889         else
1890         {
1891             /* we need a fresh SV every time so that loop body sees a
1892              * completely new SV for closures/references to work as
1893              * they used to */
1894             *itersvp = newSVsv(cur);
1895             SvREFCNT_dec_NN(oldsv);
1896         }
1897         if (strEQ(SvPVX_const(cur), max))
1898             sv_setiv(cur, 0); /* terminate next time */
1899         else
1900             sv_inc(cur);
1901         break;
1902     }
1903
1904     case CXt_LOOP_LAZYIV: /* integer increment */
1905     {
1906         IV cur = cx->blk_loop.state_u.lazyiv.cur;
1907         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
1908             RETPUSHNO;
1909
1910         oldsv = *itersvp;
1911         /* don't risk potential race */
1912         if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1913             /* safe to reuse old SV */
1914             sv_setiv(oldsv, cur);
1915         }
1916         else
1917         {
1918             /* we need a fresh SV every time so that loop body sees a
1919              * completely new SV for closures/references to work as they
1920              * used to */
1921             *itersvp = newSViv(cur);
1922             SvREFCNT_dec_NN(oldsv);
1923         }
1924
1925         if (UNLIKELY(cur == IV_MAX)) {
1926             /* Handle end of range at IV_MAX */
1927             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1928         } else
1929             ++cx->blk_loop.state_u.lazyiv.cur;
1930         break;
1931     }
1932
1933     case CXt_LOOP_FOR: /* iterate array */
1934     {
1935
1936         AV *av = cx->blk_loop.state_u.ary.ary;
1937         SV *sv;
1938         bool av_is_stack = FALSE;
1939         IV ix;
1940
1941         if (!av) {
1942             av_is_stack = TRUE;
1943             av = PL_curstack;
1944         }
1945         if (PL_op->op_private & OPpITER_REVERSED) {
1946             ix = --cx->blk_loop.state_u.ary.ix;
1947             if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
1948                 RETPUSHNO;
1949         }
1950         else {
1951             ix = ++cx->blk_loop.state_u.ary.ix;
1952             if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
1953                 RETPUSHNO;
1954         }
1955
1956         if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
1957             SV * const * const svp = av_fetch(av, ix, FALSE);
1958             sv = svp ? *svp : NULL;
1959         }
1960         else {
1961             sv = AvARRAY(av)[ix];
1962         }
1963
1964         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
1965             SvSetMagicSV(*itersvp, sv);
1966             break;
1967         }
1968
1969         if (LIKELY(sv)) {
1970             if (UNLIKELY(SvIS_FREED(sv))) {
1971                 *itersvp = NULL;
1972                 Perl_croak(aTHX_ "Use of freed value in iteration");
1973             }
1974             if (SvPADTMP(sv)) {
1975                 sv = newSVsv(sv);
1976             }
1977             else {
1978                 SvTEMP_off(sv);
1979                 SvREFCNT_inc_simple_void_NN(sv);
1980             }
1981         }
1982         else if (!av_is_stack) {
1983             sv = newSVavdefelem(av, ix, 0);
1984         }
1985         else
1986             sv = &PL_sv_undef;
1987
1988         oldsv = *itersvp;
1989         *itersvp = sv;
1990         SvREFCNT_dec(oldsv);
1991         break;
1992     }
1993
1994     default:
1995         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1996     }
1997     RETPUSHYES;
1998 }
1999
2000 /*
2001 A description of how taint works in pattern matching and substitution.
2002
2003 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2004 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2005
2006 While the pattern is being assembled/concatenated and then compiled,
2007 PL_tainted will get set (via TAINT_set) if any component of the pattern
2008 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
2009 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2010 TAINT_get).  It will also be set if any component of the pattern matches
2011 based on locale-dependent behavior.
2012
2013 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2014 the pattern is marked as tainted. This means that subsequent usage, such
2015 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2016 on the new pattern too.
2017
2018 RXf_TAINTED_SEEN is used post-execution by the get magic code
2019 of $1 et al to indicate whether the returned value should be tainted.
2020 It is the responsibility of the caller of the pattern (i.e. pp_match,
2021 pp_subst etc) to set this flag for any other circumstances where $1 needs
2022 to be tainted.
2023
2024 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2025
2026 There are three possible sources of taint
2027     * the source string
2028     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2029     * the replacement string (or expression under /e)
2030
2031 There are four destinations of taint and they are affected by the sources
2032 according to the rules below:
2033
2034     * the return value (not including /r):
2035         tainted by the source string and pattern, but only for the
2036         number-of-iterations case; boolean returns aren't tainted;
2037     * the modified string (or modified copy under /r):
2038         tainted by the source string, pattern, and replacement strings;
2039     * $1 et al:
2040         tainted by the pattern, and under 'use re "taint"', by the source
2041         string too;
2042     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2043         should always be unset before executing subsequent code.
2044
2045 The overall action of pp_subst is:
2046
2047     * at the start, set bits in rxtainted indicating the taint status of
2048         the various sources.
2049
2050     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2051         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2052         pattern has subsequently become tainted via locale ops.
2053
2054     * If control is being passed to pp_substcont to execute a /e block,
2055         save rxtainted in the CXt_SUBST block, for future use by
2056         pp_substcont.
2057
2058     * Whenever control is being returned to perl code (either by falling
2059         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2060         use the flag bits in rxtainted to make all the appropriate types of
2061         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2062         et al will appear tainted.
2063
2064 pp_match is just a simpler version of the above.
2065
2066 */
2067
2068 PP(pp_subst)
2069 {
2070     dSP; dTARG;
2071     PMOP *pm = cPMOP;
2072     PMOP *rpm = pm;
2073     char *s;
2074     char *strend;
2075     const char *c;
2076     STRLEN clen;
2077     I32 iters = 0;
2078     I32 maxiters;
2079     bool once;
2080     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2081                         See "how taint works" above */
2082     char *orig;
2083     U8 r_flags;
2084     REGEXP *rx = PM_GETRE(pm);
2085     STRLEN len;
2086     int force_on_match = 0;
2087     const I32 oldsave = PL_savestack_ix;
2088     STRLEN slen;
2089     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2090 #ifdef PERL_ANY_COW
2091     bool is_cow;
2092 #endif
2093     SV *nsv = NULL;
2094     /* known replacement string? */
2095     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2096
2097     PERL_ASYNC_CHECK();
2098
2099     if (PL_op->op_flags & OPf_STACKED)
2100         TARG = POPs;
2101     else if (ARGTARG)
2102         GETTARGET;
2103     else {
2104         TARG = DEFSV;
2105         EXTEND(SP,1);
2106     }
2107
2108     SvGETMAGIC(TARG); /* must come before cow check */
2109 #ifdef PERL_ANY_COW
2110     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2111        because they make integers such as 256 "false".  */
2112     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2113 #else
2114     if (SvIsCOW(TARG))
2115         sv_force_normal_flags(TARG,0);
2116 #endif
2117     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2118         && (SvREADONLY(TARG)
2119             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2120                   || SvTYPE(TARG) > SVt_PVLV)
2121                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2122         Perl_croak_no_modify();
2123     PUTBACK;
2124
2125     orig = SvPV_nomg(TARG, len);
2126     /* note we don't (yet) force the var into being a string; if we fail
2127      * to match, we leave as-is; on successful match howeverm, we *will*
2128      * coerce into a string, then repeat the match */
2129     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2130         force_on_match = 1;
2131
2132     /* only replace once? */
2133     once = !(rpm->op_pmflags & PMf_GLOBAL);
2134
2135     /* See "how taint works" above */
2136     if (TAINTING_get) {
2137         rxtainted  = (
2138             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2139           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2140           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2141           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2142                 ? SUBST_TAINT_BOOLRET : 0));
2143         TAINT_NOT;
2144     }
2145
2146   force_it:
2147     if (!pm || !orig)
2148         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2149
2150     strend = orig + len;
2151     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2152     maxiters = 2 * slen + 10;   /* We can match twice at each
2153                                    position, once with zero-length,
2154                                    second time with non-zero. */
2155
2156     if (!RX_PRELEN(rx) && PL_curpm
2157      && !ReANY(rx)->mother_re) {
2158         pm = PL_curpm;
2159         rx = PM_GETRE(pm);
2160     }
2161
2162 #ifdef PERL_SAWAMPERSAND
2163     r_flags = (    RX_NPARENS(rx)
2164                 || PL_sawampersand
2165                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2166                 || (rpm->op_pmflags & PMf_KEEPCOPY)
2167               )
2168           ? REXEC_COPY_STR
2169           : 0;
2170 #else
2171     r_flags = REXEC_COPY_STR;
2172 #endif
2173
2174     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2175     {
2176         SPAGAIN;
2177         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2178         LEAVE_SCOPE(oldsave);
2179         RETURN;
2180     }
2181     PL_curpm = pm;
2182
2183     /* known replacement string? */
2184     if (dstr) {
2185         /* replacement needing upgrading? */
2186         if (DO_UTF8(TARG) && !doutf8) {
2187              nsv = sv_newmortal();
2188              SvSetSV(nsv, dstr);
2189              if (PL_encoding)
2190                   sv_recode_to_utf8(nsv, PL_encoding);
2191              else
2192                   sv_utf8_upgrade(nsv);
2193              c = SvPV_const(nsv, clen);
2194              doutf8 = TRUE;
2195         }
2196         else {
2197             c = SvPV_const(dstr, clen);
2198             doutf8 = DO_UTF8(dstr);
2199         }
2200
2201         if (SvTAINTED(dstr))
2202             rxtainted |= SUBST_TAINT_REPL;
2203     }
2204     else {
2205         c = NULL;
2206         doutf8 = FALSE;
2207     }
2208
2209     /* can do inplace substitution? */
2210     if (c
2211 #ifdef PERL_ANY_COW
2212         && !is_cow
2213 #endif
2214         && (I32)clen <= RX_MINLENRET(rx)
2215         && (  once
2216            || !(r_flags & REXEC_COPY_STR)
2217            || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2218            )
2219         && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2220         && (!doutf8 || SvUTF8(TARG))
2221         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2222     {
2223
2224 #ifdef PERL_ANY_COW
2225         if (SvIsCOW(TARG)) {
2226           if (!force_on_match)
2227             goto have_a_cow;
2228           assert(SvVOK(TARG));
2229         }
2230 #endif
2231         if (force_on_match) {
2232             /* redo the first match, this time with the orig var
2233              * forced into being a string */
2234             force_on_match = 0;
2235             orig = SvPV_force_nomg(TARG, len);
2236             goto force_it;
2237         }
2238
2239         if (once) {
2240             char *d, *m;
2241             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2242                 rxtainted |= SUBST_TAINT_PAT;
2243             m = orig + RX_OFFS(rx)[0].start;
2244             d = orig + RX_OFFS(rx)[0].end;
2245             s = orig;
2246             if (m - s > strend - d) {  /* faster to shorten from end */
2247                 I32 i;
2248                 if (clen) {
2249                     Copy(c, m, clen, char);
2250                     m += clen;
2251                 }
2252                 i = strend - d;
2253                 if (i > 0) {
2254                     Move(d, m, i, char);
2255                     m += i;
2256                 }
2257                 *m = '\0';
2258                 SvCUR_set(TARG, m - s);
2259             }
2260             else {      /* faster from front */
2261                 I32 i = m - s;
2262                 d -= clen;
2263                 if (i > 0)
2264                     Move(s, d - i, i, char);
2265                 sv_chop(TARG, d-i);
2266                 if (clen)
2267                     Copy(c, d, clen, char);
2268             }
2269             SPAGAIN;
2270             PUSHs(&PL_sv_yes);
2271         }
2272         else {
2273             char *d, *m;
2274             d = s = RX_OFFS(rx)[0].start + orig;
2275             do {
2276                 I32 i;
2277                 if (UNLIKELY(iters++ > maxiters))
2278                     DIE(aTHX_ "Substitution loop");
2279                 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2280                     rxtainted |= SUBST_TAINT_PAT;
2281                 m = RX_OFFS(rx)[0].start + orig;
2282                 if ((i = m - s)) {
2283                     if (s != d)
2284                         Move(s, d, i, char);
2285                     d += i;
2286                 }
2287                 if (clen) {
2288                     Copy(c, d, clen, char);
2289                     d += clen;
2290                 }
2291                 s = RX_OFFS(rx)[0].end + orig;
2292             } while (CALLREGEXEC(rx, s, strend, orig,
2293                                  s == m, /* don't match same null twice */
2294                                  TARG, NULL,
2295                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2296             if (s != d) {
2297                 I32 i = strend - s;
2298                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2299                 Move(s, d, i+1, char);          /* include the NUL */
2300             }
2301             SPAGAIN;
2302             mPUSHi((I32)iters);
2303         }
2304     }
2305     else {
2306         bool first;
2307         char *m;
2308         SV *repl;
2309         if (force_on_match) {
2310             /* redo the first match, this time with the orig var
2311              * forced into being a string */
2312             force_on_match = 0;
2313             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2314                 /* I feel that it should be possible to avoid this mortal copy
2315                    given that the code below copies into a new destination.
2316                    However, I suspect it isn't worth the complexity of
2317                    unravelling the C<goto force_it> for the small number of
2318                    cases where it would be viable to drop into the copy code. */
2319                 TARG = sv_2mortal(newSVsv(TARG));
2320             }
2321             orig = SvPV_force_nomg(TARG, len);
2322             goto force_it;
2323         }
2324 #ifdef PERL_ANY_COW
2325       have_a_cow:
2326 #endif
2327         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2328             rxtainted |= SUBST_TAINT_PAT;
2329         repl = dstr;
2330         s = RX_OFFS(rx)[0].start + orig;
2331         dstr = newSVpvn_flags(orig, s-orig,
2332                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2333         if (!c) {
2334             PERL_CONTEXT *cx;
2335             SPAGAIN;
2336             m = orig;
2337             /* note that a whole bunch of local vars are saved here for
2338              * use by pp_substcont: here's a list of them in case you're
2339              * searching for places in this sub that uses a particular var:
2340              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2341              * s m strend rx once */
2342             PUSHSUBST(cx);
2343             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2344         }
2345         first = TRUE;
2346         do {
2347             if (UNLIKELY(iters++ > maxiters))
2348                 DIE(aTHX_ "Substitution loop");
2349             if (UNLIKELY(RX_MATCH_TAINTED(rx)))
2350                 rxtainted |= SUBST_TAINT_PAT;
2351             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2352                 char *old_s    = s;
2353                 char *old_orig = orig;
2354                 assert(RX_SUBOFFSET(rx) == 0);
2355
2356                 orig = RX_SUBBEG(rx);
2357                 s = orig + (old_s - old_orig);
2358                 strend = s + (strend - old_s);
2359             }
2360             m = RX_OFFS(rx)[0].start + orig;
2361             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2362             s = RX_OFFS(rx)[0].end + orig;
2363             if (first) {
2364                 /* replacement already stringified */
2365               if (clen)
2366                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2367               first = FALSE;
2368             }
2369             else {
2370                 if (PL_encoding) {
2371                     if (!nsv) nsv = sv_newmortal();
2372                     sv_copypv(nsv, repl);
2373                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2374                     sv_catsv(dstr, nsv);
2375                 }
2376                 else sv_catsv(dstr, repl);
2377                 if (UNLIKELY(SvTAINTED(repl)))
2378                     rxtainted |= SUBST_TAINT_REPL;
2379             }
2380             if (once)
2381                 break;
2382         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2383                              TARG, NULL,
2384                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2385         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2386
2387         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2388             /* From here on down we're using the copy, and leaving the original
2389                untouched.  */
2390             TARG = dstr;
2391             SPAGAIN;
2392             PUSHs(dstr);
2393         } else {
2394 #ifdef PERL_ANY_COW
2395             /* The match may make the string COW. If so, brilliant, because
2396                that's just saved us one malloc, copy and free - the regexp has
2397                donated the old buffer, and we malloc an entirely new one, rather
2398                than the regexp malloc()ing a buffer and copying our original,
2399                only for us to throw it away here during the substitution.  */
2400             if (SvIsCOW(TARG)) {
2401                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2402             } else
2403 #endif
2404             {
2405                 SvPV_free(TARG);
2406             }
2407             SvPV_set(TARG, SvPVX(dstr));
2408             SvCUR_set(TARG, SvCUR(dstr));
2409             SvLEN_set(TARG, SvLEN(dstr));
2410             SvFLAGS(TARG) |= SvUTF8(dstr);
2411             SvPV_set(dstr, NULL);
2412
2413             SPAGAIN;
2414             mPUSHi((I32)iters);
2415         }
2416     }
2417
2418     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2419         (void)SvPOK_only_UTF8(TARG);
2420     }
2421
2422     /* See "how taint works" above */
2423     if (TAINTING_get) {
2424         if ((rxtainted & SUBST_TAINT_PAT) ||
2425             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2426                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2427         )
2428             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2429
2430         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2431             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2432         )
2433             SvTAINTED_on(TOPs);  /* taint return value */
2434         else
2435             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2436
2437         /* needed for mg_set below */
2438         TAINT_set(
2439           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2440         );
2441         SvTAINT(TARG);
2442     }
2443     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2444     TAINT_NOT;
2445     LEAVE_SCOPE(oldsave);
2446     RETURN;
2447 }
2448
2449 PP(pp_grepwhile)
2450 {
2451     dSP;
2452
2453     if (SvTRUEx(POPs))
2454         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2455     ++*PL_markstack_ptr;
2456     FREETMPS;
2457     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2458
2459     /* All done yet? */
2460     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
2461         I32 items;
2462         const I32 gimme = GIMME_V;
2463
2464         LEAVE_with_name("grep");                                        /* exit outer scope */
2465         (void)POPMARK;                          /* pop src */
2466         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2467         (void)POPMARK;                          /* pop dst */
2468         SP = PL_stack_base + POPMARK;           /* pop original mark */
2469         if (gimme == G_SCALAR) {
2470             if (PL_op->op_private & OPpGREP_LEX) {
2471                 SV* const sv = sv_newmortal();
2472                 sv_setiv(sv, items);
2473                 PUSHs(sv);
2474             }
2475             else {
2476                 dTARGET;
2477                 XPUSHi(items);
2478             }
2479         }
2480         else if (gimme == G_ARRAY)
2481             SP += items;
2482         RETURN;
2483     }
2484     else {
2485         SV *src;
2486
2487         ENTER_with_name("grep_item");                                   /* enter inner scope */
2488         SAVEVPTR(PL_curpm);
2489
2490         src = PL_stack_base[*PL_markstack_ptr];
2491         if (SvPADTMP(src)) {
2492             src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2493             PL_tmps_floor++;
2494         }
2495         SvTEMP_off(src);
2496         if (PL_op->op_private & OPpGREP_LEX)
2497             PAD_SVl(PL_op->op_targ) = src;
2498         else
2499             DEFSV_set(src);
2500
2501         RETURNOP(cLOGOP->op_other);
2502     }
2503 }
2504
2505 PP(pp_leavesub)
2506 {
2507     dSP;
2508     SV **mark;
2509     SV **newsp;
2510     PMOP *newpm;
2511     I32 gimme;
2512     PERL_CONTEXT *cx;
2513     SV *sv;
2514
2515     if (CxMULTICALL(&cxstack[cxstack_ix]))
2516         return 0;
2517
2518     POPBLOCK(cx,newpm);
2519     cxstack_ix++; /* temporarily protect top context */
2520
2521     TAINT_NOT;
2522     if (gimme == G_SCALAR) {
2523         MARK = newsp + 1;
2524         if (LIKELY(MARK <= SP)) {
2525             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2526                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2527                      && !SvMAGICAL(TOPs)) {
2528                     *MARK = SvREFCNT_inc(TOPs);
2529                     FREETMPS;
2530                     sv_2mortal(*MARK);
2531                 }
2532                 else {
2533                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2534                     FREETMPS;
2535                     *MARK = sv_mortalcopy(sv);
2536                     SvREFCNT_dec_NN(sv);
2537                 }
2538             }
2539             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2540                      && !SvMAGICAL(TOPs)) {
2541                 *MARK = TOPs;
2542             }
2543             else
2544                 *MARK = sv_mortalcopy(TOPs);
2545         }
2546         else {
2547             MEXTEND(MARK, 0);
2548             *MARK = &PL_sv_undef;
2549         }
2550         SP = MARK;
2551     }
2552     else if (gimme == G_ARRAY) {
2553         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2554             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2555                  || SvMAGICAL(*MARK)) {
2556                 *MARK = sv_mortalcopy(*MARK);
2557                 TAINT_NOT;      /* Each item is independent */
2558             }
2559         }
2560     }
2561     PUTBACK;
2562
2563     LEAVE;
2564     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2565     cxstack_ix--;
2566     PL_curpm = newpm;   /* ... and pop $1 et al */
2567
2568     LEAVESUB(sv);
2569     return cx->blk_sub.retop;
2570 }
2571
2572 PP(pp_entersub)
2573 {
2574     dSP; dPOPss;
2575     GV *gv;
2576     CV *cv;
2577     PERL_CONTEXT *cx;
2578     I32 gimme;
2579     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2580
2581     if (UNLIKELY(!sv))
2582         DIE(aTHX_ "Not a CODE reference");
2583     /* This is overwhelmingly the most common case:  */
2584     if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
2585         switch (SvTYPE(sv)) {
2586         case SVt_PVGV:
2587           we_have_a_glob:
2588             if (!(cv = GvCVu((const GV *)sv))) {
2589                 HV *stash;
2590                 cv = sv_2cv(sv, &stash, &gv, 0);
2591             }
2592             if (!cv) {
2593                 ENTER;
2594                 SAVETMPS;
2595                 goto try_autoload;
2596             }
2597             break;
2598         case SVt_PVLV:
2599             if(isGV_with_GP(sv)) goto we_have_a_glob;
2600             /* FALLTHROUGH */
2601         default:
2602             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2603                 if (hasargs)
2604                     SP = PL_stack_base + POPMARK;
2605                 else
2606                     (void)POPMARK;
2607                 RETURN;
2608             }
2609             SvGETMAGIC(sv);
2610             if (SvROK(sv)) {
2611                 if (SvAMAGIC(sv)) {
2612                     sv = amagic_deref_call(sv, to_cv_amg);
2613                     /* Don't SPAGAIN here.  */
2614                 }
2615             }
2616             else {
2617                 const char *sym;
2618                 STRLEN len;
2619                 if (!SvOK(sv))
2620                     DIE(aTHX_ PL_no_usym, "a subroutine");
2621                 sym = SvPV_nomg_const(sv, len);
2622                 if (PL_op->op_private & HINT_STRICT_REFS)
2623                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2624                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2625                 break;
2626             }
2627             cv = MUTABLE_CV(SvRV(sv));
2628             if (SvTYPE(cv) == SVt_PVCV)
2629                 break;
2630             /* FALLTHROUGH */
2631         case SVt_PVHV:
2632         case SVt_PVAV:
2633             DIE(aTHX_ "Not a CODE reference");
2634             /* This is the second most common case:  */
2635         case SVt_PVCV:
2636             cv = MUTABLE_CV(sv);
2637             break;
2638         }
2639     }
2640
2641     ENTER;
2642
2643   retry:
2644     if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
2645         DIE(aTHX_ "Closure prototype called");
2646     if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2647         GV* autogv;
2648         SV* sub_name;
2649
2650         /* anonymous or undef'd function leaves us no recourse */
2651         if (CvLEXICAL(cv) && CvHASGV(cv))
2652             DIE(aTHX_ "Undefined subroutine &%"SVf" called",
2653                        SVfARG(cv_name(cv, NULL, 0)));
2654         if (CvANON(cv) || !CvHASGV(cv)) {
2655             DIE(aTHX_ "Undefined subroutine called");
2656         }
2657
2658         /* autoloaded stub? */
2659         if (cv != GvCV(gv = CvGV(cv))) {
2660             cv = GvCV(gv);
2661         }
2662         /* should call AUTOLOAD now? */
2663         else {
2664 try_autoload:
2665             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2666                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2667             {
2668                 cv = GvCV(autogv);
2669             }
2670             else {
2671                sorry:
2672                 sub_name = sv_newmortal();
2673                 gv_efullname3(sub_name, gv, NULL);
2674                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2675             }
2676         }
2677         if (!cv)
2678             goto sorry;
2679         goto retry;
2680     }
2681
2682     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
2683             && !CvNODEBUG(cv)))
2684     {
2685          Perl_get_db_sub(aTHX_ &sv, cv);
2686          if (CvISXSUB(cv))
2687              PL_curcopdb = PL_curcop;
2688          if (CvLVALUE(cv)) {
2689              /* check for lsub that handles lvalue subroutines */
2690              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
2691              /* if lsub not found then fall back to DB::sub */
2692              if (!cv) cv = GvCV(PL_DBsub);
2693          } else {
2694              cv = GvCV(PL_DBsub);
2695          }
2696
2697         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2698             DIE(aTHX_ "No DB::sub routine defined");
2699     }
2700
2701     gimme = GIMME_V;
2702
2703     if (!(CvISXSUB(cv))) {
2704         /* This path taken at least 75% of the time   */
2705         dMARK;
2706         PADLIST * const padlist = CvPADLIST(cv);
2707         I32 depth;
2708
2709         PUSHBLOCK(cx, CXt_SUB, MARK);
2710         PUSHSUB(cx);
2711         cx->blk_sub.retop = PL_op->op_next;
2712         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
2713             PERL_STACK_OVERFLOW_CHECK();
2714             pad_push(padlist, depth);
2715         }
2716         SAVECOMPPAD();
2717         PAD_SET_CUR_NOSAVE(padlist, depth);
2718         if (LIKELY(hasargs)) {
2719             AV *const av = MUTABLE_AV(PAD_SVl(0));
2720             SSize_t items;
2721             AV **defavp;
2722
2723             if (UNLIKELY(AvREAL(av))) {
2724                 /* @_ is normally not REAL--this should only ever
2725                  * happen when DB::sub() calls things that modify @_ */
2726                 av_clear(av);
2727                 AvREAL_off(av);
2728                 AvREIFY_on(av);
2729             }
2730             defavp = &GvAV(PL_defgv);
2731             cx->blk_sub.savearray = *defavp;
2732             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
2733             CX_CURPAD_SAVE(cx->blk_sub);
2734             cx->blk_sub.argarray = av;
2735             items = SP - MARK;
2736
2737             if (UNLIKELY(items - 1 > AvMAX(av))) {
2738                 SV **ary = AvALLOC(av);
2739                 AvMAX(av) = items - 1;
2740                 Renew(ary, items, SV*);
2741                 AvALLOC(av) = ary;
2742                 AvARRAY(av) = ary;
2743             }
2744
2745             Copy(MARK+1,AvARRAY(av),items,SV*);
2746             AvFILLp(av) = items - 1;
2747
2748             MARK = AvARRAY(av);
2749             while (items--) {
2750                 if (*MARK)
2751                 {
2752                     if (SvPADTMP(*MARK)) {
2753                         *MARK = sv_mortalcopy(*MARK);
2754                     }
2755                     SvTEMP_off(*MARK);
2756                 }
2757                 MARK++;
2758             }
2759         }
2760         SAVETMPS;
2761         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2762             !CvLVALUE(cv)))
2763             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2764         /* warning must come *after* we fully set up the context
2765          * stuff so that __WARN__ handlers can safely dounwind()
2766          * if they want to
2767          */
2768         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
2769                 && ckWARN(WARN_RECURSION)
2770                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
2771             sub_crush_depth(cv);
2772         RETURNOP(CvSTART(cv));
2773     }
2774     else {
2775         SSize_t markix = TOPMARK;
2776
2777         SAVETMPS;
2778         PUTBACK;
2779
2780         if (UNLIKELY(((PL_op->op_private
2781                & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2782              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2783             !CvLVALUE(cv)))
2784             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2785
2786         if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
2787             /* Need to copy @_ to stack. Alternative may be to
2788              * switch stack to @_, and copy return values
2789              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2790             AV * const av = GvAV(PL_defgv);
2791             const SSize_t items = AvFILL(av) + 1;
2792
2793             if (items) {
2794                 SSize_t i = 0;
2795                 const bool m = cBOOL(SvRMAGICAL(av));
2796                 /* Mark is at the end of the stack. */
2797                 EXTEND(SP, items);
2798                 for (; i < items; ++i)
2799                 {
2800                     SV *sv;
2801                     if (m) {
2802                         SV ** const svp = av_fetch(av, i, 0);
2803                         sv = svp ? *svp : NULL;
2804                     }
2805                     else sv = AvARRAY(av)[i];
2806                     if (sv) SP[i+1] = sv;
2807                     else {
2808                         SP[i+1] = newSVavdefelem(av, i, 1);
2809                     }
2810                 }
2811                 SP += items;
2812                 PUTBACK ;
2813             }
2814         }
2815         else {
2816             SV **mark = PL_stack_base + markix;
2817             SSize_t items = SP - mark;
2818             while (items--) {
2819                 mark++;
2820                 if (*mark && SvPADTMP(*mark)) {
2821                     *mark = sv_mortalcopy(*mark);
2822                 }
2823             }
2824         }
2825         /* We assume first XSUB in &DB::sub is the called one. */
2826         if (UNLIKELY(PL_curcopdb)) {
2827             SAVEVPTR(PL_curcop);
2828             PL_curcop = PL_curcopdb;
2829             PL_curcopdb = NULL;
2830         }
2831         /* Do we need to open block here? XXXX */
2832
2833         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2834         assert(CvXSUB(cv));
2835         CvXSUB(cv)(aTHX_ cv);
2836
2837         /* Enforce some sanity in scalar context. */
2838         if (gimme == G_SCALAR) {
2839             SV **svp = PL_stack_base + markix + 1;
2840             if (svp != PL_stack_sp) {
2841                 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
2842                 PL_stack_sp = svp;
2843             }
2844         }
2845         LEAVE;
2846         return NORMAL;
2847     }
2848 }
2849
2850 void
2851 Perl_sub_crush_depth(pTHX_ CV *cv)
2852 {
2853     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2854
2855     if (CvANON(cv))
2856         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2857     else {
2858         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2859                     SVfARG(cv_name(cv,NULL,0)));
2860     }
2861 }
2862
2863 PP(pp_aelem)
2864 {
2865     dSP;
2866     SV** svp;
2867     SV* const elemsv = POPs;
2868     IV elem = SvIV(elemsv);
2869     AV *const av = MUTABLE_AV(POPs);
2870     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2871     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2872     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2873     bool preeminent = TRUE;
2874     SV *sv;
2875
2876     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
2877         Perl_warner(aTHX_ packWARN(WARN_MISC),
2878                     "Use of reference \"%"SVf"\" as array index",
2879                     SVfARG(elemsv));
2880     if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
2881         RETPUSHUNDEF;
2882
2883     if (UNLIKELY(localizing)) {
2884         MAGIC *mg;
2885         HV *stash;
2886
2887         /* If we can determine whether the element exist,
2888          * Try to preserve the existenceness of a tied array
2889          * element by using EXISTS and DELETE if possible.
2890          * Fallback to FETCH and STORE otherwise. */
2891         if (SvCANEXISTDELETE(av))
2892             preeminent = av_exists(av, elem);
2893     }
2894
2895     svp = av_fetch(av, elem, lval && !defer);
2896     if (lval) {
2897 #ifdef PERL_MALLOC_WRAP
2898          if (SvUOK(elemsv)) {
2899               const UV uv = SvUV(elemsv);
2900               elem = uv > IV_MAX ? IV_MAX : uv;
2901          }
2902          else if (SvNOK(elemsv))
2903               elem = (IV)SvNV(elemsv);
2904          if (elem > 0) {
2905               static const char oom_array_extend[] =
2906                 "Out of memory during array extend"; /* Duplicated in av.c */
2907               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2908          }
2909 #endif
2910         if (!svp || !*svp) {
2911             IV len;
2912             if (!defer)
2913                 DIE(aTHX_ PL_no_aelem, elem);
2914             len = av_tindex(av);
2915             mPUSHs(newSVavdefelem(av,
2916             /* Resolve a negative index now, unless it points before the
2917                beginning of the array, in which case record it for error
2918                reporting in magic_setdefelem. */
2919                 elem < 0 && len + elem >= 0 ? len + elem : elem,
2920                 1));
2921             RETURN;
2922         }
2923         if (UNLIKELY(localizing)) {
2924             if (preeminent)
2925                 save_aelem(av, elem, svp);
2926             else
2927                 SAVEADELETE(av, elem);
2928         }
2929         else if (PL_op->op_private & OPpDEREF) {
2930             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2931             RETURN;
2932         }
2933     }
2934     sv = (svp ? *svp : &PL_sv_undef);
2935     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2936         mg_get(sv);
2937     PUSHs(sv);
2938     RETURN;
2939 }
2940
2941 SV*
2942 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2943 {
2944     PERL_ARGS_ASSERT_VIVIFY_REF;
2945
2946     SvGETMAGIC(sv);
2947     if (!SvOK(sv)) {
2948         if (SvREADONLY(sv))
2949             Perl_croak_no_modify();
2950         prepare_SV_for_RV(sv);
2951         switch (to_what) {
2952         case OPpDEREF_SV:
2953             SvRV_set(sv, newSV(0));
2954             break;
2955         case OPpDEREF_AV:
2956             SvRV_set(sv, MUTABLE_SV(newAV()));
2957             break;
2958         case OPpDEREF_HV:
2959             SvRV_set(sv, MUTABLE_SV(newHV()));
2960             break;
2961         }
2962         SvROK_on(sv);
2963         SvSETMAGIC(sv);
2964         SvGETMAGIC(sv);
2965     }
2966     if (SvGMAGICAL(sv)) {
2967         /* copy the sv without magic to prevent magic from being
2968            executed twice */
2969         SV* msv = sv_newmortal();
2970         sv_setsv_nomg(msv, sv);
2971         return msv;
2972     }
2973     return sv;
2974 }
2975
2976 PP(pp_method)
2977 {
2978     dSP;
2979     SV* const sv = TOPs;
2980
2981     if (SvROK(sv)) {
2982         SV* const rsv = SvRV(sv);
2983         if (SvTYPE(rsv) == SVt_PVCV) {
2984             SETs(rsv);
2985             RETURN;
2986         }
2987     }
2988
2989     SETs(method_common(sv, NULL));
2990     RETURN;
2991 }
2992
2993 PP(pp_method_named)
2994 {
2995     dSP;
2996     SV* const meth = cMETHOPx_meth(PL_op);
2997     U32 hash = SvSHARED_HASH(meth);
2998
2999     XPUSHs(method_common(meth, &hash));
3000     RETURN;
3001 }
3002
3003 STATIC SV *
3004 S_method_common(pTHX_ SV* meth, U32* hashp)
3005 {
3006     SV* ob;
3007     GV* gv;
3008     HV* stash;
3009     SV *packsv = NULL;
3010     SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
3011         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3012                             "package or object reference", SVfARG(meth)),
3013            (SV *)NULL)
3014         : *(PL_stack_base + TOPMARK + 1);
3015
3016     PERL_ARGS_ASSERT_METHOD_COMMON;
3017
3018     if (UNLIKELY(!sv))
3019        undefined:
3020         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3021                    SVfARG(meth));
3022
3023     SvGETMAGIC(sv);
3024     if (SvROK(sv))
3025         ob = MUTABLE_SV(SvRV(sv));
3026     else if (!SvOK(sv)) goto undefined;
3027     else if (isGV_with_GP(sv)) {
3028         if (!GvIO(sv))
3029             Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3030                              "without a package or object reference",
3031                               SVfARG(meth));
3032         ob = sv;
3033         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3034             assert(!LvTARGLEN(ob));
3035             ob = LvTARG(ob);
3036             assert(ob);
3037         }
3038         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3039     }
3040     else {
3041         /* this isn't a reference */
3042         GV* iogv;
3043         STRLEN packlen;
3044         const char * const packname = SvPV_nomg_const(sv, packlen);
3045         const U32 packname_utf8 = SvUTF8(sv);
3046         stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3047         if (stash) goto fetch;
3048
3049         if (!(iogv = gv_fetchpvn_flags(
3050                 packname, packlen, packname_utf8, SVt_PVIO
3051              )) ||
3052             !(ob=MUTABLE_SV(GvIO(iogv))))
3053         {
3054             /* this isn't the name of a filehandle either */
3055             if (!packlen)
3056             {
3057                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3058                                  "without a package or object reference",
3059                                   SVfARG(meth));
3060             }
3061             /* assume it's a package name */
3062             stash = gv_stashpvn(packname, packlen, packname_utf8);
3063             if (!stash) packsv = sv;
3064             goto fetch;
3065         }
3066         /* it _is_ a filehandle name -- replace with a reference */
3067         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3068     }
3069
3070     /* if we got here, ob should be an object or a glob */
3071     if (!ob || !(SvOBJECT(ob)
3072                  || (isGV_with_GP(ob)
3073                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3074                      && SvOBJECT(ob))))
3075     {
3076         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3077                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3078                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3079                                         : meth));
3080     }
3081
3082     stash = SvSTASH(ob);
3083
3084   fetch:
3085     /* NOTE: stash may be null, hope hv_fetch_ent and
3086        gv_fetchmethod can cope (it seems they can) */
3087
3088     /* shortcut for simple names */
3089     if (hashp) {
3090         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3091         if (he) {
3092             gv = MUTABLE_GV(HeVAL(he));
3093             assert(stash);
3094             if (isGV(gv) && GvCV(gv) &&
3095                 (!GvCVGEN(gv) || GvCVGEN(gv)
3096                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3097                 return MUTABLE_SV(GvCV(gv));
3098         }
3099     }
3100
3101     assert(stash || packsv);
3102     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3103                                  meth, GV_AUTOLOAD | GV_CROAK);
3104     assert(gv);
3105
3106     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3107 }
3108
3109 /*
3110  * Local variables:
3111  * c-indentation-style: bsd
3112  * c-basic-offset: 4
3113  * indent-tabs-mode: nil
3114  * End:
3115  *
3116  * ex: set ts=8 sts=4 sw=4 et:
3117  */