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      * Don't bother if LHS is just an empty hash or array.
 993      */
 994
 995     if (    (PL_op->op_private & OPpASSIGN_COMMON)
 996         &&  (
 997                firstlelem != lastlelem
 998             || ! ((sv = *firstlelem))
 999             || SvMAGICAL(sv)
1000             || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1001             || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1002             || (SvTYPE(sv) == SVt_PVHV && HvKEYS((HV*)sv) != 0)
1003             )
1004     ) {
1005         EXTEND_MORTAL(lastrelem - firstrelem + 1);
1006         for (relem = firstrelem; relem <= lastrelem; relem++) {
1007             if ((sv = *relem)) {
1008                 TAINT_NOT;      /* Each item is independent */
1009
1010                 /* Dear TODO test in t/op/sort.t, I love you.
1011                    (It's relying on a panic, not a "semi-panic" from newSVsv()
1012                    and then an assertion failure below.)  */
1013                 if (SvIS_FREED(sv)) {
1014                     Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1015                                (void*)sv);
1016                 }
1017                 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1018                    and we need a second copy of a temp here.  */
1019                 *relem = sv_2mortal(newSVsv(sv));
1020             }
1021         }
1022     }
1023
1024     relem = firstrelem;
1025     lelem = firstlelem;
1026     ary = NULL;
1027     hash = NULL;
1028
1029     while (lelem <= lastlelem) {
1030         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1031         sv = *lelem++;
1032         switch (SvTYPE(sv)) {
1033         case SVt_PVAV:
1034             ary = MUTABLE_AV(sv);
1035             magic = SvMAGICAL(ary) != 0;
1036             av_clear(ary);
1037             av_extend(ary, lastrelem - relem);
1038             i = 0;
1039             while (relem <= lastrelem) {        /* gobble up all the rest */
1040                 SV **didstore;
1041                 assert(*relem);
1042                 sv = newSV(0);
1043                 sv_setsv(sv, *relem);
1044                 *(relem++) = sv;
1045                 didstore = av_store(ary,i++,sv);
1046                 if (magic) {
1047                     if (SvSMAGICAL(sv))
1048                         mg_set(sv);
1049                     if (!didstore)
1050                         sv_2mortal(sv);
1051                 }
1052                 TAINT_NOT;
1053             }
1054             if (PL_delaymagic & DM_ARRAY_ISA)
1055                 SvSETMAGIC(MUTABLE_SV(ary));
1056             break;
1057         case SVt_PVHV: {                                /* normal hash */
1058                 SV *tmpstr;
1059                 SV** topelem = relem;
1060
1061                 hash = MUTABLE_HV(sv);
1062                 magic = SvMAGICAL(hash) != 0;
1063                 hv_clear(hash);
1064                 firsthashrelem = relem;
1065
1066                 while (relem < lastrelem) {     /* gobble up all the rest */
1067                     HE *didstore;
1068                     sv = *relem ? *relem : &PL_sv_no;
1069                     relem++;
1070                     tmpstr = newSV(0);
1071                     if (*relem)
1072                         sv_setsv(tmpstr,*relem);        /* value */
1073                     relem++;
1074                     if (gimme != G_VOID) {
1075                         if (hv_exists_ent(hash, sv, 0))
1076                             /* key overwrites an existing entry */
1077                             duplicates += 2;
1078                         else
1079                         if (gimme == G_ARRAY) {
1080                             /* copy element back: possibly to an earlier
1081                              * stack location if we encountered dups earlier */
1082                             *topelem++ = sv;
1083                             *topelem++ = tmpstr;
1084                         }
1085                     }
1086                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1087                     if (magic) {
1088                         if (SvSMAGICAL(tmpstr))
1089                             mg_set(tmpstr);
1090                         if (!didstore)
1091                             sv_2mortal(tmpstr);
1092                     }
1093                     TAINT_NOT;
1094                 }
1095                 if (relem == lastrelem) {
1096                     do_oddball(hash, relem, firstrelem);
1097                     relem++;
1098                 }
1099             }
1100             break;
1101         default:
1102             if (SvIMMORTAL(sv)) {
1103                 if (relem <= lastrelem)
1104                     relem++;
1105                 break;
1106             }
1107             if (relem <= lastrelem) {
1108                 sv_setsv(sv, *relem);
1109                 *(relem++) = sv;
1110             }
1111             else
1112                 sv_setsv(sv, &PL_sv_undef);
1113             SvSETMAGIC(sv);
1114             break;
1115         }
1116     }
1117     if (PL_delaymagic & ~DM_DELAY) {
1118         if (PL_delaymagic & DM_UID) {
1119 #ifdef HAS_SETRESUID
1120             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1121                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1122                             (Uid_t)-1);
1123 #else
1124 #  ifdef HAS_SETREUID
1125             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1126                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1127 #  else
1128 #    ifdef HAS_SETRUID
1129             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1130                 (void)setruid(PL_uid);
1131                 PL_delaymagic &= ~DM_RUID;
1132             }
1133 #    endif /* HAS_SETRUID */
1134 #    ifdef HAS_SETEUID
1135             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1136                 (void)seteuid(PL_euid);
1137                 PL_delaymagic &= ~DM_EUID;
1138             }
1139 #    endif /* HAS_SETEUID */
1140             if (PL_delaymagic & DM_UID) {
1141                 if (PL_uid != PL_euid)
1142                     DIE(aTHX_ "No setreuid available");
1143                 (void)PerlProc_setuid(PL_uid);
1144             }
1145 #  endif /* HAS_SETREUID */
1146 #endif /* HAS_SETRESUID */
1147             PL_uid = PerlProc_getuid();
1148             PL_euid = PerlProc_geteuid();
1149         }
1150         if (PL_delaymagic & DM_GID) {
1151 #ifdef HAS_SETRESGID
1152             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1153                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1154                             (Gid_t)-1);
1155 #else
1156 #  ifdef HAS_SETREGID
1157             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1158                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1159 #  else
1160 #    ifdef HAS_SETRGID
1161             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1162                 (void)setrgid(PL_gid);
1163                 PL_delaymagic &= ~DM_RGID;
1164             }
1165 #    endif /* HAS_SETRGID */
1166 #    ifdef HAS_SETEGID
1167             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1168                 (void)setegid(PL_egid);
1169                 PL_delaymagic &= ~DM_EGID;
1170             }
1171 #    endif /* HAS_SETEGID */
1172             if (PL_delaymagic & DM_GID) {
1173                 if (PL_gid != PL_egid)
1174                     DIE(aTHX_ "No setregid available");
1175                 (void)PerlProc_setgid(PL_gid);
1176             }
1177 #  endif /* HAS_SETREGID */
1178 #endif /* HAS_SETRESGID */
1179             PL_gid = PerlProc_getgid();
1180             PL_egid = PerlProc_getegid();
1181         }
1182         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1183     }
1184     PL_delaymagic = 0;
1185
1186     if (gimme == G_VOID)
1187         SP = firstrelem - 1;
1188     else if (gimme == G_SCALAR) {
1189         dTARGET;
1190         SP = firstrelem;
1191         SETi(lastrelem - firstrelem + 1 - duplicates);
1192     }
1193     else {
1194         if (ary)
1195             SP = lastrelem;
1196         else if (hash) {
1197             if (duplicates) {
1198                 /* at this point we have removed the duplicate key/value
1199                  * pairs from the stack, but the remaining values may be
1200                  * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1201                  * the (a 2), but the stack now probably contains
1202                  * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1203                  * obliterates the earlier key. So refresh all values. */
1204                 lastrelem -= duplicates;
1205                 relem = firsthashrelem;
1206                 while (relem < lastrelem) {
1207                     HE *he;
1208                     sv = *relem++;
1209                     he = hv_fetch_ent(hash, sv, 0, 0);
1210                     *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1211                 }
1212             }
1213             SP = lastrelem;
1214         }
1215         else
1216             SP = firstrelem + (lastlelem - firstlelem);
1217         lelem = firstlelem + (relem - firstrelem);
1218         while (relem <= SP)
1219             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1220     }
1221
1222     RETURN;
1223 }
1224
1225 PP(pp_qr)
1226 {
1227     dVAR; dSP;
1228     register PMOP * const pm = cPMOP;
1229     REGEXP * rx = PM_GETRE(pm);
1230     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1231     SV * const rv = sv_newmortal();
1232
1233     SvUPGRADE(rv, SVt_IV);
1234     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1235        loathe to use it here, but it seems to be the right fix. Or close.
1236        The key part appears to be that it's essential for pp_qr to return a new
1237        object (SV), which implies that there needs to be an effective way to
1238        generate a new SV from the existing SV that is pre-compiled in the
1239        optree.  */
1240     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1241     SvROK_on(rv);
1242
1243     if (pkg) {
1244         HV *const stash = gv_stashsv(pkg, GV_ADD);
1245         SvREFCNT_dec(pkg);
1246         (void)sv_bless(rv, stash);
1247     }
1248
1249     if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1250         SvTAINTED_on(rv);
1251         SvTAINTED_on(SvRV(rv));
1252     }
1253     XPUSHs(rv);
1254     RETURN;
1255 }
1256
1257 PP(pp_match)
1258 {
1259     dVAR; dSP; dTARG;
1260     register PMOP *pm = cPMOP;
1261     PMOP *dynpm = pm;
1262     register const char *t;
1263     register const char *s;
1264     const char *strend;
1265     I32 global;
1266     U8 r_flags = REXEC_CHECKED;
1267     const char *truebase;                       /* Start of string  */
1268     register REGEXP *rx = PM_GETRE(pm);
1269     bool rxtainted;
1270     const I32 gimme = GIMME;
1271     STRLEN len;
1272     I32 minmatch = 0;
1273     const I32 oldsave = PL_savestack_ix;
1274     I32 update_minmatch = 1;
1275     I32 had_zerolen = 0;
1276     U32 gpos = 0;
1277
1278     if (PL_op->op_flags & OPf_STACKED)
1279         TARG = POPs;
1280     else if (PL_op->op_private & OPpTARGET_MY)
1281         GETTARGET;
1282     else {
1283         TARG = DEFSV;
1284         EXTEND(SP,1);
1285     }
1286
1287     PUTBACK;                            /* EVAL blocks need stack_sp. */
1288     /* Skip get-magic if this is a qr// clone, because regcomp has
1289        already done it. */
1290     s = ((struct regexp *)SvANY(rx))->mother_re
1291          ? SvPV_nomg_const(TARG, len)
1292          : SvPV_const(TARG, len);
1293     if (!s)
1294         DIE(aTHX_ "panic: pp_match");
1295     strend = s + len;
1296     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1297                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1298     TAINT_NOT;
1299
1300     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1301
1302     /* PMdf_USED is set after a ?? matches once */
1303     if (
1304 #ifdef USE_ITHREADS
1305         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1306 #else
1307         pm->op_pmflags & PMf_USED
1308 #endif
1309     ) {
1310       failure:
1311         if (gimme == G_ARRAY)
1312             RETURN;
1313         RETPUSHNO;
1314     }
1315
1316
1317
1318     /* empty pattern special-cased to use last successful pattern if possible */
1319     if (!RX_PRELEN(rx) && PL_curpm) {
1320         pm = PL_curpm;
1321         rx = PM_GETRE(pm);
1322     }
1323
1324     if (RX_MINLEN(rx) > (I32)len)
1325         goto failure;
1326
1327     truebase = t = s;
1328
1329     /* XXXX What part of this is needed with true \G-support? */
1330     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1331         RX_OFFS(rx)[0].start = -1;
1332         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1333             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1334             if (mg && mg->mg_len >= 0) {
1335                 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1336                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1337                 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1338                     r_flags |= REXEC_IGNOREPOS;
1339                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1340                 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1341                     gpos = mg->mg_len;
1342                 else
1343                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1344                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1345                 update_minmatch = 0;
1346             }
1347         }
1348     }
1349     /* XXX: comment out !global get safe $1 vars after a
1350        match, BUT be aware that this leads to dramatic slowdowns on
1351        /g matches against large strings.  So far a solution to this problem
1352        appears to be quite tricky.
1353        Test for the unsafe vars are TODO for now. */
1354     if (       (!global && RX_NPARENS(rx))
1355             || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1356             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1357         r_flags |= REXEC_COPY_STR;
1358     if (SvSCREAM(TARG))
1359         r_flags |= REXEC_SCREAM;
1360
1361   play_it_again:
1362     if (global && RX_OFFS(rx)[0].start != -1) {
1363         t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1364         if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1365             goto nope;
1366         if (update_minmatch++)
1367             minmatch = had_zerolen;
1368     }
1369     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1370         DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1371         /* FIXME - can PL_bostr be made const char *?  */
1372         PL_bostr = (char *)truebase;
1373         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1374
1375         if (!s)
1376             goto nope;
1377         if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1378              && !PL_sawampersand
1379              && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1380              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1381                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1382                       && (r_flags & REXEC_SCREAM)))
1383              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1384             goto yup;
1385     }
1386     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1387                     minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1388     {
1389         PL_curpm = pm;
1390         if (dynpm->op_pmflags & PMf_ONCE) {
1391 #ifdef USE_ITHREADS
1392             SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1393 #else
1394             dynpm->op_pmflags |= PMf_USED;
1395 #endif
1396         }
1397         goto gotcha;
1398     }
1399     else
1400         goto ret_no;
1401     /*NOTREACHED*/
1402
1403   gotcha:
1404     if (rxtainted)
1405         RX_MATCH_TAINTED_on(rx);
1406     TAINT_IF(RX_MATCH_TAINTED(rx));
1407     if (gimme == G_ARRAY) {
1408         const I32 nparens = RX_NPARENS(rx);
1409         I32 i = (global && !nparens) ? 1 : 0;
1410
1411         SPAGAIN;                        /* EVAL blocks could move the stack. */
1412         EXTEND(SP, nparens + i);
1413         EXTEND_MORTAL(nparens + i);
1414         for (i = !i; i <= nparens; i++) {
1415             PUSHs(sv_newmortal());
1416             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1417                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1418                 s = RX_OFFS(rx)[i].start + truebase;
1419                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1420                     len < 0 || len > strend - s)
1421                     DIE(aTHX_ "panic: pp_match start/end pointers");
1422                 sv_setpvn(*SP, s, len);
1423                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1424                     SvUTF8_on(*SP);
1425             }
1426         }
1427         if (global) {
1428             if (dynpm->op_pmflags & PMf_CONTINUE) {
1429                 MAGIC* mg = NULL;
1430                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1431                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1432                 if (!mg) {
1433 #ifdef PERL_OLD_COPY_ON_WRITE
1434                     if (SvIsCOW(TARG))
1435                         sv_force_normal_flags(TARG, 0);
1436 #endif
1437                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1438                                      &PL_vtbl_mglob, NULL, 0);
1439                 }
1440                 if (RX_OFFS(rx)[0].start != -1) {
1441                     mg->mg_len = RX_OFFS(rx)[0].end;
1442                     if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1443                         mg->mg_flags |= MGf_MINMATCH;
1444                     else
1445                         mg->mg_flags &= ~MGf_MINMATCH;
1446                 }
1447             }
1448             had_zerolen = (RX_OFFS(rx)[0].start != -1
1449                            && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1450                                == (UV)RX_OFFS(rx)[0].end));
1451             PUTBACK;                    /* EVAL blocks may use stack */
1452             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1453             goto play_it_again;
1454         }
1455         else if (!nparens)
1456             XPUSHs(&PL_sv_yes);
1457         LEAVE_SCOPE(oldsave);
1458         RETURN;
1459     }
1460     else {
1461         if (global) {
1462             MAGIC* mg;
1463             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1464                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1465             else
1466                 mg = NULL;
1467             if (!mg) {
1468 #ifdef PERL_OLD_COPY_ON_WRITE
1469                 if (SvIsCOW(TARG))
1470                     sv_force_normal_flags(TARG, 0);
1471 #endif
1472                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1473                                  &PL_vtbl_mglob, NULL, 0);
1474             }
1475             if (RX_OFFS(rx)[0].start != -1) {
1476                 mg->mg_len = RX_OFFS(rx)[0].end;
1477                 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1478                     mg->mg_flags |= MGf_MINMATCH;
1479                 else
1480                     mg->mg_flags &= ~MGf_MINMATCH;
1481             }
1482         }
1483         LEAVE_SCOPE(oldsave);
1484         RETPUSHYES;
1485     }
1486
1487 yup:                                    /* Confirmed by INTUIT */
1488     if (rxtainted)
1489         RX_MATCH_TAINTED_on(rx);
1490     TAINT_IF(RX_MATCH_TAINTED(rx));
1491     PL_curpm = pm;
1492     if (dynpm->op_pmflags & PMf_ONCE) {
1493 #ifdef USE_ITHREADS
1494         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1495 #else
1496         dynpm->op_pmflags |= PMf_USED;
1497 #endif
1498     }
1499     if (RX_MATCH_COPIED(rx))
1500         Safefree(RX_SUBBEG(rx));
1501     RX_MATCH_COPIED_off(rx);
1502     RX_SUBBEG(rx) = NULL;
1503     if (global) {
1504         /* FIXME - should rx->subbeg be const char *?  */
1505         RX_SUBBEG(rx) = (char *) truebase;
1506         RX_OFFS(rx)[0].start = s - truebase;
1507         if (RX_MATCH_UTF8(rx)) {
1508             char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1509             RX_OFFS(rx)[0].end = t - truebase;
1510         }
1511         else {
1512             RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1513         }
1514         RX_SUBLEN(rx) = strend - truebase;
1515         goto gotcha;
1516     }
1517     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1518         I32 off;
1519 #ifdef PERL_OLD_COPY_ON_WRITE
1520         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1521             if (DEBUG_C_TEST) {
1522                 PerlIO_printf(Perl_debug_log,
1523                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1524                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1525                               (int)(t-truebase));
1526             }
1527             RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1528             RX_SUBBEG(rx)
1529                 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1530             assert (SvPOKp(RX_SAVED_COPY(rx)));
1531         } else
1532 #endif
1533         {
1534
1535             RX_SUBBEG(rx) = savepvn(t, strend - t);
1536 #ifdef PERL_OLD_COPY_ON_WRITE
1537             RX_SAVED_COPY(rx) = NULL;
1538 #endif
1539         }
1540         RX_SUBLEN(rx) = strend - t;
1541         RX_MATCH_COPIED_on(rx);
1542         off = RX_OFFS(rx)[0].start = s - t;
1543         RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1544     }
1545     else {                      /* startp/endp are used by @- @+. */
1546         RX_OFFS(rx)[0].start = s - truebase;
1547         RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1548     }
1549     /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1550        -dmq */
1551     RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;      /* used by @-, @+, and $^N */
1552     LEAVE_SCOPE(oldsave);
1553     RETPUSHYES;
1554
1555 nope:
1556 ret_no:
1557     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1558         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1559             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1560             if (mg)
1561                 mg->mg_len = -1;
1562         }
1563     }
1564     LEAVE_SCOPE(oldsave);
1565     if (gimme == G_ARRAY)
1566         RETURN;
1567     RETPUSHNO;
1568 }
1569
1570 OP *
1571 Perl_do_readline(pTHX)
1572 {
1573     dVAR; dSP; dTARGETSTACKED;
1574     register SV *sv;
1575     STRLEN tmplen = 0;
1576     STRLEN offset;
1577     PerlIO *fp;
1578     register IO * const io = GvIO(PL_last_in_gv);
1579     register const I32 type = PL_op->op_type;
1580     const I32 gimme = GIMME_V;
1581
1582     if (io) {
1583         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1584         if (mg) {
1585             Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1586             if (gimme == G_SCALAR) {
1587                 SPAGAIN;
1588                 SvSetSV_nosteal(TARG, TOPs);
1589                 SETTARG;
1590             }
1591             return NORMAL;
1592         }
1593     }
1594     fp = NULL;
1595     if (io) {
1596         fp = IoIFP(io);
1597         if (!fp) {
1598             if (IoFLAGS(io) & IOf_ARGV) {
1599                 if (IoFLAGS(io) & IOf_START) {
1600                     IoLINES(io) = 0;
1601                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1602                         IoFLAGS(io) &= ~IOf_START;
1603                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1604                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1605                         SvSETMAGIC(GvSV(PL_last_in_gv));
1606                         fp = IoIFP(io);
1607                         goto have_fp;
1608                     }
1609                 }
1610                 fp = nextargv(PL_last_in_gv);
1611                 if (!fp) { /* Note: fp != IoIFP(io) */
1612                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1613                 }
1614             }
1615             else if (type == OP_GLOB)
1616                 fp = Perl_start_glob(aTHX_ POPs, io);
1617         }
1618         else if (type == OP_GLOB)
1619             SP--;
1620         else if (IoTYPE(io) == IoTYPE_WRONLY) {
1621             report_wrongway_fh(PL_last_in_gv, '>');
1622         }
1623     }
1624     if (!fp) {
1625         if ((!io || !(IoFLAGS(io) & IOf_START))
1626             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1627         {
1628             if (type == OP_GLOB)
1629                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1630                             "glob failed (can't start child: %s)",
1631                             Strerror(errno));
1632             else
1633                 report_evil_fh(PL_last_in_gv);
1634         }
1635         if (gimme == G_SCALAR) {
1636             /* undef TARG, and push that undefined value */
1637             if (type != OP_RCATLINE) {
1638                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1639                 SvOK_off(TARG);
1640             }
1641             PUSHTARG;
1642         }
1643         RETURN;
1644     }
1645   have_fp:
1646     if (gimme == G_SCALAR) {
1647         sv = TARG;
1648         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1649             mg_get(sv);
1650         if (SvROK(sv)) {
1651             if (type == OP_RCATLINE)
1652                 SvPV_force_nolen(sv);
1653             else
1654                 sv_unref(sv);
1655         }
1656         else if (isGV_with_GP(sv)) {
1657             SvPV_force_nolen(sv);
1658         }
1659         SvUPGRADE(sv, SVt_PV);
1660         tmplen = SvLEN(sv);     /* remember if already alloced */
1661         if (!tmplen && !SvREADONLY(sv)) {
1662             /* try short-buffering it. Please update t/op/readline.t
1663              * if you change the growth length.
1664              */
1665             Sv_Grow(sv, 80);
1666         }
1667         offset = 0;
1668         if (type == OP_RCATLINE && SvOK(sv)) {
1669             if (!SvPOK(sv)) {
1670                 SvPV_force_nolen(sv);
1671             }
1672             offset = SvCUR(sv);
1673         }
1674     }
1675     else {
1676         sv = sv_2mortal(newSV(80));
1677         offset = 0;
1678     }
1679
1680     /* This should not be marked tainted if the fp is marked clean */
1681 #define MAYBE_TAINT_LINE(io, sv) \
1682     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1683         TAINT;                          \
1684         SvTAINTED_on(sv);               \
1685     }
1686
1687 /* delay EOF state for a snarfed empty file */
1688 #define SNARF_EOF(gimme,rs,io,sv) \
1689     (gimme != G_SCALAR || SvCUR(sv)                                     \
1690      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1691
1692     for (;;) {
1693         PUTBACK;
1694         if (!sv_gets(sv, fp, offset)
1695             && (type == OP_GLOB
1696                 || SNARF_EOF(gimme, PL_rs, io, sv)
1697                 || PerlIO_error(fp)))
1698         {
1699             PerlIO_clearerr(fp);
1700             if (IoFLAGS(io) & IOf_ARGV) {
1701                 fp = nextargv(PL_last_in_gv);
1702                 if (fp)
1703                     continue;
1704                 (void)do_close(PL_last_in_gv, FALSE);
1705             }
1706             else if (type == OP_GLOB) {
1707                 if (!do_close(PL_last_in_gv, FALSE)) {
1708                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1709                                    "glob failed (child exited with status %d%s)",
1710                                    (int)(STATUS_CURRENT >> 8),
1711                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1712                 }
1713             }
1714             if (gimme == G_SCALAR) {
1715                 if (type != OP_RCATLINE) {
1716                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1717                     SvOK_off(TARG);
1718                 }
1719                 SPAGAIN;
1720                 PUSHTARG;
1721             }
1722             MAYBE_TAINT_LINE(io, sv);
1723             RETURN;
1724         }
1725         MAYBE_TAINT_LINE(io, sv);
1726         IoLINES(io)++;
1727         IoFLAGS(io) |= IOf_NOLINE;
1728         SvSETMAGIC(sv);
1729         SPAGAIN;
1730         XPUSHs(sv);
1731         if (type == OP_GLOB) {
1732             const char *t1;
1733
1734             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1735                 char * const tmps = SvEND(sv) - 1;
1736                 if (*tmps == *SvPVX_const(PL_rs)) {
1737                     *tmps = '\0';
1738                     SvCUR_set(sv, SvCUR(sv) - 1);
1739                 }
1740             }
1741             for (t1 = SvPVX_const(sv); *t1; t1++)
1742                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1743                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1744                         break;
1745             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1746                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1747                 continue;
1748             }
1749         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1750              if (ckWARN(WARN_UTF8)) {
1751                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1752                 const STRLEN len = SvCUR(sv) - offset;
1753                 const U8 *f;
1754
1755                 if (!is_utf8_string_loc(s, len, &f))
1756                     /* Emulate :encoding(utf8) warning in the same case. */
1757                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1758                                 "utf8 \"\\x%02X\" does not map to Unicode",
1759                                 f < (U8*)SvEND(sv) ? *f : 0);
1760              }
1761         }
1762         if (gimme == G_ARRAY) {
1763             if (SvLEN(sv) - SvCUR(sv) > 20) {
1764                 SvPV_shrink_to_cur(sv);
1765             }
1766             sv = sv_2mortal(newSV(80));
1767             continue;
1768         }
1769         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1770             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1771             const STRLEN new_len
1772                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1773             SvPV_renew(sv, new_len);
1774         }
1775         RETURN;
1776     }
1777 }
1778
1779 PP(pp_enter)
1780 {
1781     dVAR; dSP;
1782     register PERL_CONTEXT *cx;
1783     I32 gimme = OP_GIMME(PL_op, -1);
1784
1785     if (gimme == -1) {
1786         if (cxstack_ix >= 0) {
1787             /* If this flag is set, we're just inside a return, so we should
1788              * store the caller's context */
1789             gimme = (PL_op->op_flags & OPf_SPECIAL)
1790                 ? block_gimme()
1791                 : cxstack[cxstack_ix].blk_gimme;
1792         } else
1793             gimme = G_SCALAR;
1794     }
1795
1796     ENTER_with_name("block");
1797
1798     SAVETMPS;
1799     PUSHBLOCK(cx, CXt_BLOCK, SP);
1800
1801     RETURN;
1802 }
1803
1804 PP(pp_helem)
1805 {
1806     dVAR; dSP;
1807     HE* he;
1808     SV **svp;
1809     SV * const keysv = POPs;
1810     HV * const hv = MUTABLE_HV(POPs);
1811     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1812     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1813     SV *sv;
1814     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1815     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1816     bool preeminent = TRUE;
1817
1818     if (SvTYPE(hv) != SVt_PVHV)
1819         RETPUSHUNDEF;
1820
1821     if (localizing) {
1822         MAGIC *mg;
1823         HV *stash;
1824
1825         /* If we can determine whether the element exist,
1826          * Try to preserve the existenceness of a tied hash
1827          * element by using EXISTS and DELETE if possible.
1828          * Fallback to FETCH and STORE otherwise. */
1829         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1830             preeminent = hv_exists_ent(hv, keysv, 0);
1831     }
1832
1833     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1834     svp = he ? &HeVAL(he) : NULL;
1835     if (lval) {
1836         if (!svp || *svp == &PL_sv_undef) {
1837             SV* lv;
1838             SV* key2;
1839             if (!defer) {
1840                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1841             }
1842             lv = sv_newmortal();
1843             sv_upgrade(lv, SVt_PVLV);
1844             LvTYPE(lv) = 'y';
1845             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1846             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1847             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1848             LvTARGLEN(lv) = 1;
1849             PUSHs(lv);
1850             RETURN;
1851         }
1852         if (localizing) {
1853             if (HvNAME_get(hv) && isGV(*svp))
1854                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1855             else if (preeminent)
1856                 save_helem_flags(hv, keysv, svp,
1857                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1858             else
1859                 SAVEHDELETE(hv, keysv);
1860         }
1861         else if (PL_op->op_private & OPpDEREF)
1862             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1863     }
1864     sv = (svp ? *svp : &PL_sv_undef);
1865     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1866      * was to make C<local $tied{foo} = $tied{foo}> possible.
1867      * However, it seems no longer to be needed for that purpose, and
1868      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1869      * would loop endlessly since the pos magic is getting set on the
1870      * mortal copy and lost. However, the copy has the effect of
1871      * triggering the get magic, and losing it altogether made things like
1872      * c<$tied{foo};> in void context no longer do get magic, which some
1873      * code relied on. Also, delayed triggering of magic on @+ and friends
1874      * meant the original regex may be out of scope by now. So as a
1875      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1876      * being called too many times). */
1877     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1878         mg_get(sv);
1879     PUSHs(sv);
1880     RETURN;
1881 }
1882
1883 PP(pp_leave)
1884 {
1885     dVAR; dSP;
1886     register PERL_CONTEXT *cx;
1887     SV **newsp;
1888     PMOP *newpm;
1889     I32 gimme;
1890
1891     if (PL_op->op_flags & OPf_SPECIAL) {
1892         cx = &cxstack[cxstack_ix];
1893         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1894     }
1895
1896     POPBLOCK(cx,newpm);
1897
1898     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1899
1900     TAINT_NOT;
1901     if (gimme == G_VOID)
1902         SP = newsp;
1903     else if (gimme == G_SCALAR) {
1904         register SV **mark;
1905         MARK = newsp + 1;
1906         if (MARK <= SP) {
1907             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1908                 *MARK = TOPs;
1909             else
1910                 *MARK = sv_mortalcopy(TOPs);
1911         } else {
1912             MEXTEND(mark,0);
1913             *MARK = &PL_sv_undef;
1914         }
1915         SP = MARK;
1916     }
1917     else if (gimme == G_ARRAY) {
1918         /* in case LEAVE wipes old return values */
1919         register SV **mark;
1920         for (mark = newsp + 1; mark <= SP; mark++) {
1921             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1922                 *mark = sv_mortalcopy(*mark);
1923                 TAINT_NOT;      /* Each item is independent */
1924             }
1925         }
1926     }
1927     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1928
1929     LEAVE_with_name("block");
1930
1931     RETURN;
1932 }
1933
1934 PP(pp_iter)
1935 {
1936     dVAR; dSP;
1937     register PERL_CONTEXT *cx;
1938     SV *sv, *oldsv;
1939     SV **itersvp;
1940     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1941     bool av_is_stack = FALSE;
1942
1943     EXTEND(SP, 1);
1944     cx = &cxstack[cxstack_ix];
1945     if (!CxTYPE_is_LOOP(cx))
1946         DIE(aTHX_ "panic: pp_iter");
1947
1948     itersvp = CxITERVAR(cx);
1949     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1950             /* string increment */
1951             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1952             SV *end = cx->blk_loop.state_u.lazysv.end;
1953             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1954                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1955             STRLEN maxlen = 0;
1956             const char *max = SvPV_const(end, maxlen);
1957             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1958                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1959                     /* safe to reuse old SV */
1960                     sv_setsv(*itersvp, cur);
1961                 }
1962                 else
1963                 {
1964                     /* we need a fresh SV every time so that loop body sees a
1965                      * completely new SV for closures/references to work as
1966                      * they used to */
1967                     oldsv = *itersvp;
1968                     *itersvp = newSVsv(cur);
1969                     SvREFCNT_dec(oldsv);
1970                 }
1971                 if (strEQ(SvPVX_const(cur), max))
1972                     sv_setiv(cur, 0); /* terminate next time */
1973                 else
1974                     sv_inc(cur);
1975                 RETPUSHYES;
1976             }
1977             RETPUSHNO;
1978     }
1979     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1980         /* integer increment */
1981         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1982             RETPUSHNO;
1983
1984         /* don't risk potential race */
1985         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1986             /* safe to reuse old SV */
1987             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1988         }
1989         else
1990         {
1991             /* we need a fresh SV every time so that loop body sees a
1992              * completely new SV for closures/references to work as they
1993              * used to */
1994             oldsv = *itersvp;
1995             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1996             SvREFCNT_dec(oldsv);
1997         }
1998
1999         /* Handle end of range at IV_MAX */
2000         if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
2001             (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
2002         {
2003             cx->blk_loop.state_u.lazyiv.cur++;
2004             cx->blk_loop.state_u.lazyiv.end++;
2005         }
2006
2007         RETPUSHYES;
2008     }
2009
2010     /* iterate array */
2011     assert(CxTYPE(cx) == CXt_LOOP_FOR);
2012     av = cx->blk_loop.state_u.ary.ary;
2013     if (!av) {
2014         av_is_stack = TRUE;
2015         av = PL_curstack;
2016     }
2017     if (PL_op->op_private & OPpITER_REVERSED) {
2018         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2019                                     ? cx->blk_loop.resetsp + 1 : 0))
2020             RETPUSHNO;
2021
2022         if (SvMAGICAL(av) || AvREIFY(av)) {
2023             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2024             sv = svp ? *svp : NULL;
2025         }
2026         else {
2027             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2028         }
2029     }
2030     else {
2031         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2032                                     AvFILL(av)))
2033             RETPUSHNO;
2034
2035         if (SvMAGICAL(av) || AvREIFY(av)) {
2036             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2037             sv = svp ? *svp : NULL;
2038         }
2039         else {
2040             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2041         }
2042     }
2043
2044     if (sv && SvIS_FREED(sv)) {
2045         *itersvp = NULL;
2046         Perl_croak(aTHX_ "Use of freed value in iteration");
2047     }
2048
2049     if (sv) {
2050         SvTEMP_off(sv);
2051         SvREFCNT_inc_simple_void_NN(sv);
2052     }
2053     else
2054         sv = &PL_sv_undef;
2055     if (!av_is_stack && sv == &PL_sv_undef) {
2056         SV *lv = newSV_type(SVt_PVLV);
2057         LvTYPE(lv) = 'y';
2058         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2059         LvTARG(lv) = SvREFCNT_inc_simple(av);
2060         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2061         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2062         sv = lv;
2063     }
2064
2065     oldsv = *itersvp;
2066     *itersvp = sv;
2067     SvREFCNT_dec(oldsv);
2068
2069     RETPUSHYES;
2070 }
2071
2072 /*
2073 A description of how taint works in pattern matching and substitution.
2074
2075 While the pattern is being assembled/concatenated and them compiled,
2076 PL_tainted will get set if any component of the pattern is tainted, e.g.
2077 /.*$tainted/.  At the end of pattern compilation, the RXf_TAINTED flag
2078 is set on the pattern if PL_tainted is set.
2079
2080 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2081 the pattern is marked as tainted. This means that subsequent usage, such
2082 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
2083
2084 During execution of a pattern, locale-variant ops such as ALNUML set the
2085 local flag RF_tainted. At the end of execution, the engine sets the
2086 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2087 otherwise.
2088
2089 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2090 of $1 et al to indicate whether the returned value should be tainted.
2091 It is the responsibility of the caller of the pattern (i.e. pp_match,
2092 pp_subst etc) to set this flag for any other circumstances where $1 needs
2093 to be tainted.
2094
2095 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2096
2097 There are three possible sources of taint
2098     * the source string
2099     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2100     * the replacement string (or expression under /e)
2101
2102 There are four destinations of taint and they are affected by the sources
2103 according to the rules below:
2104
2105     * the return value (not including /r):
2106         tainted by the source string and pattern, but only for the
2107         number-of-iterations case; boolean returns aren't tainted;
2108     * the modified string (or modified copy under /r):
2109         tainted by the source string, pattern, and replacement strings;
2110     * $1 et al:
2111         tainted by the pattern, and under 'use re "taint"', by the source
2112         string too;
2113     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2114         should always be unset before executing subsequent code.
2115
2116 The overall action of pp_subst is:
2117
2118     * at the start, set bits in rxtainted indicating the taint status of
2119         the various sources.
2120
2121     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2122         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2123         pattern has subsequently become tainted via locale ops.
2124
2125     * If control is being passed to pp_substcont to execute a /e block,
2126         save rxtainted in the CXt_SUBST block, for future use by
2127         pp_substcont.
2128
2129     * Whenever control is being returned to perl code (either by falling
2130         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2131         use the flag bits in rxtainted to make all the appropriate types of
2132         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2133         et al will appear tainted.
2134
2135 pp_match is just a simpler version of the above.
2136
2137 */
2138
2139 PP(pp_subst)
2140 {
2141     dVAR; dSP; dTARG;
2142     register PMOP *pm = cPMOP;
2143     PMOP *rpm = pm;
2144     register char *s;
2145     char *strend;
2146     register char *m;
2147     const char *c;
2148     register char *d;
2149     STRLEN clen;
2150     I32 iters = 0;
2151     I32 maxiters;
2152     register I32 i;
2153     bool once;
2154     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2155                         See "how taint works" above */
2156     char *orig;
2157     U8 r_flags;
2158     register REGEXP *rx = PM_GETRE(pm);
2159     STRLEN len;
2160     int force_on_match = 0;
2161     const I32 oldsave = PL_savestack_ix;
2162     STRLEN slen;
2163     bool doutf8 = FALSE;
2164 #ifdef PERL_OLD_COPY_ON_WRITE
2165     bool is_cow;
2166 #endif
2167     SV *nsv = NULL;
2168     /* known replacement string? */
2169     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2170
2171     PERL_ASYNC_CHECK();
2172
2173     if (PL_op->op_flags & OPf_STACKED)
2174         TARG = POPs;
2175     else if (PL_op->op_private & OPpTARGET_MY)
2176         GETTARGET;
2177     else {
2178         TARG = DEFSV;
2179         EXTEND(SP,1);
2180     }
2181
2182     /* In non-destructive replacement mode, duplicate target scalar so it
2183      * remains unchanged. */
2184     if (rpm->op_pmflags & PMf_NONDESTRUCT)
2185         TARG = sv_2mortal(newSVsv(TARG));
2186
2187 #ifdef PERL_OLD_COPY_ON_WRITE
2188     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2189        because they make integers such as 256 "false".  */
2190     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2191 #else
2192     if (SvIsCOW(TARG))
2193         sv_force_normal_flags(TARG,0);
2194 #endif
2195     if (
2196 #ifdef PERL_OLD_COPY_ON_WRITE
2197         !is_cow &&
2198 #endif
2199         (SvREADONLY(TARG)
2200          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2201                || SvTYPE(TARG) > SVt_PVLV)
2202              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2203         Perl_croak_no_modify(aTHX);
2204     PUTBACK;
2205
2206   setup_match:
2207     s = SvPV_mutable(TARG, len);
2208     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2209         force_on_match = 1;
2210
2211     /* only replace once? */
2212     once = !(rpm->op_pmflags & PMf_GLOBAL);
2213
2214     /* See "how taint works" above */
2215     if (PL_tainting) {
2216         rxtainted  = (
2217             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2218           | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2219           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2220           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2221                 ? SUBST_TAINT_BOOLRET : 0));
2222         TAINT_NOT;
2223     }
2224
2225     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2226
2227   force_it:
2228     if (!pm || !s)
2229         DIE(aTHX_ "panic: pp_subst");
2230
2231     strend = s + len;
2232     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2233     maxiters = 2 * slen + 10;   /* We can match twice at each
2234                                    position, once with zero-length,
2235                                    second time with non-zero. */
2236
2237     if (!RX_PRELEN(rx) && PL_curpm) {
2238         pm = PL_curpm;
2239         rx = PM_GETRE(pm);
2240     }
2241     r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2242             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2243                ? REXEC_COPY_STR : 0;
2244     if (SvSCREAM(TARG))
2245         r_flags |= REXEC_SCREAM;
2246
2247     orig = m = s;
2248     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2249         PL_bostr = orig;
2250         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2251
2252         if (!s)
2253             goto ret_no;
2254         /* How to do it in subst? */
2255 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2256              && !PL_sawampersand
2257              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2258              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2259                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2260                       && (r_flags & REXEC_SCREAM))))
2261             goto yup;
2262 */
2263     }
2264
2265     if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2266                          r_flags | REXEC_CHECKED))
2267     {
2268       ret_no:
2269         SPAGAIN;
2270         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2271         LEAVE_SCOPE(oldsave);
2272         RETURN;
2273     }
2274
2275     /* known replacement string? */
2276     if (dstr) {
2277         if (SvTAINTED(dstr))
2278             rxtainted |= SUBST_TAINT_REPL;
2279
2280         /* Upgrade the source if the replacement is utf8 but the source is not,
2281          * but only if it matched; see
2282          * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2283          */
2284         if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2285             char * const orig_pvx =  SvPVX(TARG);
2286             const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2287
2288             /* If the lengths are the same, the pattern contains only
2289              * invariants, can keep going; otherwise, various internal markers
2290              * could be off, so redo */
2291             if (new_len != len || orig_pvx != SvPVX(TARG)) {
2292                 goto setup_match;
2293             }
2294         }
2295
2296         /* replacement needing upgrading? */
2297         if (DO_UTF8(TARG) && !doutf8) {
2298              nsv = sv_newmortal();
2299              SvSetSV(nsv, dstr);
2300              if (PL_encoding)
2301                   sv_recode_to_utf8(nsv, PL_encoding);
2302              else
2303                   sv_utf8_upgrade(nsv);
2304              c = SvPV_const(nsv, clen);
2305              doutf8 = TRUE;
2306         }
2307         else {
2308             c = SvPV_const(dstr, clen);
2309             doutf8 = DO_UTF8(dstr);
2310         }
2311     }
2312     else {
2313         c = NULL;
2314         doutf8 = FALSE;
2315     }
2316
2317     /* can do inplace substitution? */
2318     if (c
2319 #ifdef PERL_OLD_COPY_ON_WRITE
2320         && !is_cow
2321 #endif
2322         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2323         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2324         && (!doutf8 || SvUTF8(TARG)))
2325     {
2326
2327 #ifdef PERL_OLD_COPY_ON_WRITE
2328         if (SvIsCOW(TARG)) {
2329             assert (!force_on_match);
2330             goto have_a_cow;
2331         }
2332 #endif
2333         if (force_on_match) {
2334             force_on_match = 0;
2335             s = SvPV_force(TARG, len);
2336             goto force_it;
2337         }
2338         d = s;
2339         PL_curpm = pm;
2340         SvSCREAM_off(TARG);     /* disable possible screamer */
2341         if (once) {
2342             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2343                 rxtainted |= SUBST_TAINT_PAT;
2344             m = orig + RX_OFFS(rx)[0].start;
2345             d = orig + RX_OFFS(rx)[0].end;
2346             s = orig;
2347             if (m - s > strend - d) {  /* faster to shorten from end */
2348                 if (clen) {
2349                     Copy(c, m, clen, char);
2350                     m += clen;
2351                 }
2352                 i = strend - d;
2353                 if (i > 0) {
2354                     Move(d, m, i, char);
2355                     m += i;
2356                 }
2357                 *m = '\0';
2358                 SvCUR_set(TARG, m - s);
2359             }
2360             else if ((i = m - s)) {     /* faster from front */
2361                 d -= clen;
2362                 m = d;
2363                 Move(s, d - i, i, char);
2364                 sv_chop(TARG, d-i);
2365                 if (clen)
2366                     Copy(c, m, clen, char);
2367             }
2368             else if (clen) {
2369                 d -= clen;
2370                 sv_chop(TARG, d);
2371                 Copy(c, d, clen, char);
2372             }
2373             else {
2374                 sv_chop(TARG, d);
2375             }
2376             SPAGAIN;
2377             PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
2378         }
2379         else {
2380             do {
2381                 if (iters++ > maxiters)
2382                     DIE(aTHX_ "Substitution loop");
2383                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2384                     rxtainted |= SUBST_TAINT_PAT;
2385                 m = RX_OFFS(rx)[0].start + orig;
2386                 if ((i = m - s)) {
2387                     if (s != d)
2388                         Move(s, d, i, char);
2389                     d += i;
2390                 }
2391                 if (clen) {
2392                     Copy(c, d, clen, char);
2393                     d += clen;
2394                 }
2395                 s = RX_OFFS(rx)[0].end + orig;
2396             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2397                                  TARG, NULL,
2398                                  /* don't match same null twice */
2399                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2400             if (s != d) {
2401                 i = strend - s;
2402                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2403                 Move(s, d, i+1, char);          /* include the NUL */
2404             }
2405             SPAGAIN;
2406             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2407                 PUSHs(TARG);
2408             else
2409                 mPUSHi((I32)iters);
2410         }
2411     }
2412     else {
2413         if (force_on_match) {
2414             force_on_match = 0;
2415             s = SvPV_force(TARG, len);
2416             goto force_it;
2417         }
2418 #ifdef PERL_OLD_COPY_ON_WRITE
2419       have_a_cow:
2420 #endif
2421         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2422             rxtainted |= SUBST_TAINT_PAT;
2423         dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2424         SAVEFREESV(dstr);
2425         PL_curpm = pm;
2426         if (!c) {
2427             register PERL_CONTEXT *cx;
2428             SPAGAIN;
2429             /* note that a whole bunch of local vars are saved here for
2430              * use by pp_substcont: here's a list of them in case you're
2431              * searching for places in this sub that uses a particular var:
2432              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2433              * s m strend rx once */
2434             PUSHSUBST(cx);
2435             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2436         }
2437         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2438         do {
2439             if (iters++ > maxiters)
2440                 DIE(aTHX_ "Substitution loop");
2441             if (RX_MATCH_TAINTED(rx))
2442                 rxtainted |= SUBST_TAINT_PAT;
2443             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2444                 m = s;
2445                 s = orig;
2446                 orig = RX_SUBBEG(rx);
2447                 s = orig + (m - s);
2448                 strend = s + (strend - m);
2449             }
2450             m = RX_OFFS(rx)[0].start + orig;
2451             if (doutf8 && !SvUTF8(dstr))
2452                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2453             else
2454                 sv_catpvn(dstr, s, m-s);
2455             s = RX_OFFS(rx)[0].end + orig;
2456             if (clen)
2457                 sv_catpvn(dstr, c, clen);
2458             if (once)
2459                 break;
2460         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2461                              TARG, NULL, r_flags));
2462         if (doutf8 && !DO_UTF8(TARG))
2463             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2464         else
2465             sv_catpvn(dstr, s, strend - s);
2466
2467 #ifdef PERL_OLD_COPY_ON_WRITE
2468         /* The match may make the string COW. If so, brilliant, because that's
2469            just saved us one malloc, copy and free - the regexp has donated
2470            the old buffer, and we malloc an entirely new one, rather than the
2471            regexp malloc()ing a buffer and copying our original, only for
2472            us to throw it away here during the substitution.  */
2473         if (SvIsCOW(TARG)) {
2474             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2475         } else
2476 #endif
2477         {
2478             SvPV_free(TARG);
2479         }
2480         SvPV_set(TARG, SvPVX(dstr));
2481         SvCUR_set(TARG, SvCUR(dstr));
2482         SvLEN_set(TARG, SvLEN(dstr));
2483         doutf8 |= DO_UTF8(dstr);
2484         SvPV_set(dstr, NULL);
2485
2486         SPAGAIN;
2487         if (rpm->op_pmflags & PMf_NONDESTRUCT)
2488             PUSHs(TARG);
2489         else
2490             mPUSHi((I32)iters);
2491     }
2492     (void)SvPOK_only_UTF8(TARG);
2493     if (doutf8)
2494         SvUTF8_on(TARG);
2495
2496     /* See "how taint works" above */
2497     if (PL_tainting) {
2498         if ((rxtainted & SUBST_TAINT_PAT) ||
2499             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2500                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2501         )
2502             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2503
2504         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2505             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2506         )
2507             SvTAINTED_on(TOPs);  /* taint return value */
2508         else
2509             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2510
2511         /* needed for mg_set below */
2512         PL_tainted =
2513           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2514         SvTAINT(TARG);
2515     }
2516     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2517     TAINT_NOT;
2518     LEAVE_SCOPE(oldsave);
2519     RETURN;
2520 }
2521
2522 PP(pp_grepwhile)
2523 {
2524     dVAR; dSP;
2525
2526     if (SvTRUEx(POPs))
2527         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2528     ++*PL_markstack_ptr;
2529     FREETMPS;
2530     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2531
2532     /* All done yet? */
2533     if (PL_stack_base + *PL_markstack_ptr > SP) {
2534         I32 items;
2535         const I32 gimme = GIMME_V;
2536
2537         LEAVE_with_name("grep");                                        /* exit outer scope */
2538         (void)POPMARK;                          /* pop src */
2539         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2540         (void)POPMARK;                          /* pop dst */
2541         SP = PL_stack_base + POPMARK;           /* pop original mark */
2542         if (gimme == G_SCALAR) {
2543             if (PL_op->op_private & OPpGREP_LEX) {
2544                 SV* const sv = sv_newmortal();
2545                 sv_setiv(sv, items);
2546                 PUSHs(sv);
2547             }
2548             else {
2549                 dTARGET;
2550                 XPUSHi(items);
2551             }
2552         }
2553         else if (gimme == G_ARRAY)
2554             SP += items;
2555         RETURN;
2556     }
2557     else {
2558         SV *src;
2559
2560         ENTER_with_name("grep_item");                                   /* enter inner scope */
2561         SAVEVPTR(PL_curpm);
2562
2563         src = PL_stack_base[*PL_markstack_ptr];
2564         SvTEMP_off(src);
2565         if (PL_op->op_private & OPpGREP_LEX)
2566             PAD_SVl(PL_op->op_targ) = src;
2567         else
2568             DEFSV_set(src);
2569
2570         RETURNOP(cLOGOP->op_other);
2571     }
2572 }
2573
2574 PP(pp_leavesub)
2575 {
2576     dVAR; dSP;
2577     SV **mark;
2578     SV **newsp;
2579     PMOP *newpm;
2580     I32 gimme;
2581     register PERL_CONTEXT *cx;
2582     SV *sv;
2583
2584     if (CxMULTICALL(&cxstack[cxstack_ix]))
2585         return 0;
2586
2587     POPBLOCK(cx,newpm);
2588     cxstack_ix++; /* temporarily protect top context */
2589
2590     TAINT_NOT;
2591     if (gimme == G_SCALAR) {
2592         MARK = newsp + 1;
2593         if (MARK <= SP) {
2594             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2595                 if (SvTEMP(TOPs)) {
2596                     *MARK = SvREFCNT_inc(TOPs);
2597                     FREETMPS;
2598                     sv_2mortal(*MARK);
2599                 }
2600                 else {
2601                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2602                     FREETMPS;
2603                     *MARK = sv_mortalcopy(sv);
2604                     SvREFCNT_dec(sv);
2605                 }
2606             }
2607             else
2608                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2609         }
2610         else {
2611             MEXTEND(MARK, 0);
2612             *MARK = &PL_sv_undef;
2613         }
2614         SP = MARK;
2615     }
2616     else if (gimme == G_ARRAY) {
2617         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2618             if (!SvTEMP(*MARK)) {
2619                 *MARK = sv_mortalcopy(*MARK);
2620                 TAINT_NOT;      /* Each item is independent */
2621             }
2622         }
2623     }
2624     PUTBACK;
2625
2626     LEAVE;
2627     cxstack_ix--;
2628     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2629     PL_curpm = newpm;   /* ... and pop $1 et al */
2630
2631     LEAVESUB(sv);
2632     return cx->blk_sub.retop;
2633 }
2634
2635 /* This duplicates the above code because the above code must not
2636  * get any slower by more conditions */
2637 PP(pp_leavesublv)
2638 {
2639     dVAR; dSP;
2640     SV **mark;
2641     SV **newsp;
2642     PMOP *newpm;
2643     I32 gimme;
2644     register PERL_CONTEXT *cx;
2645     SV *sv;
2646
2647     if (CxMULTICALL(&cxstack[cxstack_ix]))
2648         return 0;
2649
2650     POPBLOCK(cx,newpm);
2651     cxstack_ix++; /* temporarily protect top context */
2652
2653     TAINT_NOT;
2654
2655     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2656         /* We are an argument to a function or grep().
2657          * This kind of lvalueness was legal before lvalue
2658          * subroutines too, so be backward compatible:
2659          * cannot report errors.  */
2660
2661         /* Scalar context *is* possible, on the LHS of -> only,
2662          * as in f()->meth().  But this is not an lvalue. */
2663         if (gimme == G_SCALAR)
2664             goto temporise;
2665         if (gimme == G_ARRAY) {
2666             mark = newsp + 1;
2667             /* We want an array here, but padav will have left us an arrayref for an lvalue,
2668              * so we need to expand it */
2669             if(SvTYPE(*mark) == SVt_PVAV) {
2670                 AV *const av = MUTABLE_AV(*mark);
2671                 const I32 maxarg = AvFILL(av) + 1;
2672                 (void)POPs; /* get rid of the array ref */
2673                 EXTEND(SP, maxarg);
2674                 if (SvRMAGICAL(av)) {
2675                     U32 i;
2676                     for (i=0; i < (U32)maxarg; i++) {
2677                         SV ** const svp = av_fetch(av, i, FALSE);
2678                         SP[i+1] = svp
2679                             ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
2680                             : &PL_sv_undef;
2681                     }
2682                 }
2683                 else {
2684                     Copy(AvARRAY(av), SP+1, maxarg, SV*);
2685                 }
2686                 SP += maxarg;
2687                 PUTBACK;
2688             }
2689             if (!CvLVALUE(cx->blk_sub.cv))
2690                 goto temporise_array;
2691             EXTEND_MORTAL(SP - newsp);
2692             for (mark = newsp + 1; mark <= SP; mark++) {
2693                 if (SvTEMP(*mark))
2694                     NOOP;
2695                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2696                     *mark = sv_mortalcopy(*mark);
2697                 else {
2698                     /* Can be a localized value subject to deletion. */
2699                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2700                     SvREFCNT_inc_void(*mark);
2701                 }
2702             }
2703         }
2704     }
2705     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2706         /* Here we go for robustness, not for speed, so we change all
2707          * the refcounts so the caller gets a live guy. Cannot set
2708          * TEMP, so sv_2mortal is out of question. */
2709         if (!CvLVALUE(cx->blk_sub.cv)) {
2710             LEAVE;
2711             cxstack_ix--;
2712             POPSUB(cx,sv);
2713             PL_curpm = newpm;
2714             LEAVESUB(sv);
2715             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2716         }
2717         if (gimme == G_SCALAR) {
2718             MARK = newsp + 1;
2719             EXTEND_MORTAL(1);
2720             if (MARK == SP) {
2721                 /* Temporaries are bad unless they happen to have set magic
2722                  * attached, such as the elements of a tied hash or array */
2723                 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2724                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2725                        == SVf_READONLY
2726                     ) &&
2727                     !SvSMAGICAL(TOPs)) {
2728                     LEAVE;
2729                     cxstack_ix--;
2730                     POPSUB(cx,sv);
2731                     PL_curpm = newpm;
2732                     LEAVESUB(sv);
2733                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2734                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2735                         : "a readonly value" : "a temporary");
2736                 }
2737                 else {                  /* Can be a localized value
2738                                          * subject to deletion. */
2739                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2740                     SvREFCNT_inc_void(*mark);
2741                 }
2742             }
2743             else {                      /* Should not happen? */
2744                 LEAVE;
2745                 cxstack_ix--;
2746                 POPSUB(cx,sv);
2747                 PL_curpm = newpm;
2748                 LEAVESUB(sv);
2749                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2750                     (MARK > SP ? "Empty array" : "Array"));
2751             }
2752             SP = MARK;
2753         }
2754         else if (gimme == G_ARRAY) {
2755             EXTEND_MORTAL(SP - newsp);
2756             for (mark = newsp + 1; mark <= SP; mark++) {
2757                 if (*mark != &PL_sv_undef
2758                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2759                     /* Might be flattened array after $#array =  */
2760                     PUTBACK;
2761                     LEAVE;
2762                     cxstack_ix--;
2763                     POPSUB(cx,sv);
2764                     PL_curpm = newpm;
2765                     LEAVESUB(sv);
2766                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2767                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2768                 }
2769                 else {
2770                     /* Can be a localized value subject to deletion. */
2771                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2772                     SvREFCNT_inc_void(*mark);
2773                 }
2774             }
2775         }
2776     }
2777     else {
2778         if (gimme == G_SCALAR) {
2779           temporise:
2780             MARK = newsp + 1;
2781             if (MARK <= SP) {
2782                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2783                     if (SvTEMP(TOPs)) {
2784                         *MARK = SvREFCNT_inc(TOPs);
2785                         FREETMPS;
2786                         sv_2mortal(*MARK);
2787                     }
2788                     else {
2789                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2790                         FREETMPS;
2791                         *MARK = sv_mortalcopy(sv);
2792                         SvREFCNT_dec(sv);
2793                     }
2794                 }
2795                 else
2796                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2797             }
2798             else {
2799                 MEXTEND(MARK, 0);
2800                 *MARK = &PL_sv_undef;
2801             }
2802             SP = MARK;
2803         }
2804         else if (gimme == G_ARRAY) {
2805           temporise_array:
2806             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2807                 if (!SvTEMP(*MARK)) {
2808                     *MARK = sv_mortalcopy(*MARK);
2809                     TAINT_NOT;  /* Each item is independent */
2810                 }
2811             }
2812         }
2813     }
2814     PUTBACK;
2815
2816     LEAVE;
2817     cxstack_ix--;
2818     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2819     PL_curpm = newpm;   /* ... and pop $1 et al */
2820
2821     LEAVESUB(sv);
2822     return cx->blk_sub.retop;
2823 }
2824
2825 PP(pp_entersub)
2826 {
2827     dVAR; dSP; dPOPss;
2828     GV *gv;
2829     register CV *cv;
2830     register PERL_CONTEXT *cx;
2831     I32 gimme;
2832     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2833
2834     if (!sv)
2835         DIE(aTHX_ "Not a CODE reference");
2836     switch (SvTYPE(sv)) {
2837         /* This is overwhelming the most common case:  */
2838     case SVt_PVGV:
2839         if (!isGV_with_GP(sv))
2840             DIE(aTHX_ "Not a CODE reference");
2841       we_have_a_glob:
2842         if (!(cv = GvCVu((const GV *)sv))) {
2843             HV *stash;
2844             cv = sv_2cv(sv, &stash, &gv, 0);
2845         }
2846         if (!cv) {
2847             ENTER;
2848             SAVETMPS;
2849             goto try_autoload;
2850         }
2851         break;
2852     case SVt_PVLV:
2853         if(isGV_with_GP(sv)) goto we_have_a_glob;
2854         /*FALLTHROUGH*/
2855     default:
2856         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2857             if (hasargs)
2858                 SP = PL_stack_base + POPMARK;
2859             else
2860                 (void)POPMARK;
2861             RETURN;
2862         }
2863         SvGETMAGIC(sv);
2864         if (SvROK(sv)) {
2865             if (SvAMAGIC(sv)) {
2866                 sv = amagic_deref_call(sv, to_cv_amg);
2867                 /* Don't SPAGAIN here.  */
2868             }
2869         }
2870         else {
2871             const char *sym;
2872             STRLEN len;
2873             sym = SvPV_nomg_const(sv, len);
2874             if (!sym)
2875                 DIE(aTHX_ PL_no_usym, "a subroutine");
2876             if (PL_op->op_private & HINT_STRICT_REFS)
2877                 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2878             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2879             break;
2880         }
2881         cv = MUTABLE_CV(SvRV(sv));
2882         if (SvTYPE(cv) == SVt_PVCV)
2883             break;
2884         /* FALL THROUGH */
2885     case SVt_PVHV:
2886     case SVt_PVAV:
2887         DIE(aTHX_ "Not a CODE reference");
2888         /* This is the second most common case:  */
2889     case SVt_PVCV:
2890         cv = MUTABLE_CV(sv);
2891         break;
2892     }
2893
2894     ENTER;
2895     SAVETMPS;
2896
2897   retry:
2898     if (CvCLONE(cv) && ! CvCLONED(cv))
2899         DIE(aTHX_ "Closure prototype called");
2900     if (!CvROOT(cv) && !CvXSUB(cv)) {
2901         GV* autogv;
2902         SV* sub_name;
2903
2904         /* anonymous or undef'd function leaves us no recourse */
2905         if (CvANON(cv) || !(gv = CvGV(cv)))
2906             DIE(aTHX_ "Undefined subroutine called");
2907
2908         /* autoloaded stub? */
2909         if (cv != GvCV(gv)) {
2910             cv = GvCV(gv);
2911         }
2912         /* should call AUTOLOAD now? */
2913         else {
2914 try_autoload:
2915             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2916                                    FALSE)))
2917             {
2918                 cv = GvCV(autogv);
2919             }
2920             /* sorry */
2921             else {
2922                 sub_name = sv_newmortal();
2923                 gv_efullname3(sub_name, gv, NULL);
2924                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2925             }
2926         }
2927         if (!cv)
2928             DIE(aTHX_ "Not a CODE reference");
2929         goto retry;
2930     }
2931
2932     gimme = GIMME_V;
2933     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2934          Perl_get_db_sub(aTHX_ &sv, cv);
2935          if (CvISXSUB(cv))
2936              PL_curcopdb = PL_curcop;
2937          if (CvLVALUE(cv)) {
2938              /* check for lsub that handles lvalue subroutines */
2939              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2940              /* if lsub not found then fall back to DB::sub */
2941              if (!cv) cv = GvCV(PL_DBsub);
2942          } else {
2943              cv = GvCV(PL_DBsub);
2944          }
2945
2946         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2947             DIE(aTHX_ "No DB::sub routine defined");
2948     }
2949
2950     if (!(CvISXSUB(cv))) {
2951         /* This path taken at least 75% of the time   */
2952         dMARK;
2953         register I32 items = SP - MARK;
2954         AV* const padlist = CvPADLIST(cv);
2955         PUSHBLOCK(cx, CXt_SUB, MARK);
2956         PUSHSUB(cx);
2957         cx->blk_sub.retop = PL_op->op_next;
2958         CvDEPTH(cv)++;
2959         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2960          * that eval'' ops within this sub know the correct lexical space.
2961          * Owing the speed considerations, we choose instead to search for
2962          * the cv using find_runcv() when calling doeval().
2963          */
2964         if (CvDEPTH(cv) >= 2) {
2965             PERL_STACK_OVERFLOW_CHECK();
2966             pad_push(padlist, CvDEPTH(cv));
2967         }
2968         SAVECOMPPAD();
2969         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2970         if (hasargs) {
2971             AV *const av = MUTABLE_AV(PAD_SVl(0));
2972             if (AvREAL(av)) {
2973                 /* @_ is normally not REAL--this should only ever
2974                  * happen when DB::sub() calls things that modify @_ */
2975                 av_clear(av);
2976                 AvREAL_off(av);
2977                 AvREIFY_on(av);
2978             }
2979             cx->blk_sub.savearray = GvAV(PL_defgv);
2980             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2981             CX_CURPAD_SAVE(cx->blk_sub);
2982             cx->blk_sub.argarray = av;
2983             ++MARK;
2984
2985             if (items > AvMAX(av) + 1) {
2986                 SV **ary = AvALLOC(av);
2987                 if (AvARRAY(av) != ary) {
2988                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2989                     AvARRAY(av) = ary;
2990                 }
2991                 if (items > AvMAX(av) + 1) {
2992                     AvMAX(av) = items - 1;
2993                     Renew(ary,items,SV*);
2994                     AvALLOC(av) = ary;
2995                     AvARRAY(av) = ary;
2996                 }
2997             }
2998             Copy(MARK,AvARRAY(av),items,SV*);
2999             AvFILLp(av) = items - 1;
3000
3001             while (items--) {
3002                 if (*MARK)
3003                     SvTEMP_off(*MARK);
3004                 MARK++;
3005             }
3006         }
3007         /* warning must come *after* we fully set up the context
3008          * stuff so that __WARN__ handlers can safely dounwind()
3009          * if they want to
3010          */
3011         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
3012             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
3013             sub_crush_depth(cv);
3014         RETURNOP(CvSTART(cv));
3015     }
3016     else {
3017         I32 markix = TOPMARK;
3018
3019         PUTBACK;
3020
3021         if (!hasargs) {
3022             /* Need to copy @_ to stack. Alternative may be to
3023              * switch stack to @_, and copy return values
3024              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3025             AV * const av = GvAV(PL_defgv);
3026             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
3027
3028             if (items) {
3029                 /* Mark is at the end of the stack. */
3030                 EXTEND(SP, items);
3031                 Copy(AvARRAY(av), SP + 1, items, SV*);
3032                 SP += items;
3033                 PUTBACK ;
3034             }
3035         }
3036         /* We assume first XSUB in &DB::sub is the called one. */
3037         if (PL_curcopdb) {
3038             SAVEVPTR(PL_curcop);
3039             PL_curcop = PL_curcopdb;
3040             PL_curcopdb = NULL;
3041         }
3042         /* Do we need to open block here? XXXX */
3043
3044         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3045         assert(CvXSUB(cv));
3046         CvXSUB(cv)(aTHX_ cv);
3047
3048         /* Enforce some sanity in scalar context. */
3049         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
3050             if (markix > PL_stack_sp - PL_stack_base)
3051                 *(PL_stack_base + markix) = &PL_sv_undef;
3052             else
3053                 *(PL_stack_base + markix) = *PL_stack_sp;
3054             PL_stack_sp = PL_stack_base + markix;
3055         }
3056         LEAVE;
3057         return NORMAL;
3058     }
3059 }
3060
3061 void
3062 Perl_sub_crush_depth(pTHX_ CV *cv)
3063 {
3064     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3065
3066     if (CvANON(cv))
3067         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3068     else {
3069         SV* const tmpstr = sv_newmortal();
3070         gv_efullname3(tmpstr, CvGV(cv), NULL);
3071         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3072                     SVfARG(tmpstr));
3073     }
3074 }
3075
3076 PP(pp_aelem)
3077 {
3078     dVAR; dSP;
3079     SV** svp;
3080     SV* const elemsv = POPs;
3081     IV elem = SvIV(elemsv);
3082     AV *const av = MUTABLE_AV(POPs);
3083     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3084     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
3085     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3086     bool preeminent = TRUE;
3087     SV *sv;
3088
3089     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3090         Perl_warner(aTHX_ packWARN(WARN_MISC),
3091                     "Use of reference \"%"SVf"\" as array index",
3092                     SVfARG(elemsv));
3093     if (elem > 0)
3094         elem -= CopARYBASE_get(PL_curcop);
3095     if (SvTYPE(av) != SVt_PVAV)
3096         RETPUSHUNDEF;
3097
3098     if (localizing) {
3099         MAGIC *mg;
3100         HV *stash;
3101
3102         /* If we can determine whether the element exist,
3103          * Try to preserve the existenceness of a tied array
3104          * element by using EXISTS and DELETE if possible.
3105          * Fallback to FETCH and STORE otherwise. */
3106         if (SvCANEXISTDELETE(av))
3107             preeminent = av_exists(av, elem);
3108     }
3109
3110     svp = av_fetch(av, elem, lval && !defer);
3111     if (lval) {
3112 #ifdef PERL_MALLOC_WRAP
3113          if (SvUOK(elemsv)) {
3114               const UV uv = SvUV(elemsv);
3115               elem = uv > IV_MAX ? IV_MAX : uv;
3116          }
3117          else if (SvNOK(elemsv))
3118               elem = (IV)SvNV(elemsv);
3119          if (elem > 0) {
3120               static const char oom_array_extend[] =
3121                 "Out of memory during array extend"; /* Duplicated in av.c */
3122               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3123          }
3124 #endif
3125         if (!svp || *svp == &PL_sv_undef) {
3126             SV* lv;
3127             if (!defer)
3128                 DIE(aTHX_ PL_no_aelem, elem);
3129             lv = sv_newmortal();
3130             sv_upgrade(lv, SVt_PVLV);
3131             LvTYPE(lv) = 'y';
3132             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3133             LvTARG(lv) = SvREFCNT_inc_simple(av);
3134             LvTARGOFF(lv) = elem;
3135             LvTARGLEN(lv) = 1;
3136             PUSHs(lv);
3137             RETURN;
3138         }
3139         if (localizing) {
3140             if (preeminent)
3141                 save_aelem(av, elem, svp);
3142             else
3143                 SAVEADELETE(av, elem);
3144         }
3145         else if (PL_op->op_private & OPpDEREF)
3146             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3147     }
3148     sv = (svp ? *svp : &PL_sv_undef);
3149     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3150         mg_get(sv);
3151     PUSHs(sv);
3152     RETURN;
3153 }
3154
3155 void
3156 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3157 {
3158     PERL_ARGS_ASSERT_VIVIFY_REF;
3159
3160     SvGETMAGIC(sv);
3161     if (!SvOK(sv)) {
3162         if (SvREADONLY(sv))
3163             Perl_croak_no_modify(aTHX);
3164         prepare_SV_for_RV(sv);
3165         switch (to_what) {
3166         case OPpDEREF_SV:
3167             SvRV_set(sv, newSV(0));
3168             break;
3169         case OPpDEREF_AV:
3170             SvRV_set(sv, MUTABLE_SV(newAV()));
3171             break;
3172         case OPpDEREF_HV:
3173             SvRV_set(sv, MUTABLE_SV(newHV()));
3174             break;
3175         }
3176         SvROK_on(sv);
3177         SvSETMAGIC(sv);
3178     }
3179 }
3180
3181 PP(pp_method)
3182 {
3183     dVAR; dSP;
3184     SV* const sv = TOPs;
3185
3186     if (SvROK(sv)) {
3187         SV* const rsv = SvRV(sv);
3188         if (SvTYPE(rsv) == SVt_PVCV) {
3189             SETs(rsv);
3190             RETURN;
3191         }
3192     }
3193
3194     SETs(method_common(sv, NULL));
3195     RETURN;
3196 }
3197
3198 PP(pp_method_named)
3199 {
3200     dVAR; dSP;
3201     SV* const sv = cSVOP_sv;
3202     U32 hash = SvSHARED_HASH(sv);
3203
3204     XPUSHs(method_common(sv, &hash));
3205     RETURN;
3206 }
3207
3208 STATIC SV *
3209 S_method_common(pTHX_ SV* meth, U32* hashp)
3210 {
3211     dVAR;
3212     SV* ob;
3213     GV* gv;
3214     HV* stash;
3215     const char* packname = NULL;
3216     SV *packsv = NULL;
3217     STRLEN packlen;
3218     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3219
3220     PERL_ARGS_ASSERT_METHOD_COMMON;
3221
3222     if (!sv)
3223         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3224                    SVfARG(meth));
3225
3226     SvGETMAGIC(sv);
3227     if (SvROK(sv))
3228         ob = MUTABLE_SV(SvRV(sv));
3229     else {
3230         GV* iogv;
3231
3232         /* this isn't a reference */
3233         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3234           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3235           if (he) {
3236             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3237             goto fetch;
3238           }
3239         }
3240
3241         if (!SvOK(sv) ||
3242             !(packname) ||
3243             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3244             !(ob=MUTABLE_SV(GvIO(iogv))))
3245         {
3246             /* this isn't the name of a filehandle either */
3247             if (!packname ||
3248                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3249                     ? !isIDFIRST_utf8((U8*)packname)
3250                     : !isIDFIRST(*packname)
3251                 ))
3252             {
3253                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3254                            SVfARG(meth),
3255                            SvOK(sv) ? "without a package or object reference"
3256                                     : "on an undefined value");
3257             }
3258             /* assume it's a package name */
3259             stash = gv_stashpvn(packname, packlen, 0);
3260             if (!stash)
3261                 packsv = sv;
3262             else {
3263                 SV* const ref = newSViv(PTR2IV(stash));
3264                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3265             }
3266             goto fetch;
3267         }
3268         /* it _is_ a filehandle name -- replace with a reference */
3269         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3270     }
3271
3272     /* if we got here, ob should be a reference or a glob */
3273     if (!ob || !(SvOBJECT(ob)
3274                  || (SvTYPE(ob) == SVt_PVGV
3275                      && isGV_with_GP(ob)
3276                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3277                      && SvOBJECT(ob))))
3278     {
3279         const char * const name = SvPV_nolen_const(meth);
3280         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3281                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3282                    name);
3283     }
3284
3285     stash = SvSTASH(ob);
3286
3287   fetch:
3288     /* NOTE: stash may be null, hope hv_fetch_ent and
3289        gv_fetchmethod can cope (it seems they can) */
3290
3291     /* shortcut for simple names */
3292     if (hashp) {
3293         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3294         if (he) {
3295             gv = MUTABLE_GV(HeVAL(he));
3296             if (isGV(gv) && GvCV(gv) &&
3297                 (!GvCVGEN(gv) || GvCVGEN(gv)
3298                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3299                 return MUTABLE_SV(GvCV(gv));
3300         }
3301     }
3302
3303     gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3304                               SvPV_nolen_const(meth),
3305                               GV_AUTOLOAD | GV_CROAK);
3306
3307     assert(gv);
3308
3309     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3310 }
3311
3312 /*
3313  * Local variables:
3314  * c-indentation-style: bsd
3315  * c-basic-offset: 4
3316  * indent-tabs-mode: t
3317  * End:
3318  *
3319  * ex: set ts=8 sts=4 sw=4 noet:
3320  */