pp_hot.c

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