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