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