pp_hot.c

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