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