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