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