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         /* Will be used to set PL_tainting below */
1095         UV tmp_uid  = PerlProc_getuid();
1096         UV tmp_euid = PerlProc_geteuid();
1097         UV tmp_gid  = PerlProc_getgid();
1098         UV tmp_egid = PerlProc_getegid();
1099
1100         if (PL_delaymagic & DM_UID) {
1101 #ifdef HAS_SETRESUID
1102             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1103                             (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1104                             (Uid_t)-1);
1105 #else
1106 #  ifdef HAS_SETREUID
1107             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1108                            (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1109 #  else
1110 #    ifdef HAS_SETRUID
1111             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1112                 (void)setruid(PL_delaymagic_uid);
1113                 PL_delaymagic &= ~DM_RUID;
1114             }
1115 #    endif /* HAS_SETRUID */
1116 #    ifdef HAS_SETEUID
1117             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1118                 (void)seteuid(PL_delaymagic_euid);
1119                 PL_delaymagic &= ~DM_EUID;
1120             }
1121 #    endif /* HAS_SETEUID */
1122             if (PL_delaymagic & DM_UID) {
1123                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1124                     DIE(aTHX_ "No setreuid available");
1125                 (void)PerlProc_setuid(PL_delaymagic_uid);
1126             }
1127 #  endif /* HAS_SETREUID */
1128 #endif /* HAS_SETRESUID */
1129             tmp_uid  = PerlProc_getuid();
1130             tmp_euid = PerlProc_geteuid();
1131         }
1132         if (PL_delaymagic & DM_GID) {
1133 #ifdef HAS_SETRESGID
1134             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1135                             (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1136                             (Gid_t)-1);
1137 #else
1138 #  ifdef HAS_SETREGID
1139             (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1140                            (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1141 #  else
1142 #    ifdef HAS_SETRGID
1143             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1144                 (void)setrgid(PL_delaymagic_gid);
1145                 PL_delaymagic &= ~DM_RGID;
1146             }
1147 #    endif /* HAS_SETRGID */
1148 #    ifdef HAS_SETEGID
1149             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1150                 (void)setegid(PL_delaymagic_egid);
1151                 PL_delaymagic &= ~DM_EGID;
1152             }
1153 #    endif /* HAS_SETEGID */
1154             if (PL_delaymagic & DM_GID) {
1155                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1156                     DIE(aTHX_ "No setregid available");
1157                 (void)PerlProc_setgid(PL_delaymagic_gid);
1158             }
1159 #  endif /* HAS_SETREGID */
1160 #endif /* HAS_SETRESGID */
1161             tmp_gid  = PerlProc_getgid();
1162             tmp_egid = PerlProc_getegid();
1163         }
1164         PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid));
1165     }
1166     PL_delaymagic = 0;
1167
1168     if (gimme == G_VOID)
1169         SP = firstrelem - 1;
1170     else if (gimme == G_SCALAR) {
1171         dTARGET;
1172         SP = firstrelem;
1173         SETi(lastrelem - firstrelem + 1 - duplicates);
1174     }
1175     else {
1176         if (ary)
1177             SP = lastrelem;
1178         else if (hash) {
1179             if (duplicates) {
1180                 /* at this point we have removed the duplicate key/value
1181                  * pairs from the stack, but the remaining values may be
1182                  * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1183                  * the (a 2), but the stack now probably contains
1184                  * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1185                  * obliterates the earlier key. So refresh all values. */
1186                 lastrelem -= duplicates;
1187                 relem = firsthashrelem;
1188                 while (relem < lastrelem) {
1189                     HE *he;
1190                     sv = *relem++;
1191                     he = hv_fetch_ent(hash, sv, 0, 0);
1192                     *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1193                 }
1194             }
1195             SP = lastrelem;
1196         }
1197         else
1198             SP = firstrelem + (lastlelem - firstlelem);
1199         lelem = firstlelem + (relem - firstrelem);
1200         while (relem <= SP)
1201             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1202     }
1203
1204     RETURN;
1205 }
1206
1207 PP(pp_qr)
1208 {
1209     dVAR; dSP;
1210     register PMOP * const pm = cPMOP;
1211     REGEXP * rx = PM_GETRE(pm);
1212     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1213     SV * const rv = sv_newmortal();
1214
1215     SvUPGRADE(rv, SVt_IV);
1216     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1217        loathe to use it here, but it seems to be the right fix. Or close.
1218        The key part appears to be that it's essential for pp_qr to return a new
1219        object (SV), which implies that there needs to be an effective way to
1220        generate a new SV from the existing SV that is pre-compiled in the
1221        optree.  */
1222     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1223     SvROK_on(rv);
1224
1225     if (pkg) {
1226         HV *const stash = gv_stashsv(pkg, GV_ADD);
1227         SvREFCNT_dec(pkg);
1228         (void)sv_bless(rv, stash);
1229     }
1230
1231     if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1232         SvTAINTED_on(rv);
1233         SvTAINTED_on(SvRV(rv));
1234     }
1235     XPUSHs(rv);
1236     RETURN;
1237 }
1238
1239 PP(pp_match)
1240 {
1241     dVAR; dSP; dTARG;
1242     register PMOP *pm = cPMOP;
1243     PMOP *dynpm = pm;
1244     register const char *t;
1245     register const char *s;
1246     const char *strend;
1247     I32 global;
1248     U8 r_flags = REXEC_CHECKED;
1249     const char *truebase;                       /* Start of string  */
1250     register REGEXP *rx = PM_GETRE(pm);
1251     bool rxtainted;
1252     const I32 gimme = GIMME;
1253     STRLEN len;
1254     I32 minmatch = 0;
1255     const I32 oldsave = PL_savestack_ix;
1256     I32 update_minmatch = 1;
1257     I32 had_zerolen = 0;
1258     U32 gpos = 0;
1259
1260     if (PL_op->op_flags & OPf_STACKED)
1261         TARG = POPs;
1262     else if (PL_op->op_private & OPpTARGET_MY)
1263         GETTARGET;
1264     else {
1265         TARG = DEFSV;
1266         EXTEND(SP,1);
1267     }
1268
1269     PUTBACK;                            /* EVAL blocks need stack_sp. */
1270     /* Skip get-magic if this is a qr// clone, because regcomp has
1271        already done it. */
1272     s = ((struct regexp *)SvANY(rx))->mother_re
1273          ? SvPV_nomg_const(TARG, len)
1274          : SvPV_const(TARG, len);
1275     if (!s)
1276         DIE(aTHX_ "panic: pp_match");
1277     strend = s + len;
1278     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1279                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1280     TAINT_NOT;
1281
1282     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1283
1284     /* PMdf_USED is set after a ?? matches once */
1285     if (
1286 #ifdef USE_ITHREADS
1287         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1288 #else
1289         pm->op_pmflags & PMf_USED
1290 #endif
1291     ) {
1292       failure:
1293         if (gimme == G_ARRAY)
1294             RETURN;
1295         RETPUSHNO;
1296     }
1297
1298
1299
1300     /* empty pattern special-cased to use last successful pattern if possible */
1301     if (!RX_PRELEN(rx) && PL_curpm) {
1302         pm = PL_curpm;
1303         rx = PM_GETRE(pm);
1304     }
1305
1306     if (RX_MINLEN(rx) > (I32)len)
1307         goto failure;
1308
1309     truebase = t = s;
1310
1311     /* XXXX What part of this is needed with true \G-support? */
1312     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1313         RX_OFFS(rx)[0].start = -1;
1314         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1315             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1316             if (mg && mg->mg_len >= 0) {
1317                 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1318                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1319                 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1320                     r_flags |= REXEC_IGNOREPOS;
1321                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1322                 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1323                     gpos = mg->mg_len;
1324                 else
1325                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1326                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1327                 update_minmatch = 0;
1328             }
1329         }
1330     }
1331     /* XXX: comment out !global get safe $1 vars after a
1332        match, BUT be aware that this leads to dramatic slowdowns on
1333        /g matches against large strings.  So far a solution to this problem
1334        appears to be quite tricky.
1335        Test for the unsafe vars are TODO for now. */
1336     if (       (!global && RX_NPARENS(rx))
1337             || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1338             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1339         r_flags |= REXEC_COPY_STR;
1340
1341   play_it_again:
1342     if (global && RX_OFFS(rx)[0].start != -1) {
1343         t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1344         if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1345             goto nope;
1346         if (update_minmatch++)
1347             minmatch = had_zerolen;
1348     }
1349     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1350         DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1351         /* FIXME - can PL_bostr be made const char *?  */
1352         PL_bostr = (char *)truebase;
1353         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1354
1355         if (!s)
1356             goto nope;
1357         if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1358              && !PL_sawampersand
1359              && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1360              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1361             goto yup;
1362     }
1363     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1364                      minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1365         goto ret_no;
1366
1367     PL_curpm = pm;
1368     if (dynpm->op_pmflags & PMf_ONCE) {
1369 #ifdef USE_ITHREADS
1370         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1371 #else
1372         dynpm->op_pmflags |= PMf_USED;
1373 #endif
1374     }
1375
1376   gotcha:
1377     if (rxtainted)
1378         RX_MATCH_TAINTED_on(rx);
1379     TAINT_IF(RX_MATCH_TAINTED(rx));
1380     if (gimme == G_ARRAY) {
1381         const I32 nparens = RX_NPARENS(rx);
1382         I32 i = (global && !nparens) ? 1 : 0;
1383
1384         SPAGAIN;                        /* EVAL blocks could move the stack. */
1385         EXTEND(SP, nparens + i);
1386         EXTEND_MORTAL(nparens + i);
1387         for (i = !i; i <= nparens; i++) {
1388             PUSHs(sv_newmortal());
1389             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1390                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1391                 s = RX_OFFS(rx)[i].start + truebase;
1392                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1393                     len < 0 || len > strend - s)
1394                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1395                         "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1396                         (long) i, (long) RX_OFFS(rx)[i].start,
1397                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1398                 sv_setpvn(*SP, s, len);
1399                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1400                     SvUTF8_on(*SP);
1401             }
1402         }
1403         if (global) {
1404             if (dynpm->op_pmflags & PMf_CONTINUE) {
1405                 MAGIC* mg = NULL;
1406                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1407                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1408                 if (!mg) {
1409 #ifdef PERL_OLD_COPY_ON_WRITE
1410                     if (SvIsCOW(TARG))
1411                         sv_force_normal_flags(TARG, 0);
1412 #endif
1413                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1414                                      &PL_vtbl_mglob, NULL, 0);
1415                 }
1416                 if (RX_OFFS(rx)[0].start != -1) {
1417                     mg->mg_len = RX_OFFS(rx)[0].end;
1418                     if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1419                         mg->mg_flags |= MGf_MINMATCH;
1420                     else
1421                         mg->mg_flags &= ~MGf_MINMATCH;
1422                 }
1423             }
1424             had_zerolen = (RX_OFFS(rx)[0].start != -1
1425                            && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1426                                == (UV)RX_OFFS(rx)[0].end));
1427             PUTBACK;                    /* EVAL blocks may use stack */
1428             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1429             goto play_it_again;
1430         }
1431         else if (!nparens)
1432             XPUSHs(&PL_sv_yes);
1433         LEAVE_SCOPE(oldsave);
1434         RETURN;
1435     }
1436     else {
1437         if (global) {
1438             MAGIC* mg;
1439             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1440                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1441             else
1442                 mg = NULL;
1443             if (!mg) {
1444 #ifdef PERL_OLD_COPY_ON_WRITE
1445                 if (SvIsCOW(TARG))
1446                     sv_force_normal_flags(TARG, 0);
1447 #endif
1448                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1449                                  &PL_vtbl_mglob, NULL, 0);
1450             }
1451             if (RX_OFFS(rx)[0].start != -1) {
1452                 mg->mg_len = RX_OFFS(rx)[0].end;
1453                 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1454                     mg->mg_flags |= MGf_MINMATCH;
1455                 else
1456                     mg->mg_flags &= ~MGf_MINMATCH;
1457             }
1458         }
1459         LEAVE_SCOPE(oldsave);
1460         RETPUSHYES;
1461     }
1462
1463 yup:                                    /* Confirmed by INTUIT */
1464     if (rxtainted)
1465         RX_MATCH_TAINTED_on(rx);
1466     TAINT_IF(RX_MATCH_TAINTED(rx));
1467     PL_curpm = pm;
1468     if (dynpm->op_pmflags & PMf_ONCE) {
1469 #ifdef USE_ITHREADS
1470         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1471 #else
1472         dynpm->op_pmflags |= PMf_USED;
1473 #endif
1474     }
1475     if (RX_MATCH_COPIED(rx))
1476         Safefree(RX_SUBBEG(rx));
1477     RX_MATCH_COPIED_off(rx);
1478     RX_SUBBEG(rx) = NULL;
1479     if (global) {
1480         /* FIXME - should rx->subbeg be const char *?  */
1481         RX_SUBBEG(rx) = (char *) truebase;
1482         RX_OFFS(rx)[0].start = s - truebase;
1483         if (RX_MATCH_UTF8(rx)) {
1484             char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1485             RX_OFFS(rx)[0].end = t - truebase;
1486         }
1487         else {
1488             RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1489         }
1490         RX_SUBLEN(rx) = strend - truebase;
1491         goto gotcha;
1492     }
1493     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1494         I32 off;
1495 #ifdef PERL_OLD_COPY_ON_WRITE
1496         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1497             if (DEBUG_C_TEST) {
1498                 PerlIO_printf(Perl_debug_log,
1499                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1500                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1501                               (int)(t-truebase));
1502             }
1503             RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1504             RX_SUBBEG(rx)
1505                 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1506             assert (SvPOKp(RX_SAVED_COPY(rx)));
1507         } else
1508 #endif
1509         {
1510
1511             RX_SUBBEG(rx) = savepvn(t, strend - t);
1512 #ifdef PERL_OLD_COPY_ON_WRITE
1513             RX_SAVED_COPY(rx) = NULL;
1514 #endif
1515         }
1516         RX_SUBLEN(rx) = strend - t;
1517         RX_MATCH_COPIED_on(rx);
1518         off = RX_OFFS(rx)[0].start = s - t;
1519         RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1520     }
1521     else {                      /* startp/endp are used by @- @+. */
1522         RX_OFFS(rx)[0].start = s - truebase;
1523         RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1524     }
1525     /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1526        -dmq */
1527     RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;      /* used by @-, @+, and $^N */
1528     LEAVE_SCOPE(oldsave);
1529     RETPUSHYES;
1530
1531 nope:
1532 ret_no:
1533     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1534         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1535             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1536             if (mg)
1537                 mg->mg_len = -1;
1538         }
1539     }
1540     LEAVE_SCOPE(oldsave);
1541     if (gimme == G_ARRAY)
1542         RETURN;
1543     RETPUSHNO;
1544 }
1545
1546 OP *
1547 Perl_do_readline(pTHX)
1548 {
1549     dVAR; dSP; dTARGETSTACKED;
1550     register SV *sv;
1551     STRLEN tmplen = 0;
1552     STRLEN offset;
1553     PerlIO *fp;
1554     register IO * const io = GvIO(PL_last_in_gv);
1555     register const I32 type = PL_op->op_type;
1556     const I32 gimme = GIMME_V;
1557
1558     if (io) {
1559         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1560         if (mg) {
1561             Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1562             if (gimme == G_SCALAR) {
1563                 SPAGAIN;
1564                 SvSetSV_nosteal(TARG, TOPs);
1565                 SETTARG;
1566             }
1567             return NORMAL;
1568         }
1569     }
1570     fp = NULL;
1571     if (io) {
1572         fp = IoIFP(io);
1573         if (!fp) {
1574             if (IoFLAGS(io) & IOf_ARGV) {
1575                 if (IoFLAGS(io) & IOf_START) {
1576                     IoLINES(io) = 0;
1577                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1578                         IoFLAGS(io) &= ~IOf_START;
1579                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1580                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1581                         SvSETMAGIC(GvSV(PL_last_in_gv));
1582                         fp = IoIFP(io);
1583                         goto have_fp;
1584                     }
1585                 }
1586                 fp = nextargv(PL_last_in_gv);
1587                 if (!fp) { /* Note: fp != IoIFP(io) */
1588                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1589                 }
1590             }
1591             else if (type == OP_GLOB)
1592                 fp = Perl_start_glob(aTHX_ POPs, io);
1593         }
1594         else if (type == OP_GLOB)
1595             SP--;
1596         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1597             report_wrongway_fh(PL_last_in_gv, '>');
1598         }
1599     }
1600     if (!fp) {
1601         if ((!io || !(IoFLAGS(io) & IOf_START))
1602             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1603         {
1604             if (type == OP_GLOB)
1605                 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
1606                             "glob failed (can't start child: %s)",
1607                             Strerror(errno));
1608             else
1609                 report_evil_fh(PL_last_in_gv);
1610         }
1611         if (gimme == G_SCALAR) {
1612             /* undef TARG, and push that undefined value */
1613             if (type != OP_RCATLINE) {
1614                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1615                 SvOK_off(TARG);
1616             }
1617             PUSHTARG;
1618         }
1619         RETURN;
1620     }
1621   have_fp:
1622     if (gimme == G_SCALAR) {
1623         sv = TARG;
1624         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1625             mg_get(sv);
1626         if (SvROK(sv)) {
1627             if (type == OP_RCATLINE)
1628                 SvPV_force_nomg_nolen(sv);
1629             else
1630                 sv_unref(sv);
1631         }
1632         else if (isGV_with_GP(sv)) {
1633             SvPV_force_nomg_nolen(sv);
1634         }
1635         SvUPGRADE(sv, SVt_PV);
1636         tmplen = SvLEN(sv);     /* remember if already alloced */
1637         if (!tmplen && !SvREADONLY(sv)) {
1638             /* try short-buffering it. Please update t/op/readline.t
1639              * if you change the growth length.
1640              */
1641             Sv_Grow(sv, 80);
1642         }
1643         offset = 0;
1644         if (type == OP_RCATLINE && SvOK(sv)) {
1645             if (!SvPOK(sv)) {
1646                 SvPV_force_nomg_nolen(sv);
1647             }
1648             offset = SvCUR(sv);
1649         }
1650     }
1651     else {
1652         sv = sv_2mortal(newSV(80));
1653         offset = 0;
1654     }
1655
1656     /* This should not be marked tainted if the fp is marked clean */
1657 #define MAYBE_TAINT_LINE(io, sv) \
1658     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1659         TAINT;                          \
1660         SvTAINTED_on(sv);               \
1661     }
1662
1663 /* delay EOF state for a snarfed empty file */
1664 #define SNARF_EOF(gimme,rs,io,sv) \
1665     (gimme != G_SCALAR || SvCUR(sv)                                     \
1666      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1667
1668     for (;;) {
1669         PUTBACK;
1670         if (!sv_gets(sv, fp, offset)
1671             && (type == OP_GLOB
1672                 || SNARF_EOF(gimme, PL_rs, io, sv)
1673                 || PerlIO_error(fp)))
1674         {
1675             PerlIO_clearerr(fp);
1676             if (IoFLAGS(io) & IOf_ARGV) {
1677                 fp = nextargv(PL_last_in_gv);
1678                 if (fp)
1679                     continue;
1680                 (void)do_close(PL_last_in_gv, FALSE);
1681             }
1682             else if (type == OP_GLOB) {
1683                 if (!do_close(PL_last_in_gv, FALSE)) {
1684                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1685                                    "glob failed (child exited with status %d%s)",
1686                                    (int)(STATUS_CURRENT >> 8),
1687                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1688                 }
1689             }
1690             if (gimme == G_SCALAR) {
1691                 if (type != OP_RCATLINE) {
1692                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1693                     SvOK_off(TARG);
1694                 }
1695                 SPAGAIN;
1696                 PUSHTARG;
1697             }
1698             MAYBE_TAINT_LINE(io, sv);
1699             RETURN;
1700         }
1701         MAYBE_TAINT_LINE(io, sv);
1702         IoLINES(io)++;
1703         IoFLAGS(io) |= IOf_NOLINE;
1704         SvSETMAGIC(sv);
1705         SPAGAIN;
1706         XPUSHs(sv);
1707         if (type == OP_GLOB) {
1708             const char *t1;
1709
1710             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1711                 char * const tmps = SvEND(sv) - 1;
1712                 if (*tmps == *SvPVX_const(PL_rs)) {
1713                     *tmps = '\0';
1714                     SvCUR_set(sv, SvCUR(sv) - 1);
1715                 }
1716             }
1717             for (t1 = SvPVX_const(sv); *t1; t1++)
1718                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1719                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1720                         break;
1721             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1722                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1723                 continue;
1724             }
1725         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1726              if (ckWARN(WARN_UTF8)) {
1727                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1728                 const STRLEN len = SvCUR(sv) - offset;
1729                 const U8 *f;
1730
1731                 if (!is_utf8_string_loc(s, len, &f))
1732                     /* Emulate :encoding(utf8) warning in the same case. */
1733                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1734                                 "utf8 \"\\x%02X\" does not map to Unicode",
1735                                 f < (U8*)SvEND(sv) ? *f : 0);
1736              }
1737         }
1738         if (gimme == G_ARRAY) {
1739             if (SvLEN(sv) - SvCUR(sv) > 20) {
1740                 SvPV_shrink_to_cur(sv);
1741             }
1742             sv = sv_2mortal(newSV(80));
1743             continue;
1744         }
1745         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1746             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1747             const STRLEN new_len
1748                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1749             SvPV_renew(sv, new_len);
1750         }
1751         RETURN;
1752     }
1753 }
1754
1755 PP(pp_helem)
1756 {
1757     dVAR; dSP;
1758     HE* he;
1759     SV **svp;
1760     SV * const keysv = POPs;
1761     HV * const hv = MUTABLE_HV(POPs);
1762     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1763     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1764     SV *sv;
1765     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1766     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1767     bool preeminent = TRUE;
1768
1769     if (SvTYPE(hv) != SVt_PVHV)
1770         RETPUSHUNDEF;
1771
1772     if (localizing) {
1773         MAGIC *mg;
1774         HV *stash;
1775
1776         /* If we can determine whether the element exist,
1777          * Try to preserve the existenceness of a tied hash
1778          * element by using EXISTS and DELETE if possible.
1779          * Fallback to FETCH and STORE otherwise. */
1780         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1781             preeminent = hv_exists_ent(hv, keysv, 0);
1782     }
1783
1784     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1785     svp = he ? &HeVAL(he) : NULL;
1786     if (lval) {
1787         if (!svp || !*svp || *svp == &PL_sv_undef) {
1788             SV* lv;
1789             SV* key2;
1790             if (!defer) {
1791                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1792             }
1793             lv = sv_newmortal();
1794             sv_upgrade(lv, SVt_PVLV);
1795             LvTYPE(lv) = 'y';
1796             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1797             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1798             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1799             LvTARGLEN(lv) = 1;
1800             PUSHs(lv);
1801             RETURN;
1802         }
1803         if (localizing) {
1804             if (HvNAME_get(hv) && isGV(*svp))
1805                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1806             else if (preeminent)
1807                 save_helem_flags(hv, keysv, svp,
1808                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1809             else
1810                 SAVEHDELETE(hv, keysv);
1811         }
1812         else if (PL_op->op_private & OPpDEREF) {
1813             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1814             RETURN;
1815         }
1816     }
1817     sv = (svp && *svp ? *svp : &PL_sv_undef);
1818     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1819      * was to make C<local $tied{foo} = $tied{foo}> possible.
1820      * However, it seems no longer to be needed for that purpose, and
1821      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1822      * would loop endlessly since the pos magic is getting set on the
1823      * mortal copy and lost. However, the copy has the effect of
1824      * triggering the get magic, and losing it altogether made things like
1825      * c<$tied{foo};> in void context no longer do get magic, which some
1826      * code relied on. Also, delayed triggering of magic on @+ and friends
1827      * meant the original regex may be out of scope by now. So as a
1828      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1829      * being called too many times). */
1830     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1831         mg_get(sv);
1832     PUSHs(sv);
1833     RETURN;
1834 }
1835
1836 PP(pp_iter)
1837 {
1838     dVAR; dSP;
1839     register PERL_CONTEXT *cx;
1840     SV *sv, *oldsv;
1841     SV **itersvp;
1842     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1843     bool av_is_stack = FALSE;
1844
1845     EXTEND(SP, 1);
1846     cx = &cxstack[cxstack_ix];
1847     if (!CxTYPE_is_LOOP(cx))
1848         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1849
1850     itersvp = CxITERVAR(cx);
1851     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1852             /* string increment */
1853             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1854             SV *end = cx->blk_loop.state_u.lazysv.end;
1855             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1856                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1857             STRLEN maxlen = 0;
1858             const char *max = SvPV_const(end, maxlen);
1859             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1860                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1861                     /* safe to reuse old SV */
1862                     sv_setsv(*itersvp, cur);
1863                 }
1864                 else
1865                 {
1866                     /* we need a fresh SV every time so that loop body sees a
1867                      * completely new SV for closures/references to work as
1868                      * they used to */
1869                     oldsv = *itersvp;
1870                     *itersvp = newSVsv(cur);
1871                     SvREFCNT_dec(oldsv);
1872                 }
1873                 if (strEQ(SvPVX_const(cur), max))
1874                     sv_setiv(cur, 0); /* terminate next time */
1875                 else
1876                     sv_inc(cur);
1877                 RETPUSHYES;
1878             }
1879             RETPUSHNO;
1880     }
1881     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1882         /* integer increment */
1883         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1884             RETPUSHNO;
1885
1886         /* don't risk potential race */
1887         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1888             /* safe to reuse old SV */
1889             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1890         }
1891         else
1892         {
1893             /* we need a fresh SV every time so that loop body sees a
1894              * completely new SV for closures/references to work as they
1895              * used to */
1896             oldsv = *itersvp;
1897             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1898             SvREFCNT_dec(oldsv);
1899         }
1900
1901         /* Handle end of range at IV_MAX */
1902         if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1903             (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1904         {
1905             cx->blk_loop.state_u.lazyiv.cur++;
1906             cx->blk_loop.state_u.lazyiv.end++;
1907         }
1908
1909         RETPUSHYES;
1910     }
1911
1912     /* iterate array */
1913     assert(CxTYPE(cx) == CXt_LOOP_FOR);
1914     av = cx->blk_loop.state_u.ary.ary;
1915     if (!av) {
1916         av_is_stack = TRUE;
1917         av = PL_curstack;
1918     }
1919     if (PL_op->op_private & OPpITER_REVERSED) {
1920         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1921                                     ? cx->blk_loop.resetsp + 1 : 0))
1922             RETPUSHNO;
1923
1924         if (SvMAGICAL(av) || AvREIFY(av)) {
1925             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1926             sv = svp ? *svp : NULL;
1927         }
1928         else {
1929             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1930         }
1931     }
1932     else {
1933         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1934                                     AvFILL(av)))
1935             RETPUSHNO;
1936
1937         if (SvMAGICAL(av) || AvREIFY(av)) {
1938             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1939             sv = svp ? *svp : NULL;
1940         }
1941         else {
1942             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1943         }
1944     }
1945
1946     if (sv && SvIS_FREED(sv)) {
1947         *itersvp = NULL;
1948         Perl_croak(aTHX_ "Use of freed value in iteration");
1949     }
1950
1951     if (sv) {
1952         SvTEMP_off(sv);
1953         SvREFCNT_inc_simple_void_NN(sv);
1954     }
1955     else
1956         sv = &PL_sv_undef;
1957     if (!av_is_stack && sv == &PL_sv_undef) {
1958         SV *lv = newSV_type(SVt_PVLV);
1959         LvTYPE(lv) = 'y';
1960         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1961         LvTARG(lv) = SvREFCNT_inc_simple(av);
1962         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1963         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1964         sv = lv;
1965     }
1966
1967     oldsv = *itersvp;
1968     *itersvp = sv;
1969     SvREFCNT_dec(oldsv);
1970
1971     RETPUSHYES;
1972 }
1973
1974 /*
1975 A description of how taint works in pattern matching and substitution.
1976
1977 While the pattern is being assembled/concatenated and then compiled,
1978 PL_tainted will get set if any component of the pattern is tainted, e.g.
1979 /.*$tainted/.  At the end of pattern compilation, the RXf_TAINTED flag
1980 is set on the pattern if PL_tainted is set.
1981
1982 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1983 the pattern is marked as tainted. This means that subsequent usage, such
1984 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1985
1986 During execution of a pattern, locale-variant ops such as ALNUML set the
1987 local flag RF_tainted. At the end of execution, the engine sets the
1988 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1989 otherwise.
1990
1991 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1992 of $1 et al to indicate whether the returned value should be tainted.
1993 It is the responsibility of the caller of the pattern (i.e. pp_match,
1994 pp_subst etc) to set this flag for any other circumstances where $1 needs
1995 to be tainted.
1996
1997 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1998
1999 There are three possible sources of taint
2000     * the source string
2001     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2002     * the replacement string (or expression under /e)
2003
2004 There are four destinations of taint and they are affected by the sources
2005 according to the rules below:
2006
2007     * the return value (not including /r):
2008         tainted by the source string and pattern, but only for the
2009         number-of-iterations case; boolean returns aren't tainted;
2010     * the modified string (or modified copy under /r):
2011         tainted by the source string, pattern, and replacement strings;
2012     * $1 et al:
2013         tainted by the pattern, and under 'use re "taint"', by the source
2014         string too;
2015     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2016         should always be unset before executing subsequent code.
2017
2018 The overall action of pp_subst is:
2019
2020     * at the start, set bits in rxtainted indicating the taint status of
2021         the various sources.
2022
2023     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2024         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2025         pattern has subsequently become tainted via locale ops.
2026
2027     * If control is being passed to pp_substcont to execute a /e block,
2028         save rxtainted in the CXt_SUBST block, for future use by
2029         pp_substcont.
2030
2031     * Whenever control is being returned to perl code (either by falling
2032         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2033         use the flag bits in rxtainted to make all the appropriate types of
2034         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2035         et al will appear tainted.
2036
2037 pp_match is just a simpler version of the above.
2038
2039 */
2040
2041 PP(pp_subst)
2042 {
2043     dVAR; dSP; dTARG;
2044     register PMOP *pm = cPMOP;
2045     PMOP *rpm = pm;
2046     register char *s;
2047     char *strend;
2048     register char *m;
2049     const char *c;
2050     register char *d;
2051     STRLEN clen;
2052     I32 iters = 0;
2053     I32 maxiters;
2054     register I32 i;
2055     bool once;
2056     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2057                         See "how taint works" above */
2058     char *orig;
2059     U8 r_flags;
2060     register REGEXP *rx = PM_GETRE(pm);
2061     STRLEN len;
2062     int force_on_match = 0;
2063     const I32 oldsave = PL_savestack_ix;
2064     STRLEN slen;
2065     bool doutf8 = FALSE;
2066 #ifdef PERL_OLD_COPY_ON_WRITE
2067     bool is_cow;
2068 #endif
2069     SV *nsv = NULL;
2070     /* known replacement string? */
2071     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2072
2073     PERL_ASYNC_CHECK();
2074
2075     if (PL_op->op_flags & OPf_STACKED)
2076         TARG = POPs;
2077     else if (PL_op->op_private & OPpTARGET_MY)
2078         GETTARGET;
2079     else {
2080         TARG = DEFSV;
2081         EXTEND(SP,1);
2082     }
2083
2084 #ifdef PERL_OLD_COPY_ON_WRITE
2085     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2086        because they make integers such as 256 "false".  */
2087     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2088 #else
2089     if (SvIsCOW(TARG))
2090         sv_force_normal_flags(TARG,0);
2091 #endif
2092     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2093 #ifdef PERL_OLD_COPY_ON_WRITE
2094         && !is_cow
2095 #endif
2096         && (SvREADONLY(TARG)
2097             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2098                   || SvTYPE(TARG) > SVt_PVLV)
2099                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2100         Perl_croak_no_modify(aTHX);
2101     PUTBACK;
2102
2103   setup_match:
2104     s = SvPV_mutable(TARG, len);
2105     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2106         force_on_match = 1;
2107
2108     /* only replace once? */
2109     once = !(rpm->op_pmflags & PMf_GLOBAL);
2110
2111     /* See "how taint works" above */
2112     if (PL_tainting) {
2113         rxtainted  = (
2114             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2115           | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2116           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2117           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2118                 ? SUBST_TAINT_BOOLRET : 0));
2119         TAINT_NOT;
2120     }
2121
2122     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2123
2124   force_it:
2125     if (!pm || !s)
2126         DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2127
2128     strend = s + len;
2129     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2130     maxiters = 2 * slen + 10;   /* We can match twice at each
2131                                    position, once with zero-length,
2132                                    second time with non-zero. */
2133
2134     if (!RX_PRELEN(rx) && PL_curpm) {
2135         pm = PL_curpm;
2136         rx = PM_GETRE(pm);
2137     }
2138     r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2139             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2140                ? REXEC_COPY_STR : 0;
2141
2142     orig = m = s;
2143     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2144         PL_bostr = orig;
2145         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2146
2147         if (!s)
2148             goto ret_no;
2149         /* How to do it in subst? */
2150 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2151              && !PL_sawampersand
2152              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
2153             goto yup;
2154 */
2155     }
2156
2157     if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2158                          r_flags | REXEC_CHECKED))
2159     {
2160       ret_no:
2161         SPAGAIN;
2162         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2163         LEAVE_SCOPE(oldsave);
2164         RETURN;
2165     }
2166
2167     /* known replacement string? */
2168     if (dstr) {
2169         if (SvTAINTED(dstr))
2170             rxtainted |= SUBST_TAINT_REPL;
2171
2172         /* Upgrade the source if the replacement is utf8 but the source is not,
2173          * but only if it matched; see
2174          * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2175          */
2176         if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2177             char * const orig_pvx =  SvPVX(TARG);
2178             const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2179
2180             /* If the lengths are the same, the pattern contains only
2181              * invariants, can keep going; otherwise, various internal markers
2182              * could be off, so redo */
2183             if (new_len != len || orig_pvx != SvPVX(TARG)) {
2184                 goto setup_match;
2185             }
2186         }
2187
2188         /* replacement needing upgrading? */
2189         if (DO_UTF8(TARG) && !doutf8) {
2190              nsv = sv_newmortal();
2191              SvSetSV(nsv, dstr);
2192              if (PL_encoding)
2193                   sv_recode_to_utf8(nsv, PL_encoding);
2194              else
2195                   sv_utf8_upgrade(nsv);
2196              c = SvPV_const(nsv, clen);
2197              doutf8 = TRUE;
2198         }
2199         else {
2200             c = SvPV_const(dstr, clen);
2201             doutf8 = DO_UTF8(dstr);
2202         }
2203     }
2204     else {
2205         c = NULL;
2206         doutf8 = FALSE;
2207     }
2208
2209     /* can do inplace substitution? */
2210     if (c
2211 #ifdef PERL_OLD_COPY_ON_WRITE
2212         && !is_cow
2213 #endif
2214         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2215         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2216         && (!doutf8 || SvUTF8(TARG))
2217         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2218     {
2219
2220 #ifdef PERL_OLD_COPY_ON_WRITE
2221         if (SvIsCOW(TARG)) {
2222             assert (!force_on_match);
2223             goto have_a_cow;
2224         }
2225 #endif
2226         if (force_on_match) {
2227             force_on_match = 0;
2228             s = SvPV_force(TARG, len);
2229             goto force_it;
2230         }
2231         d = s;
2232         PL_curpm = pm;
2233         if (once) {
2234             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2235                 rxtainted |= SUBST_TAINT_PAT;
2236             m = orig + RX_OFFS(rx)[0].start;
2237             d = orig + RX_OFFS(rx)[0].end;
2238             s = orig;
2239             if (m - s > strend - d) {  /* faster to shorten from end */
2240                 if (clen) {
2241                     Copy(c, m, clen, char);
2242                     m += clen;
2243                 }
2244                 i = strend - d;
2245                 if (i > 0) {
2246                     Move(d, m, i, char);
2247                     m += i;
2248                 }
2249                 *m = '\0';
2250                 SvCUR_set(TARG, m - s);
2251             }
2252             else if ((i = m - s)) {     /* faster from front */
2253                 d -= clen;
2254                 m = d;
2255                 Move(s, d - i, i, char);
2256                 sv_chop(TARG, d-i);
2257                 if (clen)
2258                     Copy(c, m, clen, char);
2259             }
2260             else if (clen) {
2261                 d -= clen;
2262                 sv_chop(TARG, d);
2263                 Copy(c, d, clen, char);
2264             }
2265             else {
2266                 sv_chop(TARG, d);
2267             }
2268             SPAGAIN;
2269             PUSHs(&PL_sv_yes);
2270         }
2271         else {
2272             do {
2273                 if (iters++ > maxiters)
2274                     DIE(aTHX_ "Substitution loop");
2275                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2276                     rxtainted |= SUBST_TAINT_PAT;
2277                 m = RX_OFFS(rx)[0].start + orig;
2278                 if ((i = m - s)) {
2279                     if (s != d)
2280                         Move(s, d, i, char);
2281                     d += i;
2282                 }
2283                 if (clen) {
2284                     Copy(c, d, clen, char);
2285                     d += clen;
2286                 }
2287                 s = RX_OFFS(rx)[0].end + orig;
2288             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2289                                  TARG, NULL,
2290                                  /* don't match same null twice */
2291                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2292             if (s != d) {
2293                 i = strend - s;
2294                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2295                 Move(s, d, i+1, char);          /* include the NUL */
2296             }
2297             SPAGAIN;
2298             mPUSHi((I32)iters);
2299         }
2300     }
2301     else {
2302         if (force_on_match) {
2303             force_on_match = 0;
2304             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2305                 /* I feel that it should be possible to avoid this mortal copy
2306                    given that the code below copies into a new destination.
2307                    However, I suspect it isn't worth the complexity of
2308                    unravelling the C<goto force_it> for the small number of
2309                    cases where it would be viable to drop into the copy code. */
2310                 TARG = sv_2mortal(newSVsv(TARG));
2311             }
2312             s = SvPV_force(TARG, len);
2313             goto force_it;
2314         }
2315 #ifdef PERL_OLD_COPY_ON_WRITE
2316       have_a_cow:
2317 #endif
2318         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2319             rxtainted |= SUBST_TAINT_PAT;
2320         dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2321         PL_curpm = pm;
2322         if (!c) {
2323             register PERL_CONTEXT *cx;
2324             SPAGAIN;
2325             /* note that a whole bunch of local vars are saved here for
2326              * use by pp_substcont: here's a list of them in case you're
2327              * searching for places in this sub that uses a particular var:
2328              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2329              * s m strend rx once */
2330             PUSHSUBST(cx);
2331             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2332         }
2333         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2334         do {
2335             if (iters++ > maxiters)
2336                 DIE(aTHX_ "Substitution loop");
2337             if (RX_MATCH_TAINTED(rx))
2338                 rxtainted |= SUBST_TAINT_PAT;
2339             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2340                 m = s;
2341                 s = orig;
2342                 orig = RX_SUBBEG(rx);
2343                 s = orig + (m - s);
2344                 strend = s + (strend - m);
2345             }
2346             m = RX_OFFS(rx)[0].start + orig;
2347             if (doutf8 && !SvUTF8(dstr))
2348                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2349             else
2350                 sv_catpvn(dstr, s, m-s);
2351             s = RX_OFFS(rx)[0].end + orig;
2352             if (clen)
2353                 sv_catpvn(dstr, c, clen);
2354             if (once)
2355                 break;
2356         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2357                              TARG, NULL, r_flags));
2358         if (doutf8 && !DO_UTF8(TARG))
2359             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2360         else
2361             sv_catpvn(dstr, s, strend - s);
2362
2363         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2364             /* From here on down we're using the copy, and leaving the original
2365                untouched.  */
2366             TARG = dstr;
2367             SPAGAIN;
2368             PUSHs(dstr);
2369         } else {
2370 #ifdef PERL_OLD_COPY_ON_WRITE
2371             /* The match may make the string COW. If so, brilliant, because
2372                that's just saved us one malloc, copy and free - the regexp has
2373                donated the old buffer, and we malloc an entirely new one, rather
2374                than the regexp malloc()ing a buffer and copying our original,
2375                only for us to throw it away here during the substitution.  */
2376             if (SvIsCOW(TARG)) {
2377                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2378             } else
2379 #endif
2380             {
2381                 SvPV_free(TARG);
2382             }
2383             SvPV_set(TARG, SvPVX(dstr));
2384             SvCUR_set(TARG, SvCUR(dstr));
2385             SvLEN_set(TARG, SvLEN(dstr));
2386             doutf8 |= DO_UTF8(dstr);
2387             SvPV_set(dstr, NULL);
2388
2389             SPAGAIN;
2390             mPUSHi((I32)iters);
2391         }
2392     }
2393
2394     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2395         (void)SvPOK_only_UTF8(TARG);
2396         if (doutf8)
2397             SvUTF8_on(TARG);
2398     }
2399
2400     /* See "how taint works" above */
2401     if (PL_tainting) {
2402         if ((rxtainted & SUBST_TAINT_PAT) ||
2403             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2404                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2405         )
2406             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2407
2408         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2409             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2410         )
2411             SvTAINTED_on(TOPs);  /* taint return value */
2412         else
2413             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2414
2415         /* needed for mg_set below */
2416         PL_tainted =
2417           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2418         SvTAINT(TARG);
2419     }
2420     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2421     TAINT_NOT;
2422     LEAVE_SCOPE(oldsave);
2423     RETURN;
2424 }
2425
2426 PP(pp_grepwhile)
2427 {
2428     dVAR; dSP;
2429
2430     if (SvTRUEx(POPs))
2431         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2432     ++*PL_markstack_ptr;
2433     FREETMPS;
2434     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2435
2436     /* All done yet? */
2437     if (PL_stack_base + *PL_markstack_ptr > SP) {
2438         I32 items;
2439         const I32 gimme = GIMME_V;
2440
2441         LEAVE_with_name("grep");                                        /* exit outer scope */
2442         (void)POPMARK;                          /* pop src */
2443         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2444         (void)POPMARK;                          /* pop dst */
2445         SP = PL_stack_base + POPMARK;           /* pop original mark */
2446         if (gimme == G_SCALAR) {
2447             if (PL_op->op_private & OPpGREP_LEX) {
2448                 SV* const sv = sv_newmortal();
2449                 sv_setiv(sv, items);
2450                 PUSHs(sv);
2451             }
2452             else {
2453                 dTARGET;
2454                 XPUSHi(items);
2455             }
2456         }
2457         else if (gimme == G_ARRAY)
2458             SP += items;
2459         RETURN;
2460     }
2461     else {
2462         SV *src;
2463
2464         ENTER_with_name("grep_item");                                   /* enter inner scope */
2465         SAVEVPTR(PL_curpm);
2466
2467         src = PL_stack_base[*PL_markstack_ptr];
2468         SvTEMP_off(src);
2469         if (PL_op->op_private & OPpGREP_LEX)
2470             PAD_SVl(PL_op->op_targ) = src;
2471         else
2472             DEFSV_set(src);
2473
2474         RETURNOP(cLOGOP->op_other);
2475     }
2476 }
2477
2478 PP(pp_leavesub)
2479 {
2480     dVAR; dSP;
2481     SV **mark;
2482     SV **newsp;
2483     PMOP *newpm;
2484     I32 gimme;
2485     register PERL_CONTEXT *cx;
2486     SV *sv;
2487
2488     if (CxMULTICALL(&cxstack[cxstack_ix]))
2489         return 0;
2490
2491     POPBLOCK(cx,newpm);
2492     cxstack_ix++; /* temporarily protect top context */
2493
2494     TAINT_NOT;
2495     if (gimme == G_SCALAR) {
2496         MARK = newsp + 1;
2497         if (MARK <= SP) {
2498             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2499                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2500                      && !SvMAGICAL(TOPs)) {
2501                     *MARK = SvREFCNT_inc(TOPs);
2502                     FREETMPS;
2503                     sv_2mortal(*MARK);
2504                 }
2505                 else {
2506                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2507                     FREETMPS;
2508                     *MARK = sv_mortalcopy(sv);
2509                     SvREFCNT_dec(sv);
2510                 }
2511             }
2512             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2513                      && !SvMAGICAL(TOPs)) {
2514                 *MARK = TOPs;
2515             }
2516             else
2517                 *MARK = sv_mortalcopy(TOPs);
2518         }
2519         else {
2520             MEXTEND(MARK, 0);
2521             *MARK = &PL_sv_undef;
2522         }
2523         SP = MARK;
2524     }
2525     else if (gimme == G_ARRAY) {
2526         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2527             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2528                  || SvMAGICAL(*MARK)) {
2529                 *MARK = sv_mortalcopy(*MARK);
2530                 TAINT_NOT;      /* Each item is independent */
2531             }
2532         }
2533     }
2534     PUTBACK;
2535
2536     LEAVE;
2537     cxstack_ix--;
2538     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2539     PL_curpm = newpm;   /* ... and pop $1 et al */
2540
2541     LEAVESUB(sv);
2542     return cx->blk_sub.retop;
2543 }
2544
2545 PP(pp_entersub)
2546 {
2547     dVAR; dSP; dPOPss;
2548     GV *gv;
2549     register CV *cv;
2550     register PERL_CONTEXT *cx;
2551     I32 gimme;
2552     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2553
2554     if (!sv)
2555         DIE(aTHX_ "Not a CODE reference");
2556     switch (SvTYPE(sv)) {
2557         /* This is overwhelming the most common case:  */
2558     case SVt_PVGV:
2559       we_have_a_glob:
2560         if (!(cv = GvCVu((const GV *)sv))) {
2561             HV *stash;
2562             cv = sv_2cv(sv, &stash, &gv, 0);
2563         }
2564         if (!cv) {
2565             ENTER;
2566             SAVETMPS;
2567             goto try_autoload;
2568         }
2569         break;
2570     case SVt_PVLV:
2571         if(isGV_with_GP(sv)) goto we_have_a_glob;
2572         /*FALLTHROUGH*/
2573     default:
2574         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2575             if (hasargs)
2576                 SP = PL_stack_base + POPMARK;
2577             else
2578                 (void)POPMARK;
2579             RETURN;
2580         }
2581         SvGETMAGIC(sv);
2582         if (SvROK(sv)) {
2583             if (SvAMAGIC(sv)) {
2584                 sv = amagic_deref_call(sv, to_cv_amg);
2585                 /* Don't SPAGAIN here.  */
2586             }
2587         }
2588         else {
2589             const char *sym;
2590             STRLEN len;
2591             sym = SvPV_nomg_const(sv, len);
2592             if (!sym)
2593                 DIE(aTHX_ PL_no_usym, "a subroutine");
2594             if (PL_op->op_private & HINT_STRICT_REFS)
2595                 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2596             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2597             break;
2598         }
2599         cv = MUTABLE_CV(SvRV(sv));
2600         if (SvTYPE(cv) == SVt_PVCV)
2601             break;
2602         /* FALL THROUGH */
2603     case SVt_PVHV:
2604     case SVt_PVAV:
2605         DIE(aTHX_ "Not a CODE reference");
2606         /* This is the second most common case:  */
2607     case SVt_PVCV:
2608         cv = MUTABLE_CV(sv);
2609         break;
2610     }
2611
2612     ENTER;
2613     SAVETMPS;
2614
2615   retry:
2616     if (CvCLONE(cv) && ! CvCLONED(cv))
2617         DIE(aTHX_ "Closure prototype called");
2618     if (!CvROOT(cv) && !CvXSUB(cv)) {
2619         GV* autogv;
2620         SV* sub_name;
2621
2622         /* anonymous or undef'd function leaves us no recourse */
2623         if (CvANON(cv) || !(gv = CvGV(cv)))
2624             DIE(aTHX_ "Undefined subroutine called");
2625
2626         /* autoloaded stub? */
2627         if (cv != GvCV(gv)) {
2628             cv = GvCV(gv);
2629         }
2630         /* should call AUTOLOAD now? */
2631         else {
2632 try_autoload:
2633             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2634                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2635             {
2636                 cv = GvCV(autogv);
2637             }
2638             /* sorry */
2639             else {
2640                 sub_name = sv_newmortal();
2641                 gv_efullname3(sub_name, gv, NULL);
2642                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2643             }
2644         }
2645         if (!cv)
2646             DIE(aTHX_ "Not a CODE reference");
2647         goto retry;
2648     }
2649
2650     gimme = GIMME_V;
2651     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2652          Perl_get_db_sub(aTHX_ &sv, cv);
2653          if (CvISXSUB(cv))
2654              PL_curcopdb = PL_curcop;
2655          if (CvLVALUE(cv)) {
2656              /* check for lsub that handles lvalue subroutines */
2657              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2658              /* if lsub not found then fall back to DB::sub */
2659              if (!cv) cv = GvCV(PL_DBsub);
2660          } else {
2661              cv = GvCV(PL_DBsub);
2662          }
2663
2664         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2665             DIE(aTHX_ "No DB::sub routine defined");
2666     }
2667
2668     if (!(CvISXSUB(cv))) {
2669         /* This path taken at least 75% of the time   */
2670         dMARK;
2671         register I32 items = SP - MARK;
2672         AV* const padlist = CvPADLIST(cv);
2673         PUSHBLOCK(cx, CXt_SUB, MARK);
2674         PUSHSUB(cx);
2675         cx->blk_sub.retop = PL_op->op_next;
2676         CvDEPTH(cv)++;
2677         if (CvDEPTH(cv) >= 2) {
2678             PERL_STACK_OVERFLOW_CHECK();
2679             pad_push(padlist, CvDEPTH(cv));
2680         }
2681         SAVECOMPPAD();
2682         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2683         if (hasargs) {
2684             AV *const av = MUTABLE_AV(PAD_SVl(0));
2685             if (AvREAL(av)) {
2686                 /* @_ is normally not REAL--this should only ever
2687                  * happen when DB::sub() calls things that modify @_ */
2688                 av_clear(av);
2689                 AvREAL_off(av);
2690                 AvREIFY_on(av);
2691             }
2692             cx->blk_sub.savearray = GvAV(PL_defgv);
2693             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2694             CX_CURPAD_SAVE(cx->blk_sub);
2695             cx->blk_sub.argarray = av;
2696             ++MARK;
2697
2698             if (items > AvMAX(av) + 1) {
2699                 SV **ary = AvALLOC(av);
2700                 if (AvARRAY(av) != ary) {
2701                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2702                     AvARRAY(av) = ary;
2703                 }
2704                 if (items > AvMAX(av) + 1) {
2705                     AvMAX(av) = items - 1;
2706                     Renew(ary,items,SV*);
2707                     AvALLOC(av) = ary;
2708                     AvARRAY(av) = ary;
2709                 }
2710             }
2711             Copy(MARK,AvARRAY(av),items,SV*);
2712             AvFILLp(av) = items - 1;
2713
2714             while (items--) {
2715                 if (*MARK)
2716                     SvTEMP_off(*MARK);
2717                 MARK++;
2718             }
2719         }
2720         if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2721             !CvLVALUE(cv))
2722             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2723         /* warning must come *after* we fully set up the context
2724          * stuff so that __WARN__ handlers can safely dounwind()
2725          * if they want to
2726          */
2727         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2728             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2729             sub_crush_depth(cv);
2730         RETURNOP(CvSTART(cv));
2731     }
2732     else {
2733         I32 markix = TOPMARK;
2734
2735         PUTBACK;
2736
2737         if (!hasargs) {
2738             /* Need to copy @_ to stack. Alternative may be to
2739              * switch stack to @_, and copy return values
2740              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2741             AV * const av = GvAV(PL_defgv);
2742             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2743
2744             if (items) {
2745                 /* Mark is at the end of the stack. */
2746                 EXTEND(SP, items);
2747                 Copy(AvARRAY(av), SP + 1, items, SV*);
2748                 SP += items;
2749                 PUTBACK ;
2750             }
2751         }
2752         /* We assume first XSUB in &DB::sub is the called one. */
2753         if (PL_curcopdb) {
2754             SAVEVPTR(PL_curcop);
2755             PL_curcop = PL_curcopdb;
2756             PL_curcopdb = NULL;
2757         }
2758         /* Do we need to open block here? XXXX */
2759
2760         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2761         assert(CvXSUB(cv));
2762         CvXSUB(cv)(aTHX_ cv);
2763
2764         /* Enforce some sanity in scalar context. */
2765         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2766             if (markix > PL_stack_sp - PL_stack_base)
2767                 *(PL_stack_base + markix) = &PL_sv_undef;
2768             else
2769                 *(PL_stack_base + markix) = *PL_stack_sp;
2770             PL_stack_sp = PL_stack_base + markix;
2771         }
2772         LEAVE;
2773         return NORMAL;
2774     }
2775 }
2776
2777 void
2778 Perl_sub_crush_depth(pTHX_ CV *cv)
2779 {
2780     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2781
2782     if (CvANON(cv))
2783         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2784     else {
2785         SV* const tmpstr = sv_newmortal();
2786         gv_efullname3(tmpstr, CvGV(cv), NULL);
2787         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2788                     SVfARG(tmpstr));
2789     }
2790 }
2791
2792 PP(pp_aelem)
2793 {
2794     dVAR; dSP;
2795     SV** svp;
2796     SV* const elemsv = POPs;
2797     IV elem = SvIV(elemsv);
2798     AV *const av = MUTABLE_AV(POPs);
2799     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2800     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2801     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2802     bool preeminent = TRUE;
2803     SV *sv;
2804
2805     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2806         Perl_warner(aTHX_ packWARN(WARN_MISC),
2807                     "Use of reference \"%"SVf"\" as array index",
2808                     SVfARG(elemsv));
2809     if (SvTYPE(av) != SVt_PVAV)
2810         RETPUSHUNDEF;
2811
2812     if (localizing) {
2813         MAGIC *mg;
2814         HV *stash;
2815
2816         /* If we can determine whether the element exist,
2817          * Try to preserve the existenceness of a tied array
2818          * element by using EXISTS and DELETE if possible.
2819          * Fallback to FETCH and STORE otherwise. */
2820         if (SvCANEXISTDELETE(av))
2821             preeminent = av_exists(av, elem);
2822     }
2823
2824     svp = av_fetch(av, elem, lval && !defer);
2825     if (lval) {
2826 #ifdef PERL_MALLOC_WRAP
2827          if (SvUOK(elemsv)) {
2828               const UV uv = SvUV(elemsv);
2829               elem = uv > IV_MAX ? IV_MAX : uv;
2830          }
2831          else if (SvNOK(elemsv))
2832               elem = (IV)SvNV(elemsv);
2833          if (elem > 0) {
2834               static const char oom_array_extend[] =
2835                 "Out of memory during array extend"; /* Duplicated in av.c */
2836               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2837          }
2838 #endif
2839         if (!svp || *svp == &PL_sv_undef) {
2840             SV* lv;
2841             if (!defer)
2842                 DIE(aTHX_ PL_no_aelem, elem);
2843             lv = sv_newmortal();
2844             sv_upgrade(lv, SVt_PVLV);
2845             LvTYPE(lv) = 'y';
2846             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2847             LvTARG(lv) = SvREFCNT_inc_simple(av);
2848             LvTARGOFF(lv) = elem;
2849             LvTARGLEN(lv) = 1;
2850             PUSHs(lv);
2851             RETURN;
2852         }
2853         if (localizing) {
2854             if (preeminent)
2855                 save_aelem(av, elem, svp);
2856             else
2857                 SAVEADELETE(av, elem);
2858         }
2859         else if (PL_op->op_private & OPpDEREF) {
2860             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2861             RETURN;
2862         }
2863     }
2864     sv = (svp ? *svp : &PL_sv_undef);
2865     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2866         mg_get(sv);
2867     PUSHs(sv);
2868     RETURN;
2869 }
2870
2871 SV*
2872 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2873 {
2874     PERL_ARGS_ASSERT_VIVIFY_REF;
2875
2876     SvGETMAGIC(sv);
2877     if (!SvOK(sv)) {
2878         if (SvREADONLY(sv))
2879             Perl_croak_no_modify(aTHX);
2880         prepare_SV_for_RV(sv);
2881         switch (to_what) {
2882         case OPpDEREF_SV:
2883             SvRV_set(sv, newSV(0));
2884             break;
2885         case OPpDEREF_AV:
2886             SvRV_set(sv, MUTABLE_SV(newAV()));
2887             break;
2888         case OPpDEREF_HV:
2889             SvRV_set(sv, MUTABLE_SV(newHV()));
2890             break;
2891         }
2892         SvROK_on(sv);
2893         SvSETMAGIC(sv);
2894         SvGETMAGIC(sv);
2895     }
2896     if (SvGMAGICAL(sv)) {
2897         /* copy the sv without magic to prevent magic from being
2898            executed twice */
2899         SV* msv = sv_newmortal();
2900         sv_setsv_nomg(msv, sv);
2901         return msv;
2902     }
2903     return sv;
2904 }
2905
2906 PP(pp_method)
2907 {
2908     dVAR; dSP;
2909     SV* const sv = TOPs;
2910
2911     if (SvROK(sv)) {
2912         SV* const rsv = SvRV(sv);
2913         if (SvTYPE(rsv) == SVt_PVCV) {
2914             SETs(rsv);
2915             RETURN;
2916         }
2917     }
2918
2919     SETs(method_common(sv, NULL));
2920     RETURN;
2921 }
2922
2923 PP(pp_method_named)
2924 {
2925     dVAR; dSP;
2926     SV* const sv = cSVOP_sv;
2927     U32 hash = SvSHARED_HASH(sv);
2928
2929     XPUSHs(method_common(sv, &hash));
2930     RETURN;
2931 }
2932
2933 STATIC SV *
2934 S_method_common(pTHX_ SV* meth, U32* hashp)
2935 {
2936     dVAR;
2937     SV* ob;
2938     GV* gv;
2939     HV* stash;
2940     SV *packsv = NULL;
2941     SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2942         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2943                             "package or object reference", SVfARG(meth)),
2944            (SV *)NULL)
2945         : *(PL_stack_base + TOPMARK + 1);
2946
2947     PERL_ARGS_ASSERT_METHOD_COMMON;
2948
2949     if (!sv)
2950         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2951                    SVfARG(meth));
2952
2953     SvGETMAGIC(sv);
2954     if (SvROK(sv))
2955         ob = MUTABLE_SV(SvRV(sv));
2956     else {
2957         GV* iogv;
2958         STRLEN packlen;
2959         const char * packname = NULL;
2960         bool packname_is_utf8 = FALSE;
2961
2962         /* this isn't a reference */
2963         if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2964           const HE* const he =
2965             (const HE *)hv_common_key_len(
2966               PL_stashcache, packname,
2967               packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2968             );
2969
2970           if (he) {
2971             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2972             goto fetch;
2973           }
2974         }
2975
2976         if (!SvOK(sv) ||
2977             !(packname) ||
2978             !(iogv = gv_fetchpvn_flags(
2979                 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2980              )) ||
2981             !(ob=MUTABLE_SV(GvIO(iogv))))
2982         {
2983             /* this isn't the name of a filehandle either */
2984             if (!packname ||
2985                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2986                     ? !isIDFIRST_utf8((U8*)packname)
2987                     : !isIDFIRST_L1((U8)*packname)
2988                 ))
2989             {
2990                 /* diag_listed_as: Can't call method "%s" without a package or object reference */
2991                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
2992                            SVfARG(meth),
2993                            SvOK(sv) ? "without a package or object reference"
2994                                     : "on an undefined value");
2995             }
2996             /* assume it's a package name */
2997             stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
2998             if (!stash)
2999                 packsv = sv;
3000             else {
3001                 SV* const ref = newSViv(PTR2IV(stash));
3002                 (void)hv_store(PL_stashcache, packname,
3003                                 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3004             }
3005             goto fetch;
3006         }
3007         /* it _is_ a filehandle name -- replace with a reference */
3008         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3009     }
3010
3011     /* if we got here, ob should be a reference or a glob */
3012     if (!ob || !(SvOBJECT(ob)
3013                  || (SvTYPE(ob) == SVt_PVGV
3014                      && isGV_with_GP(ob)
3015                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3016                      && SvOBJECT(ob))))
3017     {
3018         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3019                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3020                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3021                                         : meth));
3022     }
3023
3024     stash = SvSTASH(ob);
3025
3026   fetch:
3027     /* NOTE: stash may be null, hope hv_fetch_ent and
3028        gv_fetchmethod can cope (it seems they can) */
3029
3030     /* shortcut for simple names */
3031     if (hashp) {
3032         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3033         if (he) {
3034             gv = MUTABLE_GV(HeVAL(he));
3035             if (isGV(gv) && GvCV(gv) &&
3036                 (!GvCVGEN(gv) || GvCVGEN(gv)
3037                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3038                 return MUTABLE_SV(GvCV(gv));
3039         }
3040     }
3041
3042     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3043                                      meth, GV_AUTOLOAD | GV_CROAK);
3044
3045     assert(gv);
3046
3047     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3048 }
3049
3050 /*
3051  * Local variables:
3052  * c-indentation-style: bsd
3053  * c-basic-offset: 4
3054  * indent-tabs-mode: nil
3055  * End:
3056  *
3057  * ex: set ts=8 sts=4 sw=4 et:
3058  */