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