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