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