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