pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  13  * shaking the air.
  14  *
  15  *                  Awake!  Awake!  Fear, Fire, Foes!  Awake!
  16  *                               Fire, Foes!  Awake!
  17  *
  18  *     [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
  19  */
  20
  21 /* This file contains 'hot' pp ("push/pop") functions that
  22  * execute the opcodes that make up a perl program. A typical pp function
  23  * expects to find its arguments on the stack, and usually pushes its
  24  * results onto the stack, hence the 'pp' terminology. Each OP structure
  25  * contains a pointer to the relevant pp_foo() function.
  26  *
  27  * By 'hot', we mean common ops whose execution speed is critical.
  28  * By gathering them together into a single file, we encourage
  29  * CPU cache hits on hot code. Also it could be taken as a warning not to
  30  * change any code in this file unless you're sure it won't affect
  31  * performance.
  32  */
  33
  34 #include "EXTERN.h"
  35 #define PERL_IN_PP_HOT_C
  36 #include "perl.h"
  37
  38 /* Hot code. */
  39
  40 PP(pp_const)
  41 {
  42     dVAR;
  43     dSP;
  44     XPUSHs(cSVOP_sv);
  45     RETURN;
  46 }
  47
  48 PP(pp_nextstate)
  49 {
  50     dVAR;
  51     PL_curcop = (COP*)PL_op;
  52     TAINT_NOT;          /* Each statement is presumed innocent */
  53     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  54     FREETMPS;
  55     PERL_ASYNC_CHECK();
  56     return NORMAL;
  57 }
  58
  59 PP(pp_gvsv)
  60 {
  61     dVAR;
  62     dSP;
  63     EXTEND(SP,1);
  64     if (PL_op->op_private & OPpLVAL_INTRO)
  65         PUSHs(save_scalar(cGVOP_gv));
  66     else
  67         PUSHs(GvSVn(cGVOP_gv));
  68     RETURN;
  69 }
  70
  71 PP(pp_null)
  72 {
  73     dVAR;
  74     return NORMAL;
  75 }
  76
  77 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
  78 PP(pp_pushmark)
  79 {
  80     dVAR;
  81     PUSHMARK(PL_stack_sp);
  82     return NORMAL;
  83 }
  84
  85 PP(pp_stringify)
  86 {
  87     dVAR; dSP; dTARGET;
  88     sv_copypv(TARG,TOPs);
  89     SETTARG;
  90     RETURN;
  91 }
  92
  93 PP(pp_gv)
  94 {
  95     dVAR; dSP;
  96     XPUSHs(MUTABLE_SV(cGVOP_gv));
  97     RETURN;
  98 }
  99
 100 PP(pp_and)
 101 {
 102     dVAR; dSP;
 103     PERL_ASYNC_CHECK();
 104     if (!SvTRUE(TOPs))
 105         RETURN;
 106     else {
 107         if (PL_op->op_type == OP_AND)
 108             --SP;
 109         RETURNOP(cLOGOP->op_other);
 110     }
 111 }
 112
 113 PP(pp_sassign)
 114 {
 115     dVAR; dSP;
 116     /* sassign keeps its args in the optree traditionally backwards.
 117        So we pop them differently.
 118     */
 119     SV *left = POPs; SV *right = TOPs;
 120
 121     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
 122         SV * const temp = left;
 123         left = right; right = temp;
 124     }
 125     if (TAINTING_get && TAINT_get && !SvTAINTED(right))
 126         TAINT_NOT;
 127     if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
 128         SV * const cv = SvRV(right);
 129         const U32 cv_type = SvTYPE(cv);
 130         const bool is_gv = isGV_with_GP(left);
 131         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 132
 133         if (!got_coderef) {
 134             assert(SvROK(cv));
 135         }
 136
 137         /* Can do the optimisation if left (LVALUE) is not a typeglob,
 138            right (RVALUE) is a reference to something, and we're in void
 139            context. */
 140         if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
 141             /* Is the target symbol table currently empty?  */
 142             GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
 143             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 144                 /* Good. Create a new proxy constant subroutine in the target.
 145                    The gv becomes a(nother) reference to the constant.  */
 146                 SV *const value = SvRV(cv);
 147
 148                 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
 149                 SvPCS_IMPORTED_on(gv);
 150                 SvRV_set(gv, value);
 151                 SvREFCNT_inc_simple_void(value);
 152                 SETs(left);
 153                 RETURN;
 154             }
 155         }
 156
 157         /* Need to fix things up.  */
 158         if (!is_gv) {
 159             /* Need to fix GV.  */
 160             left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
 161         }
 162
 163         if (!got_coderef) {
 164             /* We've been returned a constant rather than a full subroutine,
 165                but they expect a subroutine reference to apply.  */
 166             if (SvROK(cv)) {
 167                 ENTER_with_name("sassign_coderef");
 168                 SvREFCNT_inc_void(SvRV(cv));
 169                 /* newCONSTSUB takes a reference count on the passed in SV
 170                    from us.  We set the name to NULL, otherwise we get into
 171                    all sorts of fun as the reference to our new sub is
 172                    donated to the GV that we're about to assign to.
 173                 */
 174                 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
 175                                                       SvRV(cv))));
 176                 SvREFCNT_dec(cv);
 177                 LEAVE_with_name("sassign_coderef");
 178             } else {
 179                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
 180                    is that
 181                    First:   ops for \&{"BONK"}; return us the constant in the
 182                             symbol table
 183                    Second:  ops for *{"BONK"} cause that symbol table entry
 184                             (and our reference to it) to be upgraded from RV
 185                             to typeblob)
 186                    Thirdly: We get here. cv is actually PVGV now, and its
 187                             GvCV() is actually the subroutine we're looking for
 188
 189                    So change the reference so that it points to the subroutine
 190                    of that typeglob, as that's what they were after all along.
 191                 */
 192                 GV *const upgraded = MUTABLE_GV(cv);
 193                 CV *const source = GvCV(upgraded);
 194
 195                 assert(source);
 196                 assert(CvFLAGS(source) & CVf_CONST);
 197
 198                 SvREFCNT_inc_void(source);
 199                 SvREFCNT_dec(upgraded);
 200                 SvRV_set(right, MUTABLE_SV(source));
 201             }
 202         }
 203
 204     }
 205     if (
 206       SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
 207       (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
 208     )
 209         Perl_warner(aTHX_
 210             packWARN(WARN_MISC), "Useless assignment to a temporary"
 211         );
 212     SvSetMagicSV(left, right);
 213     SETs(left);
 214     RETURN;
 215 }
 216
 217 PP(pp_cond_expr)
 218 {
 219     dVAR; dSP;
 220     PERL_ASYNC_CHECK();
 221     if (SvTRUEx(POPs))
 222         RETURNOP(cLOGOP->op_other);
 223     else
 224         RETURNOP(cLOGOP->op_next);
 225 }
 226
 227 PP(pp_unstack)
 228 {
 229     dVAR;
 230     PERL_ASYNC_CHECK();
 231     TAINT_NOT;          /* Each statement is presumed innocent */
 232     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 233     FREETMPS;
 234     if (!(PL_op->op_flags & OPf_SPECIAL)) {
 235         I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
 236         LEAVE_SCOPE(oldsave);
 237     }
 238     return NORMAL;
 239 }
 240
 241 PP(pp_concat)
 242 {
 243   dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
 244   {
 245     dPOPTOPssrl;
 246     bool lbyte;
 247     STRLEN rlen;
 248     const char *rpv = NULL;
 249     bool rbyte = FALSE;
 250     bool rcopied = FALSE;
 251
 252     if (TARG == right && right != left) { /* $r = $l.$r */
 253         rpv = SvPV_nomg_const(right, rlen);
 254         rbyte = !DO_UTF8(right);
 255         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 256         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 257         rcopied = TRUE;
 258     }
 259
 260     if (TARG != left) { /* not $l .= $r */
 261         STRLEN llen;
 262         const char* const lpv = SvPV_nomg_const(left, llen);
 263         lbyte = !DO_UTF8(left);
 264         sv_setpvn(TARG, lpv, llen);
 265         if (!lbyte)
 266             SvUTF8_on(TARG);
 267         else
 268             SvUTF8_off(TARG);
 269     }
 270     else { /* $l .= $r */
 271         if (!SvOK(TARG)) {
 272             if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
 273                 report_uninit(right);
 274             sv_setpvs(left, "");
 275         }
 276         SvPV_force_nomg_nolen(left);
 277         lbyte = !DO_UTF8(left);
 278         if (IN_BYTES)
 279             SvUTF8_off(TARG);
 280     }
 281
 282     if (!rcopied) {
 283         if (left == right)
 284             /* $r.$r: do magic twice: tied might return different 2nd time */
 285             SvGETMAGIC(right);
 286         rpv = SvPV_nomg_const(right, rlen);
 287         rbyte = !DO_UTF8(right);
 288     }
 289     if (lbyte != rbyte) {
 290         /* sv_utf8_upgrade_nomg() may reallocate the stack */
 291         PUTBACK;
 292         if (lbyte)
 293             sv_utf8_upgrade_nomg(TARG);
 294         else {
 295             if (!rcopied)
 296                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 297             sv_utf8_upgrade_nomg(right);
 298             rpv = SvPV_nomg_const(right, rlen);
 299         }
 300         SPAGAIN;
 301     }
 302     sv_catpvn_nomg(TARG, rpv, rlen);
 303
 304     SETTARG;
 305     RETURN;
 306   }
 307 }
 308
 309 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     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         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                     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             UV buv;
 547             bool buvok = SvUOK(svr);
 548
 549             if (buvok)
 550                 buv = SvUVX(svr);
 551             else {
 552                 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     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         else if (PL_op->op_flags & OPf_MOD
 781                 && PL_op->op_private & OPpLVAL_INTRO)
 782             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 783     }
 784     else if (SvTYPE(sv) != type) {
 785             GV *gv;
 786
 787             if (!isGV_with_GP(sv)) {
 788                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 789                                      type, &sp);
 790                 if (!gv)
 791                     RETURN;
 792             }
 793             else {
 794                 gv = MUTABLE_GV(sv);
 795             }
 796             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
 797             if (PL_op->op_private & OPpLVAL_INTRO)
 798                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
 799     }
 800     if (PL_op->op_flags & OPf_REF) {
 801                 SETs(sv);
 802                 RETURN;
 803     }
 804     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
 805               const I32 flags = is_lvalue_sub();
 806               if (flags && !(flags & OPpENTERSUB_INARGS)) {
 807                 if (gimme != G_ARRAY)
 808                     goto croak_cant_return;
 809                 SETs(sv);
 810                 RETURN;
 811               }
 812     }
 813
 814     if (is_pp_rv2av) {
 815         AV *const av = MUTABLE_AV(sv);
 816         /* The guts of pp_rv2av, with no intending change to preserve history
 817            (until such time as we get tools that can do blame annotation across
 818            whitespace changes.  */
 819         if (gimme == G_ARRAY) {
 820             const I32 maxarg = AvFILL(av) + 1;
 821             (void)POPs;                 /* XXXX May be optimized away? */
 822             EXTEND(SP, maxarg);
 823             if (SvRMAGICAL(av)) {
 824                 U32 i;
 825                 for (i=0; i < (U32)maxarg; i++) {
 826                     SV ** const svp = av_fetch(av, i, FALSE);
 827                     /* See note in pp_helem, and bug id #27839 */
 828                     SP[i+1] = svp
 829                         ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
 830                         : &PL_sv_undef;
 831                 }
 832             }
 833             else {
 834                 Copy(AvARRAY(av), SP+1, maxarg, SV*);
 835             }
 836             SP += maxarg;
 837         }
 838         else if (gimme == G_SCALAR) {
 839             dTARGET;
 840             const I32 maxarg = AvFILL(av) + 1;
 841             SETi(maxarg);
 842         }
 843     } else {
 844         /* The guts of pp_rv2hv  */
 845         if (gimme == G_ARRAY) { /* array wanted */
 846             *PL_stack_sp = sv;
 847             return Perl_do_kv(aTHX);
 848         }
 849         else if ((PL_op->op_private & OPpTRUEBOOL
 850               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
 851                  && block_gimme() == G_VOID  ))
 852               && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
 853             SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
 854         else if (gimme == G_SCALAR) {
 855             dTARGET;
 856             TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
 857             SPAGAIN;
 858             SETTARG;
 859         }
 860     }
 861     RETURN;
 862
 863  croak_cant_return:
 864     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
 865                is_pp_rv2av ? "array" : "hash");
 866     RETURN;
 867 }
 868
 869 STATIC void
 870 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 871 {
 872     dVAR;
 873
 874     PERL_ARGS_ASSERT_DO_ODDBALL;
 875
 876     if (*relem) {
 877         SV *tmpstr;
 878         const HE *didstore;
 879
 880         if (ckWARN(WARN_MISC)) {
 881             const char *err;
 882             if (relem == firstrelem &&
 883                 SvROK(*relem) &&
 884                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 885                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 886             {
 887                 err = "Reference found where even-sized list expected";
 888             }
 889             else
 890                 err = "Odd number of elements in hash assignment";
 891             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
 892         }
 893
 894         tmpstr = newSV(0);
 895         didstore = hv_store_ent(hash,*relem,tmpstr,0);
 896         if (SvMAGICAL(hash)) {
 897             if (SvSMAGICAL(tmpstr))
 898                 mg_set(tmpstr);
 899             if (!didstore)
 900                 sv_2mortal(tmpstr);
 901         }
 902         TAINT_NOT;
 903     }
 904 }
 905
 906 PP(pp_aassign)
 907 {
 908     dVAR; dSP;
 909     SV **lastlelem = PL_stack_sp;
 910     SV **lastrelem = PL_stack_base + POPMARK;
 911     SV **firstrelem = PL_stack_base + POPMARK + 1;
 912     SV **firstlelem = lastrelem + 1;
 913
 914     SV **relem;
 915     SV **lelem;
 916
 917     SV *sv;
 918     AV *ary;
 919
 920     I32 gimme;
 921     HV *hash;
 922     I32 i;
 923     int magic;
 924     int duplicates = 0;
 925     SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet  */
 926
 927     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
 928     gimme = GIMME_V;
 929
 930     /* If there's a common identifier on both sides we have to take
 931      * special care that assigning the identifier on the left doesn't
 932      * clobber a value on the right that's used later in the list.
 933      * Don't bother if LHS is just an empty hash or array.
 934      */
 935
 936     if (    (PL_op->op_private & OPpASSIGN_COMMON)
 937         &&  (
 938                firstlelem != lastlelem
 939             || ! ((sv = *firstlelem))
 940             || SvMAGICAL(sv)
 941             || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
 942             || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
 943             || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
 944             )
 945     ) {
 946         EXTEND_MORTAL(lastrelem - firstrelem + 1);
 947         for (relem = firstrelem; relem <= lastrelem; relem++) {
 948             if ((sv = *relem)) {
 949                 TAINT_NOT;      /* Each item is independent */
 950
 951                 /* Dear TODO test in t/op/sort.t, I love you.
 952                    (It's relying on a panic, not a "semi-panic" from newSVsv()
 953                    and then an assertion failure below.)  */
 954                 if (SvIS_FREED(sv)) {
 955                     Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
 956                                (void*)sv);
 957                 }
 958                 /* Not newSVsv(), as it does not allow copy-on-write,
 959                    resulting in wasteful copies.  We need a second copy of
 960                    a temp here, hence the SV_NOSTEAL.  */
 961                 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
 962                                                |SV_NOSTEAL);
 963             }
 964         }
 965     }
 966
 967     relem = firstrelem;
 968     lelem = firstlelem;
 969     ary = NULL;
 970     hash = NULL;
 971
 972     while (lelem <= lastlelem) {
 973         TAINT_NOT;              /* Each item stands on its own, taintwise. */
 974         sv = *lelem++;
 975         switch (SvTYPE(sv)) {
 976         case SVt_PVAV:
 977             ary = MUTABLE_AV(sv);
 978             magic = SvMAGICAL(ary) != 0;
 979             ENTER;
 980             SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
 981             av_clear(ary);
 982             av_extend(ary, lastrelem - relem);
 983             i = 0;
 984             while (relem <= lastrelem) {        /* gobble up all the rest */
 985                 SV **didstore;
 986                 assert(*relem);
 987                 SvGETMAGIC(*relem); /* before newSV, in case it dies */
 988                 sv = newSV(0);
 989                 sv_setsv_nomg(sv, *relem);
 990                 *(relem++) = sv;
 991                 didstore = av_store(ary,i++,sv);
 992                 if (magic) {
 993                     if (!didstore)
 994                         sv_2mortal(sv);
 995                     if (SvSMAGICAL(sv))
 996                         mg_set(sv);
 997                 }
 998                 TAINT_NOT;
 999             }
1000             if (PL_delaymagic & DM_ARRAY_ISA)
1001                 SvSETMAGIC(MUTABLE_SV(ary));
1002             LEAVE;
1003             break;
1004         case SVt_PVHV: {                                /* normal hash */
1005                 SV *tmpstr;
1006                 SV** topelem = relem;
1007
1008                 hash = MUTABLE_HV(sv);
1009                 magic = SvMAGICAL(hash) != 0;
1010                 ENTER;
1011                 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1012                 hv_clear(hash);
1013                 firsthashrelem = relem;
1014
1015                 while (relem < lastrelem) {     /* gobble up all the rest */
1016                     HE *didstore;
1017                     sv = *relem ? *relem : &PL_sv_no;
1018                     relem++;
1019                     tmpstr = sv_newmortal();
1020                     if (*relem)
1021                         sv_setsv(tmpstr,*relem);        /* value */
1022                     relem++;
1023                     if (gimme != G_VOID) {
1024                         if (hv_exists_ent(hash, sv, 0))
1025                             /* key overwrites an existing entry */
1026                             duplicates += 2;
1027                         else
1028                         if (gimme == G_ARRAY) {
1029                             /* copy element back: possibly to an earlier
1030                              * stack location if we encountered dups earlier */
1031                             *topelem++ = sv;
1032                             *topelem++ = tmpstr;
1033                         }
1034                     }
1035                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1036                     if (didstore) SvREFCNT_inc_simple_void_NN(tmpstr);
1037                     if (magic) {
1038                         if (SvSMAGICAL(tmpstr))
1039                             mg_set(tmpstr);
1040                     }
1041                     TAINT_NOT;
1042                 }
1043                 if (relem == lastrelem) {
1044                     do_oddball(hash, relem, firstrelem);
1045                     relem++;
1046                 }
1047                 LEAVE;
1048             }
1049             break;
1050         default:
1051             if (SvIMMORTAL(sv)) {
1052                 if (relem <= lastrelem)
1053                     relem++;
1054                 break;
1055             }
1056             if (relem <= lastrelem) {
1057                 if (
1058                   SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1059                   (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1060                 )
1061                     Perl_warner(aTHX_
1062                        packWARN(WARN_MISC),
1063                       "Useless assignment to a temporary"
1064                     );
1065                 sv_setsv(sv, *relem);
1066                 *(relem++) = sv;
1067             }
1068             else
1069                 sv_setsv(sv, &PL_sv_undef);
1070             SvSETMAGIC(sv);
1071             break;
1072         }
1073     }
1074     if (PL_delaymagic & ~DM_DELAY) {
1075         /* Will be used to set PL_tainting below */
1076         UV tmp_uid  = PerlProc_getuid();
1077         UV tmp_euid = PerlProc_geteuid();
1078         UV tmp_gid  = PerlProc_getgid();
1079         UV tmp_egid = PerlProc_getegid();
1080
1081         if (PL_delaymagic & DM_UID) {
1082 #ifdef HAS_SETRESUID
1083             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1084                             (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1085                             (Uid_t)-1);
1086 #else
1087 #  ifdef HAS_SETREUID
1088             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1089                            (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1090 #  else
1091 #    ifdef HAS_SETRUID
1092             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1093                 (void)setruid(PL_delaymagic_uid);
1094                 PL_delaymagic &= ~DM_RUID;
1095             }
1096 #    endif /* HAS_SETRUID */
1097 #    ifdef HAS_SETEUID
1098             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1099                 (void)seteuid(PL_delaymagic_euid);
1100                 PL_delaymagic &= ~DM_EUID;
1101             }
1102 #    endif /* HAS_SETEUID */
1103             if (PL_delaymagic & DM_UID) {
1104                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1105                     DIE(aTHX_ "No setreuid available");
1106                 (void)PerlProc_setuid(PL_delaymagic_uid);
1107             }
1108 #  endif /* HAS_SETREUID */
1109 #endif /* HAS_SETRESUID */
1110             tmp_uid  = PerlProc_getuid();
1111             tmp_euid = PerlProc_geteuid();
1112         }
1113         if (PL_delaymagic & DM_GID) {
1114 #ifdef HAS_SETRESGID
1115             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1116                             (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1117                             (Gid_t)-1);
1118 #else
1119 #  ifdef HAS_SETREGID
1120             (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1121                            (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1122 #  else
1123 #    ifdef HAS_SETRGID
1124             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1125                 (void)setrgid(PL_delaymagic_gid);
1126                 PL_delaymagic &= ~DM_RGID;
1127             }
1128 #    endif /* HAS_SETRGID */
1129 #    ifdef HAS_SETEGID
1130             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1131                 (void)setegid(PL_delaymagic_egid);
1132                 PL_delaymagic &= ~DM_EGID;
1133             }
1134 #    endif /* HAS_SETEGID */
1135             if (PL_delaymagic & DM_GID) {
1136                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1137                     DIE(aTHX_ "No setregid available");
1138                 (void)PerlProc_setgid(PL_delaymagic_gid);
1139             }
1140 #  endif /* HAS_SETREGID */
1141 #endif /* HAS_SETRESGID */
1142             tmp_gid  = PerlProc_getgid();
1143             tmp_egid = PerlProc_getegid();
1144         }
1145         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1146     }
1147     PL_delaymagic = 0;
1148
1149     if (gimme == G_VOID)
1150         SP = firstrelem - 1;
1151     else if (gimme == G_SCALAR) {
1152         dTARGET;
1153         SP = firstrelem;
1154         SETi(lastrelem - firstrelem + 1 - duplicates);
1155     }
1156     else {
1157         if (ary)
1158             SP = lastrelem;
1159         else if (hash) {
1160             if (duplicates) {
1161                 /* at this point we have removed the duplicate key/value
1162                  * pairs from the stack, but the remaining values may be
1163                  * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1164                  * the (a 2), but the stack now probably contains
1165                  * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1166                  * obliterates the earlier key. So refresh all values. */
1167                 lastrelem -= duplicates;
1168                 relem = firsthashrelem;
1169                 while (relem < lastrelem) {
1170                     HE *he;
1171                     sv = *relem++;
1172                     he = hv_fetch_ent(hash, sv, 0, 0);
1173                     *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1174                 }
1175             }
1176             SP = lastrelem;
1177         }
1178         else
1179             SP = firstrelem + (lastlelem - firstlelem);
1180         lelem = firstlelem + (relem - firstrelem);
1181         while (relem <= SP)
1182             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1183     }
1184
1185     RETURN;
1186 }
1187
1188 PP(pp_qr)
1189 {
1190     dVAR; dSP;
1191     PMOP * const pm = cPMOP;
1192     REGEXP * rx = PM_GETRE(pm);
1193     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1194     SV * const rv = sv_newmortal();
1195     CV **cvp;
1196     CV *cv;
1197
1198     SvUPGRADE(rv, SVt_IV);
1199     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1200        loathe to use it here, but it seems to be the right fix. Or close.
1201        The key part appears to be that it's essential for pp_qr to return a new
1202        object (SV), which implies that there needs to be an effective way to
1203        generate a new SV from the existing SV that is pre-compiled in the
1204        optree.  */
1205     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1206     SvROK_on(rv);
1207
1208     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1209     if ((cv = *cvp) && CvCLONE(*cvp)) {
1210         *cvp = cv_clone(cv);
1211         SvREFCNT_dec(cv);
1212     }
1213
1214     if (pkg) {
1215         HV *const stash = gv_stashsv(pkg, GV_ADD);
1216         SvREFCNT_dec(pkg);
1217         (void)sv_bless(rv, stash);
1218     }
1219
1220     if (RX_ISTAINTED(rx)) {
1221         SvTAINTED_on(rv);
1222         SvTAINTED_on(SvRV(rv));
1223     }
1224     XPUSHs(rv);
1225     RETURN;
1226 }
1227
1228 PP(pp_match)
1229 {
1230     dVAR; dSP; dTARG;
1231     PMOP *pm = cPMOP;
1232     PMOP *dynpm = pm;
1233     const char *t;
1234     const char *s;
1235     const char *strend;
1236     I32 global;
1237     U8 r_flags = REXEC_CHECKED;
1238     const char *truebase;                       /* Start of string  */
1239     REGEXP *rx = PM_GETRE(pm);
1240     bool rxtainted;
1241     const I32 gimme = GIMME;
1242     STRLEN len;
1243     I32 minmatch = 0;
1244     const I32 oldsave = PL_savestack_ix;
1245     I32 update_minmatch = 1;
1246     I32 had_zerolen = 0;
1247     U32 gpos = 0;
1248
1249     if (PL_op->op_flags & OPf_STACKED)
1250         TARG = POPs;
1251     else if (PL_op->op_private & OPpTARGET_MY)
1252         GETTARGET;
1253     else {
1254         TARG = DEFSV;
1255         EXTEND(SP,1);
1256     }
1257
1258     PUTBACK;                            /* EVAL blocks need stack_sp. */
1259     /* Skip get-magic if this is a qr// clone, because regcomp has
1260        already done it. */
1261     s = ReANY(rx)->mother_re
1262          ? SvPV_nomg_const(TARG, len)
1263          : SvPV_const(TARG, len);
1264     if (!s)
1265         DIE(aTHX_ "panic: pp_match");
1266     strend = s + len;
1267     rxtainted = (RX_ISTAINTED(rx) ||
1268                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1269     TAINT_NOT;
1270
1271     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1272
1273     /* PMdf_USED is set after a ?? matches once */
1274     if (
1275 #ifdef USE_ITHREADS
1276         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1277 #else
1278         pm->op_pmflags & PMf_USED
1279 #endif
1280     ) {
1281         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1282       failure:
1283
1284         if (gimme == G_ARRAY)
1285             RETURN;
1286         RETPUSHNO;
1287     }
1288
1289
1290
1291     /* empty pattern special-cased to use last successful pattern if
1292        possible, except for qr// */
1293     if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1294      && PL_curpm) {
1295         pm = PL_curpm;
1296         rx = PM_GETRE(pm);
1297     }
1298
1299     if (RX_MINLEN(rx) > (I32)len) {
1300         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
1301         goto failure;
1302     }
1303
1304     truebase = t = s;
1305
1306     /* XXXX What part of this is needed with true \G-support? */
1307     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1308         RX_OFFS(rx)[0].start = -1;
1309         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1310             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1311             if (mg && mg->mg_len >= 0) {
1312                 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1313                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1314                 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1315                     r_flags |= REXEC_IGNOREPOS;
1316                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1317                 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1318                     gpos = mg->mg_len;
1319                 else
1320                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1321                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1322                 update_minmatch = 0;
1323             }
1324         }
1325     }
1326     if (       RX_NPARENS(rx)
1327             || PL_sawampersand
1328             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1329     ) {
1330         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1331         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1332          * only on the first iteration. Therefore we need to copy $' as well
1333          * as $&, to make the rest of the string available for captures in
1334          * subsequent iterations */
1335         if (! (global && gimme == G_ARRAY))
1336             r_flags |= REXEC_COPY_SKIP_POST;
1337     };
1338
1339   play_it_again:
1340     if (global && RX_OFFS(rx)[0].start != -1) {
1341         t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1342         if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
1343             DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
1344             goto nope;
1345         }
1346         if (update_minmatch++)
1347             minmatch = had_zerolen;
1348     }
1349     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1350         DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1351         /* FIXME - can PL_bostr be made const char *?  */
1352         PL_bostr = (char *)truebase;
1353         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1354
1355         if (!s)
1356             goto nope;
1357         if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1358              && !PL_sawampersand
1359              && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1360              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1361             goto yup;
1362     }
1363     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1364                      minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1365         goto ret_no;
1366
1367     PL_curpm = pm;
1368     if (dynpm->op_pmflags & PMf_ONCE) {
1369 #ifdef USE_ITHREADS
1370         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1371 #else
1372         dynpm->op_pmflags |= PMf_USED;
1373 #endif
1374     }
1375
1376   gotcha:
1377     if (rxtainted)
1378         RX_MATCH_TAINTED_on(rx);
1379     TAINT_IF(RX_MATCH_TAINTED(rx));
1380     if (gimme == G_ARRAY) {
1381         const I32 nparens = RX_NPARENS(rx);
1382         I32 i = (global && !nparens) ? 1 : 0;
1383
1384         SPAGAIN;                        /* EVAL blocks could move the stack. */
1385         EXTEND(SP, nparens + i);
1386         EXTEND_MORTAL(nparens + i);
1387         for (i = !i; i <= nparens; i++) {
1388             PUSHs(sv_newmortal());
1389             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1390                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1391                 s = RX_OFFS(rx)[i].start + truebase;
1392                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1393                     len < 0 || len > strend - s)
1394                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1395                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1396                         (long) i, (long) RX_OFFS(rx)[i].start,
1397                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1398                 sv_setpvn(*SP, s, len);
1399                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1400                     SvUTF8_on(*SP);
1401             }
1402         }
1403         if (global) {
1404             if (dynpm->op_pmflags & PMf_CONTINUE) {
1405                 MAGIC* mg = NULL;
1406                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1407                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1408                 if (!mg) {
1409 #ifdef PERL_OLD_COPY_ON_WRITE
1410                     if (SvIsCOW(TARG))
1411                         sv_force_normal_flags(TARG, 0);
1412 #endif
1413                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1414                                      &PL_vtbl_mglob, NULL, 0);
1415                 }
1416                 if (RX_OFFS(rx)[0].start != -1) {
1417                     mg->mg_len = RX_OFFS(rx)[0].end;
1418                     if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1419                         mg->mg_flags |= MGf_MINMATCH;
1420                     else
1421                         mg->mg_flags &= ~MGf_MINMATCH;
1422                 }
1423             }
1424             had_zerolen = (RX_OFFS(rx)[0].start != -1
1425                            && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1426                                == (UV)RX_OFFS(rx)[0].end));
1427             PUTBACK;                    /* EVAL blocks may use stack */
1428             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1429             goto play_it_again;
1430         }
1431         else if (!nparens)
1432             XPUSHs(&PL_sv_yes);
1433         LEAVE_SCOPE(oldsave);
1434         RETURN;
1435     }
1436     else {
1437         if (global) {
1438             MAGIC* mg;
1439             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1440                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1441             else
1442                 mg = NULL;
1443             if (!mg) {
1444 #ifdef PERL_OLD_COPY_ON_WRITE
1445                 if (SvIsCOW(TARG))
1446                     sv_force_normal_flags(TARG, 0);
1447 #endif
1448                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1449                                  &PL_vtbl_mglob, NULL, 0);
1450             }
1451             if (RX_OFFS(rx)[0].start != -1) {
1452                 mg->mg_len = RX_OFFS(rx)[0].end;
1453                 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1454                     mg->mg_flags |= MGf_MINMATCH;
1455                 else
1456                     mg->mg_flags &= ~MGf_MINMATCH;
1457             }
1458         }
1459         LEAVE_SCOPE(oldsave);
1460         RETPUSHYES;
1461     }
1462
1463 yup:                                    /* Confirmed by INTUIT */
1464     if (rxtainted)
1465         RX_MATCH_TAINTED_on(rx);
1466     TAINT_IF(RX_MATCH_TAINTED(rx));
1467     PL_curpm = pm;
1468     if (dynpm->op_pmflags & PMf_ONCE) {
1469 #ifdef USE_ITHREADS
1470         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1471 #else
1472         dynpm->op_pmflags |= PMf_USED;
1473 #endif
1474     }
1475     if (RX_MATCH_COPIED(rx))
1476         Safefree(RX_SUBBEG(rx));
1477     RX_MATCH_COPIED_off(rx);
1478     RX_SUBBEG(rx) = NULL;
1479     if (global) {
1480         /* FIXME - should rx->subbeg be const char *?  */
1481         RX_SUBBEG(rx) = (char *) truebase;
1482         RX_SUBOFFSET(rx) = 0;
1483         RX_SUBCOFFSET(rx) = 0;
1484         RX_OFFS(rx)[0].start = s - truebase;
1485         if (RX_MATCH_UTF8(rx)) {
1486             char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1487             RX_OFFS(rx)[0].end = t - truebase;
1488         }
1489         else {
1490             RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1491         }
1492         RX_SUBLEN(rx) = strend - truebase;
1493         goto gotcha;
1494     }
1495     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1496         I32 off;
1497 #ifdef PERL_OLD_COPY_ON_WRITE
1498         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1499             if (DEBUG_C_TEST) {
1500                 PerlIO_printf(Perl_debug_log,
1501                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1502                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1503                               (int)(t-truebase));
1504             }
1505             RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1506             RX_SUBBEG(rx)
1507                 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1508             assert (SvPOKp(RX_SAVED_COPY(rx)));
1509         } else
1510 #endif
1511         {
1512
1513             RX_SUBBEG(rx) = savepvn(t, strend - t);
1514 #ifdef PERL_OLD_COPY_ON_WRITE
1515             RX_SAVED_COPY(rx) = NULL;
1516 #endif
1517         }
1518         RX_SUBLEN(rx) = strend - t;
1519         RX_SUBOFFSET(rx) = 0;
1520         RX_SUBCOFFSET(rx) = 0;
1521         RX_MATCH_COPIED_on(rx);
1522         off = RX_OFFS(rx)[0].start = s - t;
1523         RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1524     }
1525     else {                      /* startp/endp are used by @- @+. */
1526         RX_OFFS(rx)[0].start = s - truebase;
1527         RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1528     }
1529     /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
1530     assert(!RX_NPARENS(rx));
1531     RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
1532     LEAVE_SCOPE(oldsave);
1533     RETPUSHYES;
1534
1535 nope:
1536 ret_no:
1537     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1538         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1539             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1540             if (mg)
1541                 mg->mg_len = -1;
1542         }
1543     }
1544     LEAVE_SCOPE(oldsave);
1545     if (gimme == G_ARRAY)
1546         RETURN;
1547     RETPUSHNO;
1548 }
1549
1550 OP *
1551 Perl_do_readline(pTHX)
1552 {
1553     dVAR; dSP; dTARGETSTACKED;
1554     SV *sv;
1555     STRLEN tmplen = 0;
1556     STRLEN offset;
1557     PerlIO *fp;
1558     IO * const io = GvIO(PL_last_in_gv);
1559     const I32 type = PL_op->op_type;
1560     const I32 gimme = GIMME_V;
1561
1562     if (io) {
1563         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1564         if (mg) {
1565             Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1566             if (gimme == G_SCALAR) {
1567                 SPAGAIN;
1568                 SvSetSV_nosteal(TARG, TOPs);
1569                 SETTARG;
1570             }
1571             return NORMAL;
1572         }
1573     }
1574     fp = NULL;
1575     if (io) {
1576         fp = IoIFP(io);
1577         if (!fp) {
1578             if (IoFLAGS(io) & IOf_ARGV) {
1579                 if (IoFLAGS(io) & IOf_START) {
1580                     IoLINES(io) = 0;
1581                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1582                         IoFLAGS(io) &= ~IOf_START;
1583                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1584                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1585                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1586                         SvSETMAGIC(GvSV(PL_last_in_gv));
1587                         fp = IoIFP(io);
1588                         goto have_fp;
1589                     }
1590                 }
1591                 fp = nextargv(PL_last_in_gv);
1592                 if (!fp) { /* Note: fp != IoIFP(io) */
1593                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1594                 }
1595             }
1596             else if (type == OP_GLOB)
1597                 fp = Perl_start_glob(aTHX_ POPs, io);
1598         }
1599         else if (type == OP_GLOB)
1600             SP--;
1601         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1602             report_wrongway_fh(PL_last_in_gv, '>');
1603         }
1604     }
1605     if (!fp) {
1606         if ((!io || !(IoFLAGS(io) & IOf_START))
1607             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1608         {
1609             if (type == OP_GLOB)
1610                 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
1611                             "glob failed (can't start child: %s)",
1612                             Strerror(errno));
1613             else
1614                 report_evil_fh(PL_last_in_gv);
1615         }
1616         if (gimme == G_SCALAR) {
1617             /* undef TARG, and push that undefined value */
1618             if (type != OP_RCATLINE) {
1619                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1620                 SvOK_off(TARG);
1621             }
1622             PUSHTARG;
1623         }
1624         RETURN;
1625     }
1626   have_fp:
1627     if (gimme == G_SCALAR) {
1628         sv = TARG;
1629         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1630             mg_get(sv);
1631         if (SvROK(sv)) {
1632             if (type == OP_RCATLINE)
1633                 SvPV_force_nomg_nolen(sv);
1634             else
1635                 sv_unref(sv);
1636         }
1637         else if (isGV_with_GP(sv)) {
1638             SvPV_force_nomg_nolen(sv);
1639         }
1640         SvUPGRADE(sv, SVt_PV);
1641         tmplen = SvLEN(sv);     /* remember if already alloced */
1642         if (!tmplen && !SvREADONLY(sv)) {
1643             /* try short-buffering it. Please update t/op/readline.t
1644              * if you change the growth length.
1645              */
1646             Sv_Grow(sv, 80);
1647         }
1648         offset = 0;
1649         if (type == OP_RCATLINE && SvOK(sv)) {
1650             if (!SvPOK(sv)) {
1651                 SvPV_force_nomg_nolen(sv);
1652             }
1653             offset = SvCUR(sv);
1654         }
1655     }
1656     else {
1657         sv = sv_2mortal(newSV(80));
1658         offset = 0;
1659     }
1660
1661     /* This should not be marked tainted if the fp is marked clean */
1662 #define MAYBE_TAINT_LINE(io, sv) \
1663     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1664         TAINT;                          \
1665         SvTAINTED_on(sv);               \
1666     }
1667
1668 /* delay EOF state for a snarfed empty file */
1669 #define SNARF_EOF(gimme,rs,io,sv) \
1670     (gimme != G_SCALAR || SvCUR(sv)                                     \
1671      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1672
1673     for (;;) {
1674         PUTBACK;
1675         if (!sv_gets(sv, fp, offset)
1676             && (type == OP_GLOB
1677                 || SNARF_EOF(gimme, PL_rs, io, sv)
1678                 || PerlIO_error(fp)))
1679         {
1680             PerlIO_clearerr(fp);
1681             if (IoFLAGS(io) & IOf_ARGV) {
1682                 fp = nextargv(PL_last_in_gv);
1683                 if (fp)
1684                     continue;
1685                 (void)do_close(PL_last_in_gv, FALSE);
1686             }
1687             else if (type == OP_GLOB) {
1688                 if (!do_close(PL_last_in_gv, FALSE)) {
1689                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1690                                    "glob failed (child exited with status %d%s)",
1691                                    (int)(STATUS_CURRENT >> 8),
1692                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1693                 }
1694             }
1695             if (gimme == G_SCALAR) {
1696                 if (type != OP_RCATLINE) {
1697                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1698                     SvOK_off(TARG);
1699                 }
1700                 SPAGAIN;
1701                 PUSHTARG;
1702             }
1703             MAYBE_TAINT_LINE(io, sv);
1704             RETURN;
1705         }
1706         MAYBE_TAINT_LINE(io, sv);
1707         IoLINES(io)++;
1708         IoFLAGS(io) |= IOf_NOLINE;
1709         SvSETMAGIC(sv);
1710         SPAGAIN;
1711         XPUSHs(sv);
1712         if (type == OP_GLOB) {
1713             const char *t1;
1714
1715             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1716                 char * const tmps = SvEND(sv) - 1;
1717                 if (*tmps == *SvPVX_const(PL_rs)) {
1718                     *tmps = '\0';
1719                     SvCUR_set(sv, SvCUR(sv) - 1);
1720                 }
1721             }
1722             for (t1 = SvPVX_const(sv); *t1; t1++)
1723                 if (!isALNUMC(*t1) &&
1724                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1725                         break;
1726             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1727                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1728                 continue;
1729             }
1730         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1731              if (ckWARN(WARN_UTF8)) {
1732                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1733                 const STRLEN len = SvCUR(sv) - offset;
1734                 const U8 *f;
1735
1736                 if (!is_utf8_string_loc(s, len, &f))
1737                     /* Emulate :encoding(utf8) warning in the same case. */
1738                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1739                                 "utf8 \"\\x%02X\" does not map to Unicode",
1740                                 f < (U8*)SvEND(sv) ? *f : 0);
1741              }
1742         }
1743         if (gimme == G_ARRAY) {
1744             if (SvLEN(sv) - SvCUR(sv) > 20) {
1745                 SvPV_shrink_to_cur(sv);
1746             }
1747             sv = sv_2mortal(newSV(80));
1748             continue;
1749         }
1750         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1751             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1752             const STRLEN new_len
1753                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1754             SvPV_renew(sv, new_len);
1755         }
1756         RETURN;
1757     }
1758 }
1759
1760 PP(pp_helem)
1761 {
1762     dVAR; dSP;
1763     HE* he;
1764     SV **svp;
1765     SV * const keysv = POPs;
1766     HV * const hv = MUTABLE_HV(POPs);
1767     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1768     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1769     SV *sv;
1770     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1771     bool preeminent = TRUE;
1772
1773     if (SvTYPE(hv) != SVt_PVHV)
1774         RETPUSHUNDEF;
1775
1776     if (localizing) {
1777         MAGIC *mg;
1778         HV *stash;
1779
1780         /* If we can determine whether the element exist,
1781          * Try to preserve the existenceness of a tied hash
1782          * element by using EXISTS and DELETE if possible.
1783          * Fallback to FETCH and STORE otherwise. */
1784         if (SvCANEXISTDELETE(hv))
1785             preeminent = hv_exists_ent(hv, keysv, 0);
1786     }
1787
1788     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1789     svp = he ? &HeVAL(he) : NULL;
1790     if (lval) {
1791         if (!svp || !*svp || *svp == &PL_sv_undef) {
1792             SV* lv;
1793             SV* key2;
1794             if (!defer) {
1795                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1796             }
1797             lv = sv_newmortal();
1798             sv_upgrade(lv, SVt_PVLV);
1799             LvTYPE(lv) = 'y';
1800             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1801             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1802             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1803             LvTARGLEN(lv) = 1;
1804             PUSHs(lv);
1805             RETURN;
1806         }
1807         if (localizing) {
1808             if (HvNAME_get(hv) && isGV(*svp))
1809                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1810             else if (preeminent)
1811                 save_helem_flags(hv, keysv, svp,
1812                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1813             else
1814                 SAVEHDELETE(hv, keysv);
1815         }
1816         else if (PL_op->op_private & OPpDEREF) {
1817             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1818             RETURN;
1819         }
1820     }
1821     sv = (svp && *svp ? *svp : &PL_sv_undef);
1822     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1823      * was to make C<local $tied{foo} = $tied{foo}> possible.
1824      * However, it seems no longer to be needed for that purpose, and
1825      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1826      * would loop endlessly since the pos magic is getting set on the
1827      * mortal copy and lost. However, the copy has the effect of
1828      * triggering the get magic, and losing it altogether made things like
1829      * c<$tied{foo};> in void context no longer do get magic, which some
1830      * code relied on. Also, delayed triggering of magic on @+ and friends
1831      * meant the original regex may be out of scope by now. So as a
1832      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1833      * being called too many times). */
1834     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1835         mg_get(sv);
1836     PUSHs(sv);
1837     RETURN;
1838 }
1839
1840 PP(pp_iter)
1841 {
1842     dVAR; dSP;
1843     PERL_CONTEXT *cx;
1844     SV *sv, *oldsv;
1845     SV **itersvp;
1846     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1847     bool av_is_stack = FALSE;
1848
1849     EXTEND(SP, 1);
1850     cx = &cxstack[cxstack_ix];
1851     if (!CxTYPE_is_LOOP(cx))
1852         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1853
1854     itersvp = CxITERVAR(cx);
1855     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1856             /* string increment */
1857             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1858             SV *end = cx->blk_loop.state_u.lazysv.end;
1859             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1860                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1861             STRLEN maxlen = 0;
1862             const char *max = SvPV_const(end, maxlen);
1863             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1864                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1865                     /* safe to reuse old SV */
1866                     sv_setsv(*itersvp, cur);
1867                 }
1868                 else
1869                 {
1870                     /* we need a fresh SV every time so that loop body sees a
1871                      * completely new SV for closures/references to work as
1872                      * they used to */
1873                     oldsv = *itersvp;
1874                     *itersvp = newSVsv(cur);
1875                     SvREFCNT_dec(oldsv);
1876                 }
1877                 if (strEQ(SvPVX_const(cur), max))
1878                     sv_setiv(cur, 0); /* terminate next time */
1879                 else
1880                     sv_inc(cur);
1881                 RETPUSHYES;
1882             }
1883             RETPUSHNO;
1884     }
1885     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1886         /* integer increment */
1887         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1888             RETPUSHNO;
1889
1890         /* don't risk potential race */
1891         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1892             /* safe to reuse old SV */
1893             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur);
1894         }
1895         else
1896         {
1897             /* we need a fresh SV every time so that loop body sees a
1898              * completely new SV for closures/references to work as they
1899              * used to */
1900             oldsv = *itersvp;
1901             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur);
1902             SvREFCNT_dec(oldsv);
1903         }
1904
1905         if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) {
1906             /* Handle end of range at IV_MAX */
1907             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1908         } else
1909             ++cx->blk_loop.state_u.lazyiv.cur;
1910
1911         RETPUSHYES;
1912     }
1913
1914     /* iterate array */
1915     assert(CxTYPE(cx) == CXt_LOOP_FOR);
1916     av = cx->blk_loop.state_u.ary.ary;
1917     if (!av) {
1918         av_is_stack = TRUE;
1919         av = PL_curstack;
1920     }
1921     if (PL_op->op_private & OPpITER_REVERSED) {
1922         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1923                                     ? cx->blk_loop.resetsp + 1 : 0))
1924             RETPUSHNO;
1925
1926         if (SvMAGICAL(av) || AvREIFY(av)) {
1927             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1928             sv = svp ? *svp : NULL;
1929         }
1930         else {
1931             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1932         }
1933     }
1934     else {
1935         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1936                                     AvFILL(av)))
1937             RETPUSHNO;
1938
1939         if (SvMAGICAL(av) || AvREIFY(av)) {
1940             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1941             sv = svp ? *svp : NULL;
1942         }
1943         else {
1944             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1945         }
1946     }
1947
1948     if (sv && SvIS_FREED(sv)) {
1949         *itersvp = NULL;
1950         Perl_croak(aTHX_ "Use of freed value in iteration");
1951     }
1952
1953     if (sv) {
1954         SvTEMP_off(sv);
1955         SvREFCNT_inc_simple_void_NN(sv);
1956     }
1957     else
1958         sv = &PL_sv_undef;
1959     if (!av_is_stack && sv == &PL_sv_undef) {
1960         SV *lv = newSV_type(SVt_PVLV);
1961         LvTYPE(lv) = 'y';
1962         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1963         LvTARG(lv) = SvREFCNT_inc_simple(av);
1964         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1965         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1966         sv = lv;
1967     }
1968
1969     oldsv = *itersvp;
1970     *itersvp = sv;
1971     SvREFCNT_dec(oldsv);
1972
1973     RETPUSHYES;
1974 }
1975
1976 /*
1977 A description of how taint works in pattern matching and substitution.
1978
1979 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1980 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1981
1982 While the pattern is being assembled/concatenated and then compiled,
1983 PL_tainted will get set (via TAINT_set) if any component of the pattern
1984 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
1985 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1986 TAINT_get).
1987
1988 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1989 the pattern is marked as tainted. This means that subsequent usage, such
1990 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1991 on the new pattern too.
1992
1993 During execution of a pattern, locale-variant ops such as ALNUML set the
1994 local flag RF_tainted. At the end of execution, the engine sets the
1995 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1996 otherwise.
1997
1998 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1999 of $1 et al to indicate whether the returned value should be tainted.
2000 It is the responsibility of the caller of the pattern (i.e. pp_match,
2001 pp_subst etc) to set this flag for any other circumstances where $1 needs
2002 to be tainted.
2003
2004 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2005
2006 There are three possible sources of taint
2007     * the source string
2008     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2009     * the replacement string (or expression under /e)
2010
2011 There are four destinations of taint and they are affected by the sources
2012 according to the rules below:
2013
2014     * the return value (not including /r):
2015         tainted by the source string and pattern, but only for the
2016         number-of-iterations case; boolean returns aren't tainted;
2017     * the modified string (or modified copy under /r):
2018         tainted by the source string, pattern, and replacement strings;
2019     * $1 et al:
2020         tainted by the pattern, and under 'use re "taint"', by the source
2021         string too;
2022     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2023         should always be unset before executing subsequent code.
2024
2025 The overall action of pp_subst is:
2026
2027     * at the start, set bits in rxtainted indicating the taint status of
2028         the various sources.
2029
2030     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2031         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2032         pattern has subsequently become tainted via locale ops.
2033
2034     * If control is being passed to pp_substcont to execute a /e block,
2035         save rxtainted in the CXt_SUBST block, for future use by
2036         pp_substcont.
2037
2038     * Whenever control is being returned to perl code (either by falling
2039         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2040         use the flag bits in rxtainted to make all the appropriate types of
2041         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2042         et al will appear tainted.
2043
2044 pp_match is just a simpler version of the above.
2045
2046 */
2047
2048 PP(pp_subst)
2049 {
2050     dVAR; dSP; dTARG;
2051     PMOP *pm = cPMOP;
2052     PMOP *rpm = pm;
2053     char *s;
2054     char *strend;
2055     char *m;
2056     const char *c;
2057     char *d;
2058     STRLEN clen;
2059     I32 iters = 0;
2060     I32 maxiters;
2061     I32 i;
2062     bool once;
2063     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2064                         See "how taint works" above */
2065     char *orig;
2066     U8 r_flags;
2067     REGEXP *rx = PM_GETRE(pm);
2068     STRLEN len;
2069     int force_on_match = 0;
2070     const I32 oldsave = PL_savestack_ix;
2071     STRLEN slen;
2072     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2073 #ifdef PERL_OLD_COPY_ON_WRITE
2074     bool is_cow;
2075 #endif
2076     SV *nsv = NULL;
2077     /* known replacement string? */
2078     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2079
2080     PERL_ASYNC_CHECK();
2081
2082     if (PL_op->op_flags & OPf_STACKED)
2083         TARG = POPs;
2084     else if (PL_op->op_private & OPpTARGET_MY)
2085         GETTARGET;
2086     else {
2087         TARG = DEFSV;
2088         EXTEND(SP,1);
2089     }
2090
2091     SvGETMAGIC(TARG); /* must come before cow check */
2092 #ifdef PERL_OLD_COPY_ON_WRITE
2093     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2094        because they make integers such as 256 "false".  */
2095     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2096 #else
2097     if (SvIsCOW(TARG))
2098         sv_force_normal_flags(TARG,0);
2099 #endif
2100     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2101 #ifdef PERL_OLD_COPY_ON_WRITE
2102         && !is_cow
2103 #endif
2104         && (SvREADONLY(TARG)
2105             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2106                   || SvTYPE(TARG) > SVt_PVLV)
2107                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2108         Perl_croak_no_modify(aTHX);
2109     PUTBACK;
2110
2111     s = SvPV_nomg(TARG, len);
2112     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2113         force_on_match = 1;
2114
2115     /* only replace once? */
2116     once = !(rpm->op_pmflags & PMf_GLOBAL);
2117
2118     /* See "how taint works" above */
2119     if (TAINTING_get) {
2120         rxtainted  = (
2121             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2122           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2123           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2124           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2125                 ? SUBST_TAINT_BOOLRET : 0));
2126         TAINT_NOT;
2127     }
2128
2129     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2130
2131   force_it:
2132     if (!pm || !s)
2133         DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2134
2135     strend = s + len;
2136     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2137     maxiters = 2 * slen + 10;   /* We can match twice at each
2138                                    position, once with zero-length,
2139                                    second time with non-zero. */
2140
2141     if (!RX_PRELEN(rx) && PL_curpm
2142      && !ReANY(rx)->mother_re) {
2143         pm = PL_curpm;
2144         rx = PM_GETRE(pm);
2145     }
2146
2147     r_flags = (    RX_NPARENS(rx)
2148                 || PL_sawampersand
2149                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2150               )
2151           ? REXEC_COPY_STR
2152           : 0;
2153
2154     orig = m = s;
2155     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2156         PL_bostr = orig;
2157         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2158
2159         if (!s)
2160             goto ret_no;
2161         /* How to do it in subst? */
2162 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2163              && !PL_sawampersand
2164              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
2165             goto yup;
2166 */
2167     }
2168
2169     if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2170                          r_flags | REXEC_CHECKED))
2171     {
2172       ret_no:
2173         SPAGAIN;
2174         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2175         LEAVE_SCOPE(oldsave);
2176         RETURN;
2177     }
2178
2179     PL_curpm = pm;
2180
2181     /* known replacement string? */
2182     if (dstr) {
2183         /* replacement needing upgrading? */
2184         if (DO_UTF8(TARG) && !doutf8) {
2185              nsv = sv_newmortal();
2186              SvSetSV(nsv, dstr);
2187              if (PL_encoding)
2188                   sv_recode_to_utf8(nsv, PL_encoding);
2189              else
2190                   sv_utf8_upgrade(nsv);
2191              c = SvPV_const(nsv, clen);
2192              doutf8 = TRUE;
2193         }
2194         else {
2195             c = SvPV_const(dstr, clen);
2196             doutf8 = DO_UTF8(dstr);
2197         }
2198
2199         if (SvTAINTED(dstr))
2200             rxtainted |= SUBST_TAINT_REPL;
2201     }
2202     else {
2203         c = NULL;
2204         doutf8 = FALSE;
2205     }
2206
2207     /* can do inplace substitution? */
2208     if (c
2209 #ifdef PERL_OLD_COPY_ON_WRITE
2210         && !is_cow
2211 #endif
2212         && (I32)clen <= RX_MINLENRET(rx)
2213         && (once || !(r_flags & REXEC_COPY_STR))
2214         && !(RX_EXTFLAGS(rx) & (RXf_LOOKBEHIND_SEEN|RXf_MODIFIES_VARS))
2215         && (!doutf8 || SvUTF8(TARG))
2216         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2217     {
2218
2219 #ifdef PERL_OLD_COPY_ON_WRITE
2220         if (SvIsCOW(TARG)) {
2221             assert (!force_on_match);
2222             goto have_a_cow;
2223         }
2224 #endif
2225         if (force_on_match) {
2226             force_on_match = 0;
2227             s = SvPV_force_nomg(TARG, len);
2228             goto force_it;
2229         }
2230         d = s;
2231         if (once) {
2232             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2233                 rxtainted |= SUBST_TAINT_PAT;
2234             m = orig + RX_OFFS(rx)[0].start;
2235             d = orig + RX_OFFS(rx)[0].end;
2236             s = orig;
2237             if (m - s > strend - d) {  /* faster to shorten from end */
2238                 if (clen) {
2239                     Copy(c, m, clen, char);
2240                     m += clen;
2241                 }
2242                 i = strend - d;
2243                 if (i > 0) {
2244                     Move(d, m, i, char);
2245                     m += i;
2246                 }
2247                 *m = '\0';
2248                 SvCUR_set(TARG, m - s);
2249             }
2250             else if ((i = m - s)) {     /* faster from front */
2251                 d -= clen;
2252                 m = d;
2253                 Move(s, d - i, i, char);
2254                 sv_chop(TARG, d-i);
2255                 if (clen)
2256                     Copy(c, m, clen, char);
2257             }
2258             else if (clen) {
2259                 d -= clen;
2260                 sv_chop(TARG, d);
2261                 Copy(c, d, clen, char);
2262             }
2263             else {
2264                 sv_chop(TARG, d);
2265             }
2266             SPAGAIN;
2267             PUSHs(&PL_sv_yes);
2268         }
2269         else {
2270             do {
2271                 if (iters++ > maxiters)
2272                     DIE(aTHX_ "Substitution loop");
2273                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2274                     rxtainted |= SUBST_TAINT_PAT;
2275                 m = RX_OFFS(rx)[0].start + orig;
2276                 if ((i = m - s)) {
2277                     if (s != d)
2278                         Move(s, d, i, char);
2279                     d += i;
2280                 }
2281                 if (clen) {
2282                     Copy(c, d, clen, char);
2283                     d += clen;
2284                 }
2285                 s = RX_OFFS(rx)[0].end + orig;
2286             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2287                                  TARG, NULL,
2288                                  /* don't match same null twice */
2289                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2290             if (s != d) {
2291                 i = strend - s;
2292                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2293                 Move(s, d, i+1, char);          /* include the NUL */
2294             }
2295             SPAGAIN;
2296             mPUSHi((I32)iters);
2297         }
2298     }
2299     else {
2300         bool first;
2301         SV *repl;
2302         if (force_on_match) {
2303             force_on_match = 0;
2304             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2305                 /* I feel that it should be possible to avoid this mortal copy
2306                    given that the code below copies into a new destination.
2307                    However, I suspect it isn't worth the complexity of
2308                    unravelling the C<goto force_it> for the small number of
2309                    cases where it would be viable to drop into the copy code. */
2310                 TARG = sv_2mortal(newSVsv(TARG));
2311             }
2312             s = SvPV_force_nomg(TARG, len);
2313             goto force_it;
2314         }
2315 #ifdef PERL_OLD_COPY_ON_WRITE
2316       have_a_cow:
2317 #endif
2318         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2319             rxtainted |= SUBST_TAINT_PAT;
2320         repl = dstr;
2321         dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2322         if (!c) {
2323             PERL_CONTEXT *cx;
2324             SPAGAIN;
2325             /* note that a whole bunch of local vars are saved here for
2326              * use by pp_substcont: here's a list of them in case you're
2327              * searching for places in this sub that uses a particular var:
2328              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2329              * s m strend rx once */
2330             PUSHSUBST(cx);
2331             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2332         }
2333         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2334         first = TRUE;
2335         do {
2336             if (iters++ > maxiters)
2337                 DIE(aTHX_ "Substitution loop");
2338             if (RX_MATCH_TAINTED(rx))
2339                 rxtainted |= SUBST_TAINT_PAT;
2340             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2341                 m = s;
2342                 s = orig;
2343                 assert(RX_SUBOFFSET(rx) == 0);
2344                 orig = RX_SUBBEG(rx);
2345                 s = orig + (m - s);
2346                 strend = s + (strend - m);
2347             }
2348             m = RX_OFFS(rx)[0].start + orig;
2349             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2350             s = RX_OFFS(rx)[0].end + orig;
2351             if (first) {
2352                 /* replacement already stringified */
2353               if (clen)
2354                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2355               first = FALSE;
2356             }
2357             else {
2358                 if (PL_encoding) {
2359                     if (!nsv) nsv = sv_newmortal();
2360                     sv_copypv(nsv, repl);
2361                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2362                     sv_catsv(dstr, nsv);
2363                 }
2364                 else sv_catsv(dstr, repl);
2365                 if (SvTAINTED(repl))
2366                     rxtainted |= SUBST_TAINT_REPL;
2367             }
2368             if (once)
2369                 break;
2370         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2371                              TARG, NULL, r_flags));
2372         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2373
2374         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2375             /* From here on down we're using the copy, and leaving the original
2376                untouched.  */
2377             TARG = dstr;
2378             SPAGAIN;
2379             PUSHs(dstr);
2380         } else {
2381 #ifdef PERL_OLD_COPY_ON_WRITE
2382             /* The match may make the string COW. If so, brilliant, because
2383                that's just saved us one malloc, copy and free - the regexp has
2384                donated the old buffer, and we malloc an entirely new one, rather
2385                than the regexp malloc()ing a buffer and copying our original,
2386                only for us to throw it away here during the substitution.  */
2387             if (SvIsCOW(TARG)) {
2388                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2389             } else
2390 #endif
2391             {
2392                 SvPV_free(TARG);
2393             }
2394             SvPV_set(TARG, SvPVX(dstr));
2395             SvCUR_set(TARG, SvCUR(dstr));
2396             SvLEN_set(TARG, SvLEN(dstr));
2397             SvFLAGS(TARG) |= SvUTF8(dstr);
2398             SvPV_set(dstr, NULL);
2399
2400             SPAGAIN;
2401             mPUSHi((I32)iters);
2402         }
2403     }
2404
2405     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2406         (void)SvPOK_only_UTF8(TARG);
2407     }
2408
2409     /* See "how taint works" above */
2410     if (TAINTING_get) {
2411         if ((rxtainted & SUBST_TAINT_PAT) ||
2412             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2413                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2414         )
2415             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2416
2417         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2418             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2419         )
2420             SvTAINTED_on(TOPs);  /* taint return value */
2421         else
2422             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2423
2424         /* needed for mg_set below */
2425         TAINT_set(
2426           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2427         );
2428         SvTAINT(TARG);
2429     }
2430     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2431     TAINT_NOT;
2432     LEAVE_SCOPE(oldsave);
2433     RETURN;
2434 }
2435
2436 PP(pp_grepwhile)
2437 {
2438     dVAR; dSP;
2439
2440     if (SvTRUEx(POPs))
2441         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2442     ++*PL_markstack_ptr;
2443     FREETMPS;
2444     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2445
2446     /* All done yet? */
2447     if (PL_stack_base + *PL_markstack_ptr > SP) {
2448         I32 items;
2449         const I32 gimme = GIMME_V;
2450
2451         LEAVE_with_name("grep");                                        /* exit outer scope */
2452         (void)POPMARK;                          /* pop src */
2453         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2454         (void)POPMARK;                          /* pop dst */
2455         SP = PL_stack_base + POPMARK;           /* pop original mark */
2456         if (gimme == G_SCALAR) {
2457             if (PL_op->op_private & OPpGREP_LEX) {
2458                 SV* const sv = sv_newmortal();
2459                 sv_setiv(sv, items);
2460                 PUSHs(sv);
2461             }
2462             else {
2463                 dTARGET;
2464                 XPUSHi(items);
2465             }
2466         }
2467         else if (gimme == G_ARRAY)
2468             SP += items;
2469         RETURN;
2470     }
2471     else {
2472         SV *src;
2473
2474         ENTER_with_name("grep_item");                                   /* enter inner scope */
2475         SAVEVPTR(PL_curpm);
2476
2477         src = PL_stack_base[*PL_markstack_ptr];
2478         SvTEMP_off(src);
2479         if (PL_op->op_private & OPpGREP_LEX)
2480             PAD_SVl(PL_op->op_targ) = src;
2481         else
2482             DEFSV_set(src);
2483
2484         RETURNOP(cLOGOP->op_other);
2485     }
2486 }
2487
2488 PP(pp_leavesub)
2489 {
2490     dVAR; dSP;
2491     SV **mark;
2492     SV **newsp;
2493     PMOP *newpm;
2494     I32 gimme;
2495     PERL_CONTEXT *cx;
2496     SV *sv;
2497
2498     if (CxMULTICALL(&cxstack[cxstack_ix]))
2499         return 0;
2500
2501     POPBLOCK(cx,newpm);
2502     cxstack_ix++; /* temporarily protect top context */
2503
2504     TAINT_NOT;
2505     if (gimme == G_SCALAR) {
2506         MARK = newsp + 1;
2507         if (MARK <= SP) {
2508             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2509                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2510                      && !SvMAGICAL(TOPs)) {
2511                     *MARK = SvREFCNT_inc(TOPs);
2512                     FREETMPS;
2513                     sv_2mortal(*MARK);
2514                 }
2515                 else {
2516                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2517                     FREETMPS;
2518                     *MARK = sv_mortalcopy(sv);
2519                     SvREFCNT_dec(sv);
2520                 }
2521             }
2522             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2523                      && !SvMAGICAL(TOPs)) {
2524                 *MARK = TOPs;
2525             }
2526             else
2527                 *MARK = sv_mortalcopy(TOPs);
2528         }
2529         else {
2530             MEXTEND(MARK, 0);
2531             *MARK = &PL_sv_undef;
2532         }
2533         SP = MARK;
2534     }
2535     else if (gimme == G_ARRAY) {
2536         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2537             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2538                  || SvMAGICAL(*MARK)) {
2539                 *MARK = sv_mortalcopy(*MARK);
2540                 TAINT_NOT;      /* Each item is independent */
2541             }
2542         }
2543     }
2544     PUTBACK;
2545
2546     LEAVE;
2547     cxstack_ix--;
2548     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2549     PL_curpm = newpm;   /* ... and pop $1 et al */
2550
2551     LEAVESUB(sv);
2552     return cx->blk_sub.retop;
2553 }
2554
2555 PP(pp_entersub)
2556 {
2557     dVAR; dSP; dPOPss;
2558     GV *gv;
2559     CV *cv;
2560     PERL_CONTEXT *cx;
2561     I32 gimme;
2562     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2563
2564     if (!sv)
2565         DIE(aTHX_ "Not a CODE reference");
2566     switch (SvTYPE(sv)) {
2567         /* This is overwhelming the most common case:  */
2568     case SVt_PVGV:
2569       we_have_a_glob:
2570         if (!(cv = GvCVu((const GV *)sv))) {
2571             HV *stash;
2572             cv = sv_2cv(sv, &stash, &gv, 0);
2573         }
2574         if (!cv) {
2575             ENTER;
2576             SAVETMPS;
2577             goto try_autoload;
2578         }
2579         break;
2580     case SVt_PVLV:
2581         if(isGV_with_GP(sv)) goto we_have_a_glob;
2582         /*FALLTHROUGH*/
2583     default:
2584         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2585             if (hasargs)
2586                 SP = PL_stack_base + POPMARK;
2587             else
2588                 (void)POPMARK;
2589             RETURN;
2590         }
2591         SvGETMAGIC(sv);
2592         if (SvROK(sv)) {
2593             if (SvAMAGIC(sv)) {
2594                 sv = amagic_deref_call(sv, to_cv_amg);
2595                 /* Don't SPAGAIN here.  */
2596             }
2597         }
2598         else {
2599             const char *sym;
2600             STRLEN len;
2601             if (!SvOK(sv))
2602                 DIE(aTHX_ PL_no_usym, "a subroutine");
2603             sym = SvPV_nomg_const(sv, len);
2604             if (PL_op->op_private & HINT_STRICT_REFS)
2605                 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2606             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2607             break;
2608         }
2609         cv = MUTABLE_CV(SvRV(sv));
2610         if (SvTYPE(cv) == SVt_PVCV)
2611             break;
2612         /* FALL THROUGH */
2613     case SVt_PVHV:
2614     case SVt_PVAV:
2615         DIE(aTHX_ "Not a CODE reference");
2616         /* This is the second most common case:  */
2617     case SVt_PVCV:
2618         cv = MUTABLE_CV(sv);
2619         break;
2620     }
2621
2622     ENTER;
2623     SAVETMPS;
2624
2625   retry:
2626     if (CvCLONE(cv) && ! CvCLONED(cv))
2627         DIE(aTHX_ "Closure prototype called");
2628     if (!CvROOT(cv) && !CvXSUB(cv)) {
2629         GV* autogv;
2630         SV* sub_name;
2631
2632         /* anonymous or undef'd function leaves us no recourse */
2633         if (CvANON(cv) || !(gv = CvGV(cv))) {
2634             if (CvNAMED(cv))
2635                 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2636                            HEKfARG(CvNAME_HEK(cv)));
2637             DIE(aTHX_ "Undefined subroutine called");
2638         }
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         I32 items = SP - MARK;
2686         PADLIST * 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        undefined:
2965         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2966                    SVfARG(meth));
2967
2968     SvGETMAGIC(sv);
2969     if (SvROK(sv))
2970         ob = MUTABLE_SV(SvRV(sv));
2971     else if (!SvOK(sv)) goto undefined;
2972     else {
2973         /* this isn't a reference */
2974         GV* iogv;
2975         STRLEN packlen;
2976         const char * const packname = SvPV_nomg_const(sv, packlen);
2977         const bool packname_is_utf8 = !!SvUTF8(sv);
2978         const HE* const he =
2979             (const HE *)hv_common(
2980                 PL_stashcache, NULL, packname, packlen,
2981                 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
2982             );
2983
2984         if (he) {
2985             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2986             DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
2987                              stash, sv));
2988             goto fetch;
2989         }
2990
2991         if (!(iogv = gv_fetchpvn_flags(
2992                 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2993              )) ||
2994             !(ob=MUTABLE_SV(GvIO(iogv))))
2995         {
2996             /* this isn't the name of a filehandle either */
2997             if (!packlen)
2998             {
2999                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3000                                  "without a package or object reference",
3001                                   SVfARG(meth));
3002             }
3003             /* assume it's a package name */
3004             stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3005             if (!stash)
3006                 packsv = sv;
3007             else {
3008                 SV* const ref = newSViv(PTR2IV(stash));
3009                 (void)hv_store(PL_stashcache, packname,
3010                                 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3011                 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3012                                  stash, sv));
3013             }
3014             goto fetch;
3015         }
3016         /* it _is_ a filehandle name -- replace with a reference */
3017         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3018     }
3019
3020     /* if we got here, ob should be a reference or a glob */
3021     if (!ob || !(SvOBJECT(ob)
3022                  || (SvTYPE(ob) == SVt_PVGV
3023                      && isGV_with_GP(ob)
3024                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3025                      && SvOBJECT(ob))))
3026     {
3027         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3028                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3029                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3030                                         : meth));
3031     }
3032
3033     stash = SvSTASH(ob);
3034
3035   fetch:
3036     /* NOTE: stash may be null, hope hv_fetch_ent and
3037        gv_fetchmethod can cope (it seems they can) */
3038
3039     /* shortcut for simple names */
3040     if (hashp) {
3041         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3042         if (he) {
3043             gv = MUTABLE_GV(HeVAL(he));
3044             if (isGV(gv) && GvCV(gv) &&
3045                 (!GvCVGEN(gv) || GvCVGEN(gv)
3046                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3047                 return MUTABLE_SV(GvCV(gv));
3048         }
3049     }
3050
3051     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3052                                      meth, GV_AUTOLOAD | GV_CROAK);
3053
3054     assert(gv);
3055
3056     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3057 }
3058
3059 /*
3060  * Local variables:
3061  * c-indentation-style: bsd
3062  * c-basic-offset: 4
3063  * indent-tabs-mode: nil
3064  * End:
3065  *
3066  * ex: set ts=8 sts=4 sw=4 et:
3067  */