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_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2441         PL_curpm = pm;
2442         if (!c) {
2443             register PERL_CONTEXT *cx;
2444             SPAGAIN;
2445             /* note that a whole bunch of local vars are saved here for
2446              * use by pp_substcont: here's a list of them in case you're
2447              * searching for places in this sub that uses a particular var:
2448              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2449              * s m strend rx once */
2450             PUSHSUBST(cx);
2451             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2452         }
2453         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2454         do {
2455             if (iters++ > maxiters)
2456                 DIE(aTHX_ "Substitution loop");
2457             if (RX_MATCH_TAINTED(rx))
2458                 rxtainted |= SUBST_TAINT_PAT;
2459             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2460                 m = s;
2461                 s = orig;
2462                 orig = RX_SUBBEG(rx);
2463                 s = orig + (m - s);
2464                 strend = s + (strend - m);
2465             }
2466             m = RX_OFFS(rx)[0].start + orig;
2467             if (doutf8 && !SvUTF8(dstr))
2468                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2469             else
2470                 sv_catpvn(dstr, s, m-s);
2471             s = RX_OFFS(rx)[0].end + orig;
2472             if (clen)
2473                 sv_catpvn(dstr, c, clen);
2474             if (once)
2475                 break;
2476         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2477                              TARG, NULL, r_flags));
2478         if (doutf8 && !DO_UTF8(TARG))
2479             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2480         else
2481             sv_catpvn(dstr, s, strend - s);
2482
2483 #ifdef PERL_OLD_COPY_ON_WRITE
2484         /* The match may make the string COW. If so, brilliant, because that's
2485            just saved us one malloc, copy and free - the regexp has donated
2486            the old buffer, and we malloc an entirely new one, rather than the
2487            regexp malloc()ing a buffer and copying our original, only for
2488            us to throw it away here during the substitution.  */
2489         if (SvIsCOW(TARG)) {
2490             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2491         } else
2492 #endif
2493         {
2494             SvPV_free(TARG);
2495         }
2496         SvPV_set(TARG, SvPVX(dstr));
2497         SvCUR_set(TARG, SvCUR(dstr));
2498         SvLEN_set(TARG, SvLEN(dstr));
2499         doutf8 |= DO_UTF8(dstr);
2500         SvPV_set(dstr, NULL);
2501
2502         SPAGAIN;
2503         if (rpm->op_pmflags & PMf_NONDESTRUCT)
2504             PUSHs(TARG);
2505         else
2506             mPUSHi((I32)iters);
2507     }
2508     (void)SvPOK_only_UTF8(TARG);
2509     if (doutf8)
2510         SvUTF8_on(TARG);
2511
2512     /* See "how taint works" above */
2513     if (PL_tainting) {
2514         if ((rxtainted & SUBST_TAINT_PAT) ||
2515             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2516                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2517         )
2518             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2519
2520         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2521             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2522         )
2523             SvTAINTED_on(TOPs);  /* taint return value */
2524         else
2525             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2526
2527         /* needed for mg_set below */
2528         PL_tainted =
2529           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2530         SvTAINT(TARG);
2531     }
2532     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2533     TAINT_NOT;
2534     LEAVE_SCOPE(oldsave);
2535     RETURN;
2536 }
2537
2538 PP(pp_grepwhile)
2539 {
2540     dVAR; dSP;
2541
2542     if (SvTRUEx(POPs))
2543         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2544     ++*PL_markstack_ptr;
2545     FREETMPS;
2546     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2547
2548     /* All done yet? */
2549     if (PL_stack_base + *PL_markstack_ptr > SP) {
2550         I32 items;
2551         const I32 gimme = GIMME_V;
2552
2553         LEAVE_with_name("grep");                                        /* exit outer scope */
2554         (void)POPMARK;                          /* pop src */
2555         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2556         (void)POPMARK;                          /* pop dst */
2557         SP = PL_stack_base + POPMARK;           /* pop original mark */
2558         if (gimme == G_SCALAR) {
2559             if (PL_op->op_private & OPpGREP_LEX) {
2560                 SV* const sv = sv_newmortal();
2561                 sv_setiv(sv, items);
2562                 PUSHs(sv);
2563             }
2564             else {
2565                 dTARGET;
2566                 XPUSHi(items);
2567             }
2568         }
2569         else if (gimme == G_ARRAY)
2570             SP += items;
2571         RETURN;
2572     }
2573     else {
2574         SV *src;
2575
2576         ENTER_with_name("grep_item");                                   /* enter inner scope */
2577         SAVEVPTR(PL_curpm);
2578
2579         src = PL_stack_base[*PL_markstack_ptr];
2580         SvTEMP_off(src);
2581         if (PL_op->op_private & OPpGREP_LEX)
2582             PAD_SVl(PL_op->op_targ) = src;
2583         else
2584             DEFSV_set(src);
2585
2586         RETURNOP(cLOGOP->op_other);
2587     }
2588 }
2589
2590 PP(pp_leavesub)
2591 {
2592     dVAR; dSP;
2593     SV **mark;
2594     SV **newsp;
2595     PMOP *newpm;
2596     I32 gimme;
2597     register PERL_CONTEXT *cx;
2598     SV *sv;
2599     bool gmagic;
2600
2601     if (CxMULTICALL(&cxstack[cxstack_ix]))
2602         return 0;
2603
2604     POPBLOCK(cx,newpm);
2605     cxstack_ix++; /* temporarily protect top context */
2606     gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
2607
2608     TAINT_NOT;
2609     if (gimme == G_SCALAR) {
2610         MARK = newsp + 1;
2611         if (MARK <= SP) {
2612             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2613                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2614                     *MARK = SvREFCNT_inc(TOPs);
2615                     FREETMPS;
2616                     sv_2mortal(*MARK);
2617                     if (gmagic) SvGETMAGIC(*MARK);
2618                 }
2619                 else {
2620                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2621                     FREETMPS;
2622                     *MARK = sv_mortalcopy(sv);
2623                     SvREFCNT_dec(sv);
2624                 }
2625             }
2626             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2627                 *MARK = TOPs;
2628                 if (gmagic) SvGETMAGIC(TOPs);
2629             }
2630             else
2631                 *MARK = sv_mortalcopy(TOPs);
2632         }
2633         else {
2634             MEXTEND(MARK, 0);
2635             *MARK = &PL_sv_undef;
2636         }
2637         SP = MARK;
2638     }
2639     else if (gimme == G_ARRAY) {
2640         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2641             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
2642                 *MARK = sv_mortalcopy(*MARK);
2643                 TAINT_NOT;      /* Each item is independent */
2644             }
2645         }
2646     }
2647     PUTBACK;
2648
2649     LEAVE;
2650     cxstack_ix--;
2651     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2652     PL_curpm = newpm;   /* ... and pop $1 et al */
2653
2654     LEAVESUB(sv);
2655     return cx->blk_sub.retop;
2656 }
2657
2658 /* This duplicates the above code because the above code must not
2659  * get any slower by more conditions */
2660 PP(pp_leavesublv)
2661 {
2662     dVAR; dSP;
2663     SV **mark;
2664     SV **newsp;
2665     PMOP *newpm;
2666     I32 gimme;
2667     register PERL_CONTEXT *cx;
2668     SV *sv;
2669
2670     if (CxMULTICALL(&cxstack[cxstack_ix]))
2671         return 0;
2672
2673     POPBLOCK(cx,newpm);
2674     cxstack_ix++; /* temporarily protect top context */
2675
2676     TAINT_NOT;
2677
2678     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2679         /* We are an argument to a function or grep().
2680          * This kind of lvalueness was legal before lvalue
2681          * subroutines too, so be backward compatible:
2682          * cannot report errors.  */
2683
2684         /* Scalar context *is* possible, on the LHS of ->. */
2685         if (gimme == G_SCALAR)
2686             goto rvalue;
2687         if (gimme == G_ARRAY) {
2688             mark = newsp + 1;
2689             if (!CvLVALUE(cx->blk_sub.cv))
2690                 goto rvalue_array;
2691             EXTEND_MORTAL(SP - newsp);
2692             for (mark = newsp + 1; mark <= SP; mark++) {
2693                 if (SvTEMP(*mark))
2694                     NOOP;
2695                 else if (SvFLAGS(*mark) & SVs_PADTMP)
2696                     *mark = sv_mortalcopy(*mark);
2697                 else {
2698                     /* Can be a localized value subject to deletion. */
2699                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2700                     SvREFCNT_inc_void(*mark);
2701                 }
2702             }
2703         }
2704     }
2705     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2706         /* Here we go for robustness, not for speed, so we change all
2707          * the refcounts so the caller gets a live guy. Cannot set
2708          * TEMP, so sv_2mortal is out of question. */
2709         if (!CvLVALUE(cx->blk_sub.cv)) {
2710             LEAVE;
2711             cxstack_ix--;
2712             POPSUB(cx,sv);
2713             PL_curpm = newpm;
2714             LEAVESUB(sv);
2715             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2716         }
2717         if (gimme == G_SCALAR) {
2718             MARK = newsp + 1;
2719             EXTEND_MORTAL(1);
2720             if (MARK == SP) {
2721                 if ((SvPADTMP(TOPs) ||
2722                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2723                        == SVf_READONLY
2724                     ) &&
2725                     !SvSMAGICAL(TOPs)) {
2726                     LEAVE;
2727                     cxstack_ix--;
2728                     POPSUB(cx,sv);
2729                     PL_curpm = newpm;
2730                     LEAVESUB(sv);
2731                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2732                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2733                         : "a readonly value" : "a temporary");
2734                 }
2735                 else {                  /* Can be a localized value
2736                                          * subject to deletion. */
2737                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2738                     SvREFCNT_inc_void(*mark);
2739                 }
2740             }
2741             else {
2742                 /* sub:lvalue{} will take us here.
2743                    Presumably the case of a non-empty array never happens.
2744                  */
2745                 LEAVE;
2746                 cxstack_ix--;
2747                 POPSUB(cx,sv);
2748                 PL_curpm = newpm;
2749                 LEAVESUB(sv);
2750                 DIE(aTHX_ "%s",
2751                     (MARK > SP
2752                       ? "Can't return undef from lvalue subroutine"
2753                       : "Array returned from lvalue subroutine in scalar "
2754                         "context"
2755                     )
2756                 );
2757             }
2758             SP = MARK;
2759         }
2760         else if (gimme == G_ARRAY) {
2761             EXTEND_MORTAL(SP - newsp);
2762             for (mark = newsp + 1; mark <= SP; mark++) {
2763                 if (*mark != &PL_sv_undef
2764                     && (SvPADTMP(*mark)
2765                        || (SvFLAGS(*mark) & (SVf_READONLY|SVf_FAKE))
2766                              == SVf_READONLY
2767                        )
2768                 ) {
2769                     /* Might be flattened array after $#array =  */
2770                     PUTBACK;
2771                     LEAVE;
2772                     cxstack_ix--;
2773                     POPSUB(cx,sv);
2774                     PL_curpm = newpm;
2775                     LEAVESUB(sv);
2776                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2777                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2778                 }
2779                 else {
2780                     /* Can be a localized value subject to deletion. */
2781                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2782                     SvREFCNT_inc_void(*mark);
2783                 }
2784             }
2785         }
2786     }
2787     else {
2788         if (gimme == G_SCALAR) {
2789           rvalue:
2790             MARK = newsp + 1;
2791             if (MARK <= SP) {
2792                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2793                         *MARK = SvREFCNT_inc(TOPs);
2794                         FREETMPS;
2795                         sv_2mortal(*MARK);
2796                 }
2797                 else
2798                     *MARK = SvTEMP(TOPs)
2799                               ? TOPs
2800                               : sv_2mortal(SvREFCNT_inc_simple_NN(TOPs));
2801             }
2802             else {
2803                 MEXTEND(MARK, 0);
2804                 *MARK = &PL_sv_undef;
2805             }
2806             SP = MARK;
2807         }
2808         else if (gimme == G_ARRAY) {
2809           rvalue_array:
2810             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2811                 if (!SvTEMP(*MARK))
2812                     *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2813             }
2814         }
2815     }
2816
2817     if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
2818         assert(gimme == G_SCALAR);
2819         SvGETMAGIC(TOPs);
2820         if (!SvOK(TOPs)) {
2821             U8 deref_type;
2822             if (cx->blk_sub.retop->op_type == OP_RV2SV)
2823                 deref_type = OPpDEREF_SV;
2824             else if (cx->blk_sub.retop->op_type == OP_RV2AV)
2825                 deref_type = OPpDEREF_AV;
2826             else {
2827                 assert(cx->blk_sub.retop->op_type == OP_RV2HV);
2828                 deref_type = OPpDEREF_HV;
2829             }
2830             vivify_ref(TOPs, deref_type);
2831         }
2832     }
2833
2834     PUTBACK;
2835
2836     LEAVE;
2837     cxstack_ix--;
2838     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2839     PL_curpm = newpm;   /* ... and pop $1 et al */
2840
2841     LEAVESUB(sv);
2842     return cx->blk_sub.retop;
2843 }
2844
2845 PP(pp_entersub)
2846 {
2847     dVAR; dSP; dPOPss;
2848     GV *gv;
2849     register CV *cv;
2850     register PERL_CONTEXT *cx;
2851     I32 gimme;
2852     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2853
2854     if (!sv)
2855         DIE(aTHX_ "Not a CODE reference");
2856     switch (SvTYPE(sv)) {
2857         /* This is overwhelming the most common case:  */
2858     case SVt_PVGV:
2859         if (!isGV_with_GP(sv))
2860             DIE(aTHX_ "Not a CODE reference");
2861       we_have_a_glob:
2862         if (!(cv = GvCVu((const GV *)sv))) {
2863             HV *stash;
2864             cv = sv_2cv(sv, &stash, &gv, 0);
2865         }
2866         if (!cv) {
2867             ENTER;
2868             SAVETMPS;
2869             goto try_autoload;
2870         }
2871         break;
2872     case SVt_PVLV:
2873         if(isGV_with_GP(sv)) goto we_have_a_glob;
2874         /*FALLTHROUGH*/
2875     default:
2876         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2877             if (hasargs)
2878                 SP = PL_stack_base + POPMARK;
2879             else
2880                 (void)POPMARK;
2881             RETURN;
2882         }
2883         SvGETMAGIC(sv);
2884         if (SvROK(sv)) {
2885             if (SvAMAGIC(sv)) {
2886                 sv = amagic_deref_call(sv, to_cv_amg);
2887                 /* Don't SPAGAIN here.  */
2888             }
2889         }
2890         else {
2891             const char *sym;
2892             STRLEN len;
2893             sym = SvPV_nomg_const(sv, len);
2894             if (!sym)
2895                 DIE(aTHX_ PL_no_usym, "a subroutine");
2896             if (PL_op->op_private & HINT_STRICT_REFS)
2897                 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2898             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2899             break;
2900         }
2901         cv = MUTABLE_CV(SvRV(sv));
2902         if (SvTYPE(cv) == SVt_PVCV)
2903             break;
2904         /* FALL THROUGH */
2905     case SVt_PVHV:
2906     case SVt_PVAV:
2907         DIE(aTHX_ "Not a CODE reference");
2908         /* This is the second most common case:  */
2909     case SVt_PVCV:
2910         cv = MUTABLE_CV(sv);
2911         break;
2912     }
2913
2914     ENTER;
2915     SAVETMPS;
2916
2917   retry:
2918     if (CvCLONE(cv) && ! CvCLONED(cv))
2919         DIE(aTHX_ "Closure prototype called");
2920     if (!CvROOT(cv) && !CvXSUB(cv)) {
2921         GV* autogv;
2922         SV* sub_name;
2923
2924         /* anonymous or undef'd function leaves us no recourse */
2925         if (CvANON(cv) || !(gv = CvGV(cv)))
2926             DIE(aTHX_ "Undefined subroutine called");
2927
2928         /* autoloaded stub? */
2929         if (cv != GvCV(gv)) {
2930             cv = GvCV(gv);
2931         }
2932         /* should call AUTOLOAD now? */
2933         else {
2934 try_autoload:
2935             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2936                                    FALSE)))
2937             {
2938                 cv = GvCV(autogv);
2939             }
2940             /* sorry */
2941             else {
2942                 sub_name = sv_newmortal();
2943                 gv_efullname3(sub_name, gv, NULL);
2944                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2945             }
2946         }
2947         if (!cv)
2948             DIE(aTHX_ "Not a CODE reference");
2949         goto retry;
2950     }
2951
2952     gimme = GIMME_V;
2953     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2954          Perl_get_db_sub(aTHX_ &sv, cv);
2955          if (CvISXSUB(cv))
2956              PL_curcopdb = PL_curcop;
2957          if (CvLVALUE(cv)) {
2958              /* check for lsub that handles lvalue subroutines */
2959              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2960              /* if lsub not found then fall back to DB::sub */
2961              if (!cv) cv = GvCV(PL_DBsub);
2962          } else {
2963              cv = GvCV(PL_DBsub);
2964          }
2965
2966         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2967             DIE(aTHX_ "No DB::sub routine defined");
2968     }
2969
2970     if (!(CvISXSUB(cv))) {
2971         /* This path taken at least 75% of the time   */
2972         dMARK;
2973         register I32 items = SP - MARK;
2974         AV* const padlist = CvPADLIST(cv);
2975         PUSHBLOCK(cx, CXt_SUB, MARK);
2976         PUSHSUB(cx);
2977         cx->blk_sub.retop = PL_op->op_next;
2978         CvDEPTH(cv)++;
2979         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2980          * that eval'' ops within this sub know the correct lexical space.
2981          * Owing the speed considerations, we choose instead to search for
2982          * the cv using find_runcv() when calling doeval().
2983          */
2984         if (CvDEPTH(cv) >= 2) {
2985             PERL_STACK_OVERFLOW_CHECK();
2986             pad_push(padlist, CvDEPTH(cv));
2987         }
2988         SAVECOMPPAD();
2989         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2990         if (hasargs) {
2991             AV *const av = MUTABLE_AV(PAD_SVl(0));
2992             if (AvREAL(av)) {
2993                 /* @_ is normally not REAL--this should only ever
2994                  * happen when DB::sub() calls things that modify @_ */
2995                 av_clear(av);
2996                 AvREAL_off(av);
2997                 AvREIFY_on(av);
2998             }
2999             cx->blk_sub.savearray = GvAV(PL_defgv);
3000             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
3001             CX_CURPAD_SAVE(cx->blk_sub);
3002             cx->blk_sub.argarray = av;
3003             ++MARK;
3004
3005             if (items > AvMAX(av) + 1) {
3006                 SV **ary = AvALLOC(av);
3007                 if (AvARRAY(av) != ary) {
3008                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
3009                     AvARRAY(av) = ary;
3010                 }
3011                 if (items > AvMAX(av) + 1) {
3012                     AvMAX(av) = items - 1;
3013                     Renew(ary,items,SV*);
3014                     AvALLOC(av) = ary;
3015                     AvARRAY(av) = ary;
3016                 }
3017             }
3018             Copy(MARK,AvARRAY(av),items,SV*);
3019             AvFILLp(av) = items - 1;
3020
3021             while (items--) {
3022                 if (*MARK)
3023                     SvTEMP_off(*MARK);
3024                 MARK++;
3025             }
3026         }
3027         /* warning must come *after* we fully set up the context
3028          * stuff so that __WARN__ handlers can safely dounwind()
3029          * if they want to
3030          */
3031         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
3032             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
3033             sub_crush_depth(cv);
3034         RETURNOP(CvSTART(cv));
3035     }
3036     else {
3037         I32 markix = TOPMARK;
3038
3039         PUTBACK;
3040
3041         if (!hasargs) {
3042             /* Need to copy @_ to stack. Alternative may be to
3043              * switch stack to @_, and copy return values
3044              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3045             AV * const av = GvAV(PL_defgv);
3046             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
3047
3048             if (items) {
3049                 /* Mark is at the end of the stack. */
3050                 EXTEND(SP, items);
3051                 Copy(AvARRAY(av), SP + 1, items, SV*);
3052                 SP += items;
3053                 PUTBACK ;
3054             }
3055         }
3056         /* We assume first XSUB in &DB::sub is the called one. */
3057         if (PL_curcopdb) {
3058             SAVEVPTR(PL_curcop);
3059             PL_curcop = PL_curcopdb;
3060             PL_curcopdb = NULL;
3061         }
3062         /* Do we need to open block here? XXXX */
3063
3064         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3065         assert(CvXSUB(cv));
3066         CvXSUB(cv)(aTHX_ cv);
3067
3068         /* Enforce some sanity in scalar context. */
3069         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
3070             if (markix > PL_stack_sp - PL_stack_base)
3071                 *(PL_stack_base + markix) = &PL_sv_undef;
3072             else
3073                 *(PL_stack_base + markix) = *PL_stack_sp;
3074             PL_stack_sp = PL_stack_base + markix;
3075         }
3076         LEAVE;
3077         return NORMAL;
3078     }
3079 }
3080
3081 void
3082 Perl_sub_crush_depth(pTHX_ CV *cv)
3083 {
3084     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3085
3086     if (CvANON(cv))
3087         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3088     else {
3089         SV* const tmpstr = sv_newmortal();
3090         gv_efullname3(tmpstr, CvGV(cv), NULL);
3091         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3092                     SVfARG(tmpstr));
3093     }
3094 }
3095
3096 PP(pp_aelem)
3097 {
3098     dVAR; dSP;
3099     SV** svp;
3100     SV* const elemsv = POPs;
3101     IV elem = SvIV(elemsv);
3102     AV *const av = MUTABLE_AV(POPs);
3103     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3104     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
3105     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3106     bool preeminent = TRUE;
3107     SV *sv;
3108
3109     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3110         Perl_warner(aTHX_ packWARN(WARN_MISC),
3111                     "Use of reference \"%"SVf"\" as array index",
3112                     SVfARG(elemsv));
3113     if (elem > 0)
3114         elem -= CopARYBASE_get(PL_curcop);
3115     if (SvTYPE(av) != SVt_PVAV)
3116         RETPUSHUNDEF;
3117
3118     if (localizing) {
3119         MAGIC *mg;
3120         HV *stash;
3121
3122         /* If we can determine whether the element exist,
3123          * Try to preserve the existenceness of a tied array
3124          * element by using EXISTS and DELETE if possible.
3125          * Fallback to FETCH and STORE otherwise. */
3126         if (SvCANEXISTDELETE(av))
3127             preeminent = av_exists(av, elem);
3128     }
3129
3130     svp = av_fetch(av, elem, lval && !defer);
3131     if (lval) {
3132 #ifdef PERL_MALLOC_WRAP
3133          if (SvUOK(elemsv)) {
3134               const UV uv = SvUV(elemsv);
3135               elem = uv > IV_MAX ? IV_MAX : uv;
3136          }
3137          else if (SvNOK(elemsv))
3138               elem = (IV)SvNV(elemsv);
3139          if (elem > 0) {
3140               static const char oom_array_extend[] =
3141                 "Out of memory during array extend"; /* Duplicated in av.c */
3142               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3143          }
3144 #endif
3145         if (!svp || *svp == &PL_sv_undef) {
3146             SV* lv;
3147             if (!defer)
3148                 DIE(aTHX_ PL_no_aelem, elem);
3149             lv = sv_newmortal();
3150             sv_upgrade(lv, SVt_PVLV);
3151             LvTYPE(lv) = 'y';
3152             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3153             LvTARG(lv) = SvREFCNT_inc_simple(av);
3154             LvTARGOFF(lv) = elem;
3155             LvTARGLEN(lv) = 1;
3156             PUSHs(lv);
3157             RETURN;
3158         }
3159         if (localizing) {
3160             if (preeminent)
3161                 save_aelem(av, elem, svp);
3162             else
3163                 SAVEADELETE(av, elem);
3164         }
3165         else if (PL_op->op_private & OPpDEREF)
3166             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3167     }
3168     sv = (svp ? *svp : &PL_sv_undef);
3169     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3170         mg_get(sv);
3171     PUSHs(sv);
3172     RETURN;
3173 }
3174
3175 void
3176 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3177 {
3178     PERL_ARGS_ASSERT_VIVIFY_REF;
3179
3180     SvGETMAGIC(sv);
3181     if (!SvOK(sv)) {
3182         if (SvREADONLY(sv))
3183             Perl_croak_no_modify(aTHX);
3184         prepare_SV_for_RV(sv);
3185         switch (to_what) {
3186         case OPpDEREF_SV:
3187             SvRV_set(sv, newSV(0));
3188             break;
3189         case OPpDEREF_AV:
3190             SvRV_set(sv, MUTABLE_SV(newAV()));
3191             break;
3192         case OPpDEREF_HV:
3193             SvRV_set(sv, MUTABLE_SV(newHV()));
3194             break;
3195         }
3196         SvROK_on(sv);
3197         SvSETMAGIC(sv);
3198     }
3199 }
3200
3201 PP(pp_method)
3202 {
3203     dVAR; dSP;
3204     SV* const sv = TOPs;
3205
3206     if (SvROK(sv)) {
3207         SV* const rsv = SvRV(sv);
3208         if (SvTYPE(rsv) == SVt_PVCV) {
3209             SETs(rsv);
3210             RETURN;
3211         }
3212     }
3213
3214     SETs(method_common(sv, NULL));
3215     RETURN;
3216 }
3217
3218 PP(pp_method_named)
3219 {
3220     dVAR; dSP;
3221     SV* const sv = cSVOP_sv;
3222     U32 hash = SvSHARED_HASH(sv);
3223
3224     XPUSHs(method_common(sv, &hash));
3225     RETURN;
3226 }
3227
3228 STATIC SV *
3229 S_method_common(pTHX_ SV* meth, U32* hashp)
3230 {
3231     dVAR;
3232     SV* ob;
3233     GV* gv;
3234     HV* stash;
3235     const char* packname = NULL;
3236     SV *packsv = NULL;
3237     STRLEN packlen;
3238     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3239
3240     PERL_ARGS_ASSERT_METHOD_COMMON;
3241
3242     if (!sv)
3243         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3244                    SVfARG(meth));
3245
3246     SvGETMAGIC(sv);
3247     if (SvROK(sv))
3248         ob = MUTABLE_SV(SvRV(sv));
3249     else {
3250         GV* iogv;
3251
3252         /* this isn't a reference */
3253         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3254           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3255           if (he) {
3256             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3257             goto fetch;
3258           }
3259         }
3260
3261         if (!SvOK(sv) ||
3262             !(packname) ||
3263             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3264             !(ob=MUTABLE_SV(GvIO(iogv))))
3265         {
3266             /* this isn't the name of a filehandle either */
3267             if (!packname ||
3268                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3269                     ? !isIDFIRST_utf8((U8*)packname)
3270                     : !isIDFIRST(*packname)
3271                 ))
3272             {
3273                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3274                            SVfARG(meth),
3275                            SvOK(sv) ? "without a package or object reference"
3276                                     : "on an undefined value");
3277             }
3278             /* assume it's a package name */
3279             stash = gv_stashpvn(packname, packlen, 0);
3280             if (!stash)
3281                 packsv = sv;
3282             else {
3283                 SV* const ref = newSViv(PTR2IV(stash));
3284                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3285             }
3286             goto fetch;
3287         }
3288         /* it _is_ a filehandle name -- replace with a reference */
3289         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3290     }
3291
3292     /* if we got here, ob should be a reference or a glob */
3293     if (!ob || !(SvOBJECT(ob)
3294                  || (SvTYPE(ob) == SVt_PVGV
3295                      && isGV_with_GP(ob)
3296                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3297                      && SvOBJECT(ob))))
3298     {
3299         const char * const name = SvPV_nolen_const(meth);
3300         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3301                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3302                    name);
3303     }
3304
3305     stash = SvSTASH(ob);
3306
3307   fetch:
3308     /* NOTE: stash may be null, hope hv_fetch_ent and
3309        gv_fetchmethod can cope (it seems they can) */
3310
3311     /* shortcut for simple names */
3312     if (hashp) {
3313         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3314         if (he) {
3315             gv = MUTABLE_GV(HeVAL(he));
3316             if (isGV(gv) && GvCV(gv) &&
3317                 (!GvCVGEN(gv) || GvCVGEN(gv)
3318                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3319                 return MUTABLE_SV(GvCV(gv));
3320         }
3321     }
3322
3323     gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3324                               SvPV_nolen_const(meth),
3325                               GV_AUTOLOAD | GV_CROAK);
3326
3327     assert(gv);
3328
3329     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3330 }
3331
3332 /*
3333  * Local variables:
3334  * c-indentation-style: bsd
3335  * c-basic-offset: 4
3336  * indent-tabs-mode: t
3337  * End:
3338  *
3339  * ex: set ts=8 sts=4 sw=4 noet:
3340  */