pp_hot.c

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