pp_hot.c

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