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