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