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