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