pp_hot.c

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