pp_hot.c

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