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