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 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1769     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1770     bool preeminent = TRUE;
1771
1772     if (SvTYPE(hv) != SVt_PVHV)
1773         RETPUSHUNDEF;
1774
1775     if (localizing) {
1776         MAGIC *mg;
1777         HV *stash;
1778
1779         /* If we can determine whether the element exist,
1780          * Try to preserve the existenceness of a tied hash
1781          * element by using EXISTS and DELETE if possible.
1782          * Fallback to FETCH and STORE otherwise. */
1783         if (SvCANEXISTDELETE(hv))
1784             preeminent = hv_exists_ent(hv, keysv, 0);
1785     }
1786
1787     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1788     svp = he ? &HeVAL(he) : NULL;
1789     if (lval) {
1790         if (!svp || !*svp || *svp == &PL_sv_undef) {
1791             SV* lv;
1792             SV* key2;
1793             if (!defer) {
1794                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1795             }
1796             lv = sv_newmortal();
1797             sv_upgrade(lv, SVt_PVLV);
1798             LvTYPE(lv) = 'y';
1799             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1800             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1801             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1802             LvTARGLEN(lv) = 1;
1803             PUSHs(lv);
1804             RETURN;
1805         }
1806         if (localizing) {
1807             if (HvNAME_get(hv) && isGV(*svp))
1808                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1809             else if (preeminent)
1810                 save_helem_flags(hv, keysv, svp,
1811                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1812             else
1813                 SAVEHDELETE(hv, keysv);
1814         }
1815         else if (PL_op->op_private & OPpDEREF) {
1816             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1817             RETURN;
1818         }
1819     }
1820     sv = (svp && *svp ? *svp : &PL_sv_undef);
1821     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1822      * was to make C<local $tied{foo} = $tied{foo}> possible.
1823      * However, it seems no longer to be needed for that purpose, and
1824      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1825      * would loop endlessly since the pos magic is getting set on the
1826      * mortal copy and lost. However, the copy has the effect of
1827      * triggering the get magic, and losing it altogether made things like
1828      * c<$tied{foo};> in void context no longer do get magic, which some
1829      * code relied on. Also, delayed triggering of magic on @+ and friends
1830      * meant the original regex may be out of scope by now. So as a
1831      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1832      * being called too many times). */
1833     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1834         mg_get(sv);
1835     PUSHs(sv);
1836     RETURN;
1837 }
1838
1839 PP(pp_iter)
1840 {
1841     dVAR; dSP;
1842     PERL_CONTEXT *cx;
1843     SV *sv, *oldsv;
1844     SV **itersvp;
1845     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1846     bool av_is_stack = FALSE;
1847
1848     EXTEND(SP, 1);
1849     cx = &cxstack[cxstack_ix];
1850     if (!CxTYPE_is_LOOP(cx))
1851         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1852
1853     itersvp = CxITERVAR(cx);
1854     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1855             /* string increment */
1856             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1857             SV *end = cx->blk_loop.state_u.lazysv.end;
1858             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1859                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1860             STRLEN maxlen = 0;
1861             const char *max = SvPV_const(end, maxlen);
1862             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1863                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1864                     /* safe to reuse old SV */
1865                     sv_setsv(*itersvp, cur);
1866                 }
1867                 else
1868                 {
1869                     /* we need a fresh SV every time so that loop body sees a
1870                      * completely new SV for closures/references to work as
1871                      * they used to */
1872                     oldsv = *itersvp;
1873                     *itersvp = newSVsv(cur);
1874                     SvREFCNT_dec(oldsv);
1875                 }
1876                 if (strEQ(SvPVX_const(cur), max))
1877                     sv_setiv(cur, 0); /* terminate next time */
1878                 else
1879                     sv_inc(cur);
1880                 RETPUSHYES;
1881             }
1882             RETPUSHNO;
1883     }
1884     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1885         /* integer increment */
1886         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1887             RETPUSHNO;
1888
1889         /* don't risk potential race */
1890         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1891             /* safe to reuse old SV */
1892             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur);
1893         }
1894         else
1895         {
1896             /* we need a fresh SV every time so that loop body sees a
1897              * completely new SV for closures/references to work as they
1898              * used to */
1899             oldsv = *itersvp;
1900             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur);
1901             SvREFCNT_dec(oldsv);
1902         }
1903
1904         if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) {
1905             /* Handle end of range at IV_MAX */
1906             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1907         } else
1908             ++cx->blk_loop.state_u.lazyiv.cur;
1909
1910         RETPUSHYES;
1911     }
1912
1913     /* iterate array */
1914     assert(CxTYPE(cx) == CXt_LOOP_FOR);
1915     av = cx->blk_loop.state_u.ary.ary;
1916     if (!av) {
1917         av_is_stack = TRUE;
1918         av = PL_curstack;
1919     }
1920     if (PL_op->op_private & OPpITER_REVERSED) {
1921         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1922                                     ? cx->blk_loop.resetsp + 1 : 0))
1923             RETPUSHNO;
1924
1925         if (SvMAGICAL(av) || AvREIFY(av)) {
1926             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1927             sv = svp ? *svp : NULL;
1928         }
1929         else {
1930             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1931         }
1932     }
1933     else {
1934         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1935                                     AvFILL(av)))
1936             RETPUSHNO;
1937
1938         if (SvMAGICAL(av) || AvREIFY(av)) {
1939             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1940             sv = svp ? *svp : NULL;
1941         }
1942         else {
1943             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1944         }
1945     }
1946
1947     if (sv && SvIS_FREED(sv)) {
1948         *itersvp = NULL;
1949         Perl_croak(aTHX_ "Use of freed value in iteration");
1950     }
1951
1952     if (sv) {
1953         SvTEMP_off(sv);
1954         SvREFCNT_inc_simple_void_NN(sv);
1955     }
1956     else
1957         sv = &PL_sv_undef;
1958     if (!av_is_stack && sv == &PL_sv_undef) {
1959         SV *lv = newSV_type(SVt_PVLV);
1960         LvTYPE(lv) = 'y';
1961         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1962         LvTARG(lv) = SvREFCNT_inc_simple(av);
1963         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1964         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1965         sv = lv;
1966     }
1967
1968     oldsv = *itersvp;
1969     *itersvp = sv;
1970     SvREFCNT_dec(oldsv);
1971
1972     RETPUSHYES;
1973 }
1974
1975 /*
1976 A description of how taint works in pattern matching and substitution.
1977
1978 While the pattern is being assembled/concatenated and then compiled,
1979 PL_tainted will get set if any component of the pattern is tainted, e.g.
1980 /.*$tainted/.  At the end of pattern compilation, the RXf_TAINTED flag
1981 is set on the pattern if PL_tainted is set.
1982
1983 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1984 the pattern is marked as tainted. This means that subsequent usage, such
1985 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1986
1987 During execution of a pattern, locale-variant ops such as ALNUML set the
1988 local flag RF_tainted. At the end of execution, the engine sets the
1989 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1990 otherwise.
1991
1992 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1993 of $1 et al to indicate whether the returned value should be tainted.
1994 It is the responsibility of the caller of the pattern (i.e. pp_match,
1995 pp_subst etc) to set this flag for any other circumstances where $1 needs
1996 to be tainted.
1997
1998 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1999
2000 There are three possible sources of taint
2001     * the source string
2002     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2003     * the replacement string (or expression under /e)
2004
2005 There are four destinations of taint and they are affected by the sources
2006 according to the rules below:
2007
2008     * the return value (not including /r):
2009         tainted by the source string and pattern, but only for the
2010         number-of-iterations case; boolean returns aren't tainted;
2011     * the modified string (or modified copy under /r):
2012         tainted by the source string, pattern, and replacement strings;
2013     * $1 et al:
2014         tainted by the pattern, and under 'use re "taint"', by the source
2015         string too;
2016     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2017         should always be unset before executing subsequent code.
2018
2019 The overall action of pp_subst is:
2020
2021     * at the start, set bits in rxtainted indicating the taint status of
2022         the various sources.
2023
2024     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2025         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2026         pattern has subsequently become tainted via locale ops.
2027
2028     * If control is being passed to pp_substcont to execute a /e block,
2029         save rxtainted in the CXt_SUBST block, for future use by
2030         pp_substcont.
2031
2032     * Whenever control is being returned to perl code (either by falling
2033         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2034         use the flag bits in rxtainted to make all the appropriate types of
2035         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2036         et al will appear tainted.
2037
2038 pp_match is just a simpler version of the above.
2039
2040 */
2041
2042 PP(pp_subst)
2043 {
2044     dVAR; dSP; dTARG;
2045     PMOP *pm = cPMOP;
2046     PMOP *rpm = pm;
2047     char *s;
2048     char *strend;
2049     char *m;
2050     const char *c;
2051     char *d;
2052     STRLEN clen;
2053     I32 iters = 0;
2054     I32 maxiters;
2055     I32 i;
2056     bool once;
2057     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2058                         See "how taint works" above */
2059     char *orig;
2060     U8 r_flags;
2061     REGEXP *rx = PM_GETRE(pm);
2062     STRLEN len;
2063     int force_on_match = 0;
2064     const I32 oldsave = PL_savestack_ix;
2065     STRLEN slen;
2066     bool doutf8 = FALSE;
2067 #ifdef PERL_OLD_COPY_ON_WRITE
2068     bool is_cow;
2069 #endif
2070     SV *nsv = NULL;
2071     /* known replacement string? */
2072     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2073
2074     PERL_ASYNC_CHECK();
2075
2076     if (PL_op->op_flags & OPf_STACKED)
2077         TARG = POPs;
2078     else if (PL_op->op_private & OPpTARGET_MY)
2079         GETTARGET;
2080     else {
2081         TARG = DEFSV;
2082         EXTEND(SP,1);
2083     }
2084
2085 #ifdef PERL_OLD_COPY_ON_WRITE
2086     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2087        because they make integers such as 256 "false".  */
2088     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2089 #else
2090     if (SvIsCOW(TARG))
2091         sv_force_normal_flags(TARG,0);
2092 #endif
2093     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2094 #ifdef PERL_OLD_COPY_ON_WRITE
2095         && !is_cow
2096 #endif
2097         && (SvREADONLY(TARG)
2098             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2099                   || SvTYPE(TARG) > SVt_PVLV)
2100                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2101         Perl_croak_no_modify(aTHX);
2102     PUTBACK;
2103
2104   setup_match:
2105     s = SvPV_mutable(TARG, len);
2106     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2107         force_on_match = 1;
2108
2109     /* only replace once? */
2110     once = !(rpm->op_pmflags & PMf_GLOBAL);
2111
2112     /* See "how taint works" above */
2113     if (PL_tainting) {
2114         rxtainted  = (
2115             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2116           | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2117           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2118           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2119                 ? SUBST_TAINT_BOOLRET : 0));
2120         TAINT_NOT;
2121     }
2122
2123     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2124
2125   force_it:
2126     if (!pm || !s)
2127         DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2128
2129     strend = s + len;
2130     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2131     maxiters = 2 * slen + 10;   /* We can match twice at each
2132                                    position, once with zero-length,
2133                                    second time with non-zero. */
2134
2135     if (!RX_PRELEN(rx) && PL_curpm) {
2136         pm = PL_curpm;
2137         rx = PM_GETRE(pm);
2138     }
2139
2140     r_flags = (    RX_NPARENS(rx)
2141                 || PL_sawampersand
2142                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2143               )
2144           ? REXEC_COPY_STR
2145           : 0;
2146
2147     orig = m = s;
2148     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2149         PL_bostr = orig;
2150         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2151
2152         if (!s)
2153             goto ret_no;
2154         /* How to do it in subst? */
2155 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2156              && !PL_sawampersand
2157              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
2158             goto yup;
2159 */
2160     }
2161
2162     if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2163                          r_flags | REXEC_CHECKED))
2164     {
2165       ret_no:
2166         SPAGAIN;
2167         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2168         LEAVE_SCOPE(oldsave);
2169         RETURN;
2170     }
2171
2172     /* known replacement string? */
2173     if (dstr) {
2174         if (SvTAINTED(dstr))
2175             rxtainted |= SUBST_TAINT_REPL;
2176
2177         /* Upgrade the source if the replacement is utf8 but the source is not,
2178          * but only if it matched; see
2179          * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2180          */
2181         if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2182             char * const orig_pvx =  SvPVX(TARG);
2183             const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2184
2185             /* If the lengths are the same, the pattern contains only
2186              * invariants, can keep going; otherwise, various internal markers
2187              * could be off, so redo */
2188             if (new_len != len || orig_pvx != SvPVX(TARG)) {
2189                 goto setup_match;
2190             }
2191         }
2192
2193         /* replacement needing upgrading? */
2194         if (DO_UTF8(TARG) && !doutf8) {
2195              nsv = sv_newmortal();
2196              SvSetSV(nsv, dstr);
2197              if (PL_encoding)
2198                   sv_recode_to_utf8(nsv, PL_encoding);
2199              else
2200                   sv_utf8_upgrade(nsv);
2201              c = SvPV_const(nsv, clen);
2202              doutf8 = TRUE;
2203         }
2204         else {
2205             c = SvPV_const(dstr, clen);
2206             doutf8 = DO_UTF8(dstr);
2207         }
2208     }
2209     else {
2210         c = NULL;
2211         doutf8 = FALSE;
2212     }
2213
2214     /* can do inplace substitution? */
2215     if (c
2216 #ifdef PERL_OLD_COPY_ON_WRITE
2217         && !is_cow
2218 #endif
2219         && (I32)clen <= RX_MINLENRET(rx)
2220         && (once || !(r_flags & REXEC_COPY_STR))
2221         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2222         && (!doutf8 || SvUTF8(TARG))
2223         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2224     {
2225
2226 #ifdef PERL_OLD_COPY_ON_WRITE
2227         if (SvIsCOW(TARG)) {
2228             assert (!force_on_match);
2229             goto have_a_cow;
2230         }
2231 #endif
2232         if (force_on_match) {
2233             force_on_match = 0;
2234             s = SvPV_force(TARG, len);
2235             goto force_it;
2236         }
2237         d = s;
2238         PL_curpm = pm;
2239         if (once) {
2240             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2241                 rxtainted |= SUBST_TAINT_PAT;
2242             m = orig + RX_OFFS(rx)[0].start;
2243             d = orig + RX_OFFS(rx)[0].end;
2244             s = orig;
2245             if (m - s > strend - d) {  /* faster to shorten from end */
2246                 if (clen) {
2247                     Copy(c, m, clen, char);
2248                     m += clen;
2249                 }
2250                 i = strend - d;
2251                 if (i > 0) {
2252                     Move(d, m, i, char);
2253                     m += i;
2254                 }
2255                 *m = '\0';
2256                 SvCUR_set(TARG, m - s);
2257             }
2258             else if ((i = m - s)) {     /* faster from front */
2259                 d -= clen;
2260                 m = d;
2261                 Move(s, d - i, i, char);
2262                 sv_chop(TARG, d-i);
2263                 if (clen)
2264                     Copy(c, m, clen, char);
2265             }
2266             else if (clen) {
2267                 d -= clen;
2268                 sv_chop(TARG, d);
2269                 Copy(c, d, clen, char);
2270             }
2271             else {
2272                 sv_chop(TARG, d);
2273             }
2274             SPAGAIN;
2275             PUSHs(&PL_sv_yes);
2276         }
2277         else {
2278             do {
2279                 if (iters++ > maxiters)
2280                     DIE(aTHX_ "Substitution loop");
2281                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2282                     rxtainted |= SUBST_TAINT_PAT;
2283                 m = RX_OFFS(rx)[0].start + orig;
2284                 if ((i = m - s)) {
2285                     if (s != d)
2286                         Move(s, d, i, char);
2287                     d += i;
2288                 }
2289                 if (clen) {
2290                     Copy(c, d, clen, char);
2291                     d += clen;
2292                 }
2293                 s = RX_OFFS(rx)[0].end + orig;
2294             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2295                                  TARG, NULL,
2296                                  /* don't match same null twice */
2297                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2298             if (s != d) {
2299                 i = strend - s;
2300                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2301                 Move(s, d, i+1, char);          /* include the NUL */
2302             }
2303             SPAGAIN;
2304             mPUSHi((I32)iters);
2305         }
2306     }
2307     else {
2308         if (force_on_match) {
2309             force_on_match = 0;
2310             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2311                 /* I feel that it should be possible to avoid this mortal copy
2312                    given that the code below copies into a new destination.
2313                    However, I suspect it isn't worth the complexity of
2314                    unravelling the C<goto force_it> for the small number of
2315                    cases where it would be viable to drop into the copy code. */
2316                 TARG = sv_2mortal(newSVsv(TARG));
2317             }
2318             s = SvPV_force(TARG, len);
2319             goto force_it;
2320         }
2321 #ifdef PERL_OLD_COPY_ON_WRITE
2322       have_a_cow:
2323 #endif
2324         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2325             rxtainted |= SUBST_TAINT_PAT;
2326         dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2327         PL_curpm = pm;
2328         if (!c) {
2329             PERL_CONTEXT *cx;
2330             SPAGAIN;
2331             /* note that a whole bunch of local vars are saved here for
2332              * use by pp_substcont: here's a list of them in case you're
2333              * searching for places in this sub that uses a particular var:
2334              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2335              * s m strend rx once */
2336             PUSHSUBST(cx);
2337             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2338         }
2339         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2340         do {
2341             if (iters++ > maxiters)
2342                 DIE(aTHX_ "Substitution loop");
2343             if (RX_MATCH_TAINTED(rx))
2344                 rxtainted |= SUBST_TAINT_PAT;
2345             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2346                 m = s;
2347                 s = orig;
2348                 assert(RX_SUBOFFSET(rx) == 0);
2349                 orig = RX_SUBBEG(rx);
2350                 s = orig + (m - s);
2351                 strend = s + (strend - m);
2352             }
2353             m = RX_OFFS(rx)[0].start + orig;
2354             if (doutf8 && !SvUTF8(dstr))
2355                 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
2356             else
2357                 sv_catpvn_nomg(dstr, s, m-s);
2358             s = RX_OFFS(rx)[0].end + orig;
2359             if (clen)
2360                 sv_catpvn_nomg(dstr, c, clen);
2361             if (once)
2362                 break;
2363         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2364                              TARG, NULL, r_flags));
2365         if (doutf8 && !DO_UTF8(TARG))
2366             sv_catpvn_nomg_utf8_upgrade(dstr, s, strend - s, nsv);
2367         else
2368             sv_catpvn_nomg(dstr, s, strend - s);
2369
2370         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2371             /* From here on down we're using the copy, and leaving the original
2372                untouched.  */
2373             TARG = dstr;
2374             SPAGAIN;
2375             PUSHs(dstr);
2376         } else {
2377 #ifdef PERL_OLD_COPY_ON_WRITE
2378             /* The match may make the string COW. If so, brilliant, because
2379                that's just saved us one malloc, copy and free - the regexp has
2380                donated the old buffer, and we malloc an entirely new one, rather
2381                than the regexp malloc()ing a buffer and copying our original,
2382                only for us to throw it away here during the substitution.  */
2383             if (SvIsCOW(TARG)) {
2384                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2385             } else
2386 #endif
2387             {
2388                 SvPV_free(TARG);
2389             }
2390             SvPV_set(TARG, SvPVX(dstr));
2391             SvCUR_set(TARG, SvCUR(dstr));
2392             SvLEN_set(TARG, SvLEN(dstr));
2393             doutf8 |= DO_UTF8(dstr);
2394             SvPV_set(dstr, NULL);
2395
2396             SPAGAIN;
2397             mPUSHi((I32)iters);
2398         }
2399     }
2400
2401     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2402         (void)SvPOK_only_UTF8(TARG);
2403         if (doutf8)
2404             SvUTF8_on(TARG);
2405     }
2406
2407     /* See "how taint works" above */
2408     if (PL_tainting) {
2409         if ((rxtainted & SUBST_TAINT_PAT) ||
2410             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2411                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2412         )
2413             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2414
2415         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2416             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2417         )
2418             SvTAINTED_on(TOPs);  /* taint return value */
2419         else
2420             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2421
2422         /* needed for mg_set below */
2423         PL_tainted =
2424           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2425         SvTAINT(TARG);
2426     }
2427     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2428     TAINT_NOT;
2429     LEAVE_SCOPE(oldsave);
2430     RETURN;
2431 }
2432
2433 PP(pp_grepwhile)
2434 {
2435     dVAR; dSP;
2436
2437     if (SvTRUEx(POPs))
2438         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2439     ++*PL_markstack_ptr;
2440     FREETMPS;
2441     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2442
2443     /* All done yet? */
2444     if (PL_stack_base + *PL_markstack_ptr > SP) {
2445         I32 items;
2446         const I32 gimme = GIMME_V;
2447
2448         LEAVE_with_name("grep");                                        /* exit outer scope */
2449         (void)POPMARK;                          /* pop src */
2450         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2451         (void)POPMARK;                          /* pop dst */
2452         SP = PL_stack_base + POPMARK;           /* pop original mark */
2453         if (gimme == G_SCALAR) {
2454             if (PL_op->op_private & OPpGREP_LEX) {
2455                 SV* const sv = sv_newmortal();
2456                 sv_setiv(sv, items);
2457                 PUSHs(sv);
2458             }
2459             else {
2460                 dTARGET;
2461                 XPUSHi(items);
2462             }
2463         }
2464         else if (gimme == G_ARRAY)
2465             SP += items;
2466         RETURN;
2467     }
2468     else {
2469         SV *src;
2470
2471         ENTER_with_name("grep_item");                                   /* enter inner scope */
2472         SAVEVPTR(PL_curpm);
2473
2474         src = PL_stack_base[*PL_markstack_ptr];
2475         SvTEMP_off(src);
2476         if (PL_op->op_private & OPpGREP_LEX)
2477             PAD_SVl(PL_op->op_targ) = src;
2478         else
2479             DEFSV_set(src);
2480
2481         RETURNOP(cLOGOP->op_other);
2482     }
2483 }
2484
2485 PP(pp_leavesub)
2486 {
2487     dVAR; dSP;
2488     SV **mark;
2489     SV **newsp;
2490     PMOP *newpm;
2491     I32 gimme;
2492     PERL_CONTEXT *cx;
2493     SV *sv;
2494
2495     if (CxMULTICALL(&cxstack[cxstack_ix]))
2496         return 0;
2497
2498     POPBLOCK(cx,newpm);
2499     cxstack_ix++; /* temporarily protect top context */
2500
2501     TAINT_NOT;
2502     if (gimme == G_SCALAR) {
2503         MARK = newsp + 1;
2504         if (MARK <= SP) {
2505             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2506                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2507                      && !SvMAGICAL(TOPs)) {
2508                     *MARK = SvREFCNT_inc(TOPs);
2509                     FREETMPS;
2510                     sv_2mortal(*MARK);
2511                 }
2512                 else {
2513                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2514                     FREETMPS;
2515                     *MARK = sv_mortalcopy(sv);
2516                     SvREFCNT_dec(sv);
2517                 }
2518             }
2519             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2520                      && !SvMAGICAL(TOPs)) {
2521                 *MARK = TOPs;
2522             }
2523             else
2524                 *MARK = sv_mortalcopy(TOPs);
2525         }
2526         else {
2527             MEXTEND(MARK, 0);
2528             *MARK = &PL_sv_undef;
2529         }
2530         SP = MARK;
2531     }
2532     else if (gimme == G_ARRAY) {
2533         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2534             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2535                  || SvMAGICAL(*MARK)) {
2536                 *MARK = sv_mortalcopy(*MARK);
2537                 TAINT_NOT;      /* Each item is independent */
2538             }
2539         }
2540     }
2541     PUTBACK;
2542
2543     LEAVE;
2544     cxstack_ix--;
2545     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2546     PL_curpm = newpm;   /* ... and pop $1 et al */
2547
2548     LEAVESUB(sv);
2549     return cx->blk_sub.retop;
2550 }
2551
2552 PP(pp_entersub)
2553 {
2554     dVAR; dSP; dPOPss;
2555     GV *gv;
2556     CV *cv;
2557     PERL_CONTEXT *cx;
2558     I32 gimme;
2559     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2560
2561     if (!sv)
2562         DIE(aTHX_ "Not a CODE reference");
2563     switch (SvTYPE(sv)) {
2564         /* This is overwhelming the most common case:  */
2565     case SVt_PVGV:
2566       we_have_a_glob:
2567         if (!(cv = GvCVu((const GV *)sv))) {
2568             HV *stash;
2569             cv = sv_2cv(sv, &stash, &gv, 0);
2570         }
2571         if (!cv) {
2572             ENTER;
2573             SAVETMPS;
2574             goto try_autoload;
2575         }
2576         break;
2577     case SVt_PVLV:
2578         if(isGV_with_GP(sv)) goto we_have_a_glob;
2579         /*FALLTHROUGH*/
2580     default:
2581         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2582             if (hasargs)
2583                 SP = PL_stack_base + POPMARK;
2584             else
2585                 (void)POPMARK;
2586             RETURN;
2587         }
2588         SvGETMAGIC(sv);
2589         if (SvROK(sv)) {
2590             if (SvAMAGIC(sv)) {
2591                 sv = amagic_deref_call(sv, to_cv_amg);
2592                 /* Don't SPAGAIN here.  */
2593             }
2594         }
2595         else {
2596             const char *sym;
2597             STRLEN len;
2598             if (!SvOK(sv))
2599                 DIE(aTHX_ PL_no_usym, "a subroutine");
2600             sym = SvPV_nomg_const(sv, len);
2601             if (PL_op->op_private & HINT_STRICT_REFS)
2602                 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2603             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2604             break;
2605         }
2606         cv = MUTABLE_CV(SvRV(sv));
2607         if (SvTYPE(cv) == SVt_PVCV)
2608             break;
2609         /* FALL THROUGH */
2610     case SVt_PVHV:
2611     case SVt_PVAV:
2612         DIE(aTHX_ "Not a CODE reference");
2613         /* This is the second most common case:  */
2614     case SVt_PVCV:
2615         cv = MUTABLE_CV(sv);
2616         break;
2617     }
2618
2619     ENTER;
2620     SAVETMPS;
2621
2622   retry:
2623     if (CvCLONE(cv) && ! CvCLONED(cv))
2624         DIE(aTHX_ "Closure prototype called");
2625     if (!CvROOT(cv) && !CvXSUB(cv)) {
2626         GV* autogv;
2627         SV* sub_name;
2628
2629         /* anonymous or undef'd function leaves us no recourse */
2630         if (CvANON(cv) || !(gv = CvGV(cv))) {
2631             if (CvNAMED(cv))
2632                 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2633                            HEKfARG(CvNAME_HEK(cv)));
2634             DIE(aTHX_ "Undefined subroutine called");
2635         }
2636
2637         /* autoloaded stub? */
2638         if (cv != GvCV(gv)) {
2639             cv = GvCV(gv);
2640         }
2641         /* should call AUTOLOAD now? */
2642         else {
2643 try_autoload:
2644             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2645                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2646             {
2647                 cv = GvCV(autogv);
2648             }
2649             else {
2650                sorry:
2651                 sub_name = sv_newmortal();
2652                 gv_efullname3(sub_name, gv, NULL);
2653                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2654             }
2655         }
2656         if (!cv)
2657             goto sorry;
2658         goto retry;
2659     }
2660
2661     gimme = GIMME_V;
2662     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2663          Perl_get_db_sub(aTHX_ &sv, cv);
2664          if (CvISXSUB(cv))
2665              PL_curcopdb = PL_curcop;
2666          if (CvLVALUE(cv)) {
2667              /* check for lsub that handles lvalue subroutines */
2668              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2669              /* if lsub not found then fall back to DB::sub */
2670              if (!cv) cv = GvCV(PL_DBsub);
2671          } else {
2672              cv = GvCV(PL_DBsub);
2673          }
2674
2675         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2676             DIE(aTHX_ "No DB::sub routine defined");
2677     }
2678
2679     if (!(CvISXSUB(cv))) {
2680         /* This path taken at least 75% of the time   */
2681         dMARK;
2682         I32 items = SP - MARK;
2683         PADLIST * const padlist = CvPADLIST(cv);
2684         PUSHBLOCK(cx, CXt_SUB, MARK);
2685         PUSHSUB(cx);
2686         cx->blk_sub.retop = PL_op->op_next;
2687         CvDEPTH(cv)++;
2688         if (CvDEPTH(cv) >= 2) {
2689             PERL_STACK_OVERFLOW_CHECK();
2690             pad_push(padlist, CvDEPTH(cv));
2691         }
2692         SAVECOMPPAD();
2693         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2694         if (hasargs) {
2695             AV *const av = MUTABLE_AV(PAD_SVl(0));
2696             if (AvREAL(av)) {
2697                 /* @_ is normally not REAL--this should only ever
2698                  * happen when DB::sub() calls things that modify @_ */
2699                 av_clear(av);
2700                 AvREAL_off(av);
2701                 AvREIFY_on(av);
2702             }
2703             cx->blk_sub.savearray = GvAV(PL_defgv);
2704             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2705             CX_CURPAD_SAVE(cx->blk_sub);
2706             cx->blk_sub.argarray = av;
2707             ++MARK;
2708
2709             if (items > AvMAX(av) + 1) {
2710                 SV **ary = AvALLOC(av);
2711                 if (AvARRAY(av) != ary) {
2712                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2713                     AvARRAY(av) = ary;
2714                 }
2715                 if (items > AvMAX(av) + 1) {
2716                     AvMAX(av) = items - 1;
2717                     Renew(ary,items,SV*);
2718                     AvALLOC(av) = ary;
2719                     AvARRAY(av) = ary;
2720                 }
2721             }
2722             Copy(MARK,AvARRAY(av),items,SV*);
2723             AvFILLp(av) = items - 1;
2724
2725             while (items--) {
2726                 if (*MARK)
2727                     SvTEMP_off(*MARK);
2728                 MARK++;
2729             }
2730         }
2731         if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2732             !CvLVALUE(cv))
2733             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2734         /* warning must come *after* we fully set up the context
2735          * stuff so that __WARN__ handlers can safely dounwind()
2736          * if they want to
2737          */
2738         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2739             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2740             sub_crush_depth(cv);
2741         RETURNOP(CvSTART(cv));
2742     }
2743     else {
2744         I32 markix = TOPMARK;
2745
2746         PUTBACK;
2747
2748         if (!hasargs) {
2749             /* Need to copy @_ to stack. Alternative may be to
2750              * switch stack to @_, and copy return values
2751              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2752             AV * const av = GvAV(PL_defgv);
2753             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2754
2755             if (items) {
2756                 /* Mark is at the end of the stack. */
2757                 EXTEND(SP, items);
2758                 Copy(AvARRAY(av), SP + 1, items, SV*);
2759                 SP += items;
2760                 PUTBACK ;
2761             }
2762         }
2763         /* We assume first XSUB in &DB::sub is the called one. */
2764         if (PL_curcopdb) {
2765             SAVEVPTR(PL_curcop);
2766             PL_curcop = PL_curcopdb;
2767             PL_curcopdb = NULL;
2768         }
2769         /* Do we need to open block here? XXXX */
2770
2771         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2772         assert(CvXSUB(cv));
2773         CvXSUB(cv)(aTHX_ cv);
2774
2775         /* Enforce some sanity in scalar context. */
2776         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2777             if (markix > PL_stack_sp - PL_stack_base)
2778                 *(PL_stack_base + markix) = &PL_sv_undef;
2779             else
2780                 *(PL_stack_base + markix) = *PL_stack_sp;
2781             PL_stack_sp = PL_stack_base + markix;
2782         }
2783         LEAVE;
2784         return NORMAL;
2785     }
2786 }
2787
2788 void
2789 Perl_sub_crush_depth(pTHX_ CV *cv)
2790 {
2791     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2792
2793     if (CvANON(cv))
2794         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2795     else {
2796         SV* const tmpstr = sv_newmortal();
2797         gv_efullname3(tmpstr, CvGV(cv), NULL);
2798         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2799                     SVfARG(tmpstr));
2800     }
2801 }
2802
2803 PP(pp_aelem)
2804 {
2805     dVAR; dSP;
2806     SV** svp;
2807     SV* const elemsv = POPs;
2808     IV elem = SvIV(elemsv);
2809     AV *const av = MUTABLE_AV(POPs);
2810     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2811     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2812     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2813     bool preeminent = TRUE;
2814     SV *sv;
2815
2816     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2817         Perl_warner(aTHX_ packWARN(WARN_MISC),
2818                     "Use of reference \"%"SVf"\" as array index",
2819                     SVfARG(elemsv));
2820     if (SvTYPE(av) != SVt_PVAV)
2821         RETPUSHUNDEF;
2822
2823     if (localizing) {
2824         MAGIC *mg;
2825         HV *stash;
2826
2827         /* If we can determine whether the element exist,
2828          * Try to preserve the existenceness of a tied array
2829          * element by using EXISTS and DELETE if possible.
2830          * Fallback to FETCH and STORE otherwise. */
2831         if (SvCANEXISTDELETE(av))
2832             preeminent = av_exists(av, elem);
2833     }
2834
2835     svp = av_fetch(av, elem, lval && !defer);
2836     if (lval) {
2837 #ifdef PERL_MALLOC_WRAP
2838          if (SvUOK(elemsv)) {
2839               const UV uv = SvUV(elemsv);
2840               elem = uv > IV_MAX ? IV_MAX : uv;
2841          }
2842          else if (SvNOK(elemsv))
2843               elem = (IV)SvNV(elemsv);
2844          if (elem > 0) {
2845               static const char oom_array_extend[] =
2846                 "Out of memory during array extend"; /* Duplicated in av.c */
2847               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2848          }
2849 #endif
2850         if (!svp || *svp == &PL_sv_undef) {
2851             SV* lv;
2852             if (!defer)
2853                 DIE(aTHX_ PL_no_aelem, elem);
2854             lv = sv_newmortal();
2855             sv_upgrade(lv, SVt_PVLV);
2856             LvTYPE(lv) = 'y';
2857             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2858             LvTARG(lv) = SvREFCNT_inc_simple(av);
2859             LvTARGOFF(lv) = elem;
2860             LvTARGLEN(lv) = 1;
2861             PUSHs(lv);
2862             RETURN;
2863         }
2864         if (localizing) {
2865             if (preeminent)
2866                 save_aelem(av, elem, svp);
2867             else
2868                 SAVEADELETE(av, elem);
2869         }
2870         else if (PL_op->op_private & OPpDEREF) {
2871             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2872             RETURN;
2873         }
2874     }
2875     sv = (svp ? *svp : &PL_sv_undef);
2876     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2877         mg_get(sv);
2878     PUSHs(sv);
2879     RETURN;
2880 }
2881
2882 SV*
2883 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2884 {
2885     PERL_ARGS_ASSERT_VIVIFY_REF;
2886
2887     SvGETMAGIC(sv);
2888     if (!SvOK(sv)) {
2889         if (SvREADONLY(sv))
2890             Perl_croak_no_modify(aTHX);
2891         prepare_SV_for_RV(sv);
2892         switch (to_what) {
2893         case OPpDEREF_SV:
2894             SvRV_set(sv, newSV(0));
2895             break;
2896         case OPpDEREF_AV:
2897             SvRV_set(sv, MUTABLE_SV(newAV()));
2898             break;
2899         case OPpDEREF_HV:
2900             SvRV_set(sv, MUTABLE_SV(newHV()));
2901             break;
2902         }
2903         SvROK_on(sv);
2904         SvSETMAGIC(sv);
2905         SvGETMAGIC(sv);
2906     }
2907     if (SvGMAGICAL(sv)) {
2908         /* copy the sv without magic to prevent magic from being
2909            executed twice */
2910         SV* msv = sv_newmortal();
2911         sv_setsv_nomg(msv, sv);
2912         return msv;
2913     }
2914     return sv;
2915 }
2916
2917 PP(pp_method)
2918 {
2919     dVAR; dSP;
2920     SV* const sv = TOPs;
2921
2922     if (SvROK(sv)) {
2923         SV* const rsv = SvRV(sv);
2924         if (SvTYPE(rsv) == SVt_PVCV) {
2925             SETs(rsv);
2926             RETURN;
2927         }
2928     }
2929
2930     SETs(method_common(sv, NULL));
2931     RETURN;
2932 }
2933
2934 PP(pp_method_named)
2935 {
2936     dVAR; dSP;
2937     SV* const sv = cSVOP_sv;
2938     U32 hash = SvSHARED_HASH(sv);
2939
2940     XPUSHs(method_common(sv, &hash));
2941     RETURN;
2942 }
2943
2944 STATIC SV *
2945 S_method_common(pTHX_ SV* meth, U32* hashp)
2946 {
2947     dVAR;
2948     SV* ob;
2949     GV* gv;
2950     HV* stash;
2951     SV *packsv = NULL;
2952     SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2953         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2954                             "package or object reference", SVfARG(meth)),
2955            (SV *)NULL)
2956         : *(PL_stack_base + TOPMARK + 1);
2957
2958     PERL_ARGS_ASSERT_METHOD_COMMON;
2959
2960     if (!sv)
2961        undefined:
2962         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2963                    SVfARG(meth));
2964
2965     SvGETMAGIC(sv);
2966     if (SvROK(sv))
2967         ob = MUTABLE_SV(SvRV(sv));
2968     else if (!SvOK(sv)) goto undefined;
2969     else {
2970         /* this isn't a reference */
2971         GV* iogv;
2972         STRLEN packlen;
2973         const char * const packname = SvPV_nomg_const(sv, packlen);
2974         bool packname_is_utf8 = FALSE;
2975         const HE* const he =
2976             (const HE *)hv_common_key_len(
2977               PL_stashcache, packname,
2978               packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2979             );
2980
2981         if (he) {
2982             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2983             goto fetch;
2984         }
2985
2986         if (!(iogv = gv_fetchpvn_flags(
2987                 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2988              )) ||
2989             !(ob=MUTABLE_SV(GvIO(iogv))))
2990         {
2991             /* this isn't the name of a filehandle either */
2992             if (!packlen)
2993             {
2994                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2995                                  "without a package or object reference",
2996                                   SVfARG(meth));
2997             }
2998             /* assume it's a package name */
2999             stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3000             if (!stash)
3001                 packsv = sv;
3002             else {
3003                 SV* const ref = newSViv(PTR2IV(stash));
3004                 (void)hv_store(PL_stashcache, packname,
3005                                 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3006             }
3007             goto fetch;
3008         }
3009         /* it _is_ a filehandle name -- replace with a reference */
3010         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3011     }
3012
3013     /* if we got here, ob should be a reference or a glob */
3014     if (!ob || !(SvOBJECT(ob)
3015                  || (SvTYPE(ob) == SVt_PVGV
3016                      && isGV_with_GP(ob)
3017                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3018                      && SvOBJECT(ob))))
3019     {
3020         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3021                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3022                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3023                                         : meth));
3024     }
3025
3026     stash = SvSTASH(ob);
3027
3028   fetch:
3029     /* NOTE: stash may be null, hope hv_fetch_ent and
3030        gv_fetchmethod can cope (it seems they can) */
3031
3032     /* shortcut for simple names */
3033     if (hashp) {
3034         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3035         if (he) {
3036             gv = MUTABLE_GV(HeVAL(he));
3037             if (isGV(gv) && GvCV(gv) &&
3038                 (!GvCVGEN(gv) || GvCVGEN(gv)
3039                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3040                 return MUTABLE_SV(GvCV(gv));
3041         }
3042     }
3043
3044     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3045                                      meth, GV_AUTOLOAD | GV_CROAK);
3046
3047     assert(gv);
3048
3049     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3050 }
3051
3052 /*
3053  * Local variables:
3054  * c-indentation-style: bsd
3055  * c-basic-offset: 4
3056  * indent-tabs-mode: nil
3057  * End:
3058  *
3059  * ex: set ts=8 sts=4 sw=4 et:
3060  */