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