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