pp_hot.c

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