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