pp_hot.c

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