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