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