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