pp_hot.c

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