pp_hot.c

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