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