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(hv, keysv, svp, !(PL_op->op_flags & OPf_SPECIAL));
1832             }
1833         }
1834         else if (PL_op->op_private & OPpDEREF)
1835             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1836     }
1837     sv = (svp ? *svp : &PL_sv_undef);
1838     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1839      * Pushing the magical RHS on to the stack is useless, since
1840      * that magic is soon destined to be misled by the local(),
1841      * and thus the later pp_sassign() will fail to mg_get() the
1842      * old value.  This should also cure problems with delayed
1843      * mg_get()s.  GSAR 98-07-03 */
1844     if (!lval && SvGMAGICAL(sv))
1845         sv = sv_mortalcopy(sv);
1846     PUSHs(sv);
1847     RETURN;
1848 }
1849
1850 PP(pp_leave)
1851 {
1852     dVAR; dSP;
1853     register PERL_CONTEXT *cx;
1854     SV **newsp;
1855     PMOP *newpm;
1856     I32 gimme;
1857
1858     if (PL_op->op_flags & OPf_SPECIAL) {
1859         cx = &cxstack[cxstack_ix];
1860         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1861     }
1862
1863     POPBLOCK(cx,newpm);
1864
1865     gimme = OP_GIMME(PL_op, -1);
1866     if (gimme == -1) {
1867         if (cxstack_ix >= 0)
1868             gimme = cxstack[cxstack_ix].blk_gimme;
1869         else
1870             gimme = G_SCALAR;
1871     }
1872
1873     TAINT_NOT;
1874     if (gimme == G_VOID)
1875         SP = newsp;
1876     else if (gimme == G_SCALAR) {
1877         register SV **mark;
1878         MARK = newsp + 1;
1879         if (MARK <= SP) {
1880             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1881                 *MARK = TOPs;
1882             else
1883                 *MARK = sv_mortalcopy(TOPs);
1884         } else {
1885             MEXTEND(mark,0);
1886             *MARK = &PL_sv_undef;
1887         }
1888         SP = MARK;
1889     }
1890     else if (gimme == G_ARRAY) {
1891         /* in case LEAVE wipes old return values */
1892         register SV **mark;
1893         for (mark = newsp + 1; mark <= SP; mark++) {
1894             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1895                 *mark = sv_mortalcopy(*mark);
1896                 TAINT_NOT;      /* Each item is independent */
1897             }
1898         }
1899     }
1900     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1901
1902     LEAVE;
1903
1904     RETURN;
1905 }
1906
1907 PP(pp_iter)
1908 {
1909     dVAR; dSP;
1910     register PERL_CONTEXT *cx;
1911     SV *sv, *oldsv;
1912     SV **itersvp;
1913     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1914     bool av_is_stack = FALSE;
1915
1916     EXTEND(SP, 1);
1917     cx = &cxstack[cxstack_ix];
1918     if (!CxTYPE_is_LOOP(cx))
1919         DIE(aTHX_ "panic: pp_iter");
1920
1921     itersvp = CxITERVAR(cx);
1922     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1923             /* string increment */
1924             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1925             SV *end = cx->blk_loop.state_u.lazysv.end;
1926             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1927                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1928             STRLEN maxlen = 0;
1929             const char *max = SvPV_const(end, maxlen);
1930             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1931                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1932                     /* safe to reuse old SV */
1933                     sv_setsv(*itersvp, cur);
1934                 }
1935                 else
1936                 {
1937                     /* we need a fresh SV every time so that loop body sees a
1938                      * completely new SV for closures/references to work as
1939                      * they used to */
1940                     oldsv = *itersvp;
1941                     *itersvp = newSVsv(cur);
1942                     SvREFCNT_dec(oldsv);
1943                 }
1944                 if (strEQ(SvPVX_const(cur), max))
1945                     sv_setiv(cur, 0); /* terminate next time */
1946                 else
1947                     sv_inc(cur);
1948                 RETPUSHYES;
1949             }
1950             RETPUSHNO;
1951     }
1952     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1953         /* integer increment */
1954         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1955             RETPUSHNO;
1956
1957         /* don't risk potential race */
1958         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1959             /* safe to reuse old SV */
1960             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1961         }
1962         else
1963         {
1964             /* we need a fresh SV every time so that loop body sees a
1965              * completely new SV for closures/references to work as they
1966              * used to */
1967             oldsv = *itersvp;
1968             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1969             SvREFCNT_dec(oldsv);
1970         }
1971
1972         /* Handle end of range at IV_MAX */
1973         if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1974             (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1975         {
1976             cx->blk_loop.state_u.lazyiv.cur++;
1977             cx->blk_loop.state_u.lazyiv.end++;
1978         }
1979
1980         RETPUSHYES;
1981     }
1982
1983     /* iterate array */
1984     assert(CxTYPE(cx) == CXt_LOOP_FOR);
1985     av = cx->blk_loop.state_u.ary.ary;
1986     if (!av) {
1987         av_is_stack = TRUE;
1988         av = PL_curstack;
1989     }
1990     if (PL_op->op_private & OPpITER_REVERSED) {
1991         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1992                                     ? cx->blk_loop.resetsp + 1 : 0))
1993             RETPUSHNO;
1994
1995         if (SvMAGICAL(av) || AvREIFY(av)) {
1996             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1997             sv = svp ? *svp : NULL;
1998         }
1999         else {
2000             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2001         }
2002     }
2003     else {
2004         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2005                                     AvFILL(av)))
2006             RETPUSHNO;
2007
2008         if (SvMAGICAL(av) || AvREIFY(av)) {
2009             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2010             sv = svp ? *svp : NULL;
2011         }
2012         else {
2013             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2014         }
2015     }
2016
2017     if (sv && SvIS_FREED(sv)) {
2018         *itersvp = NULL;
2019         Perl_croak(aTHX_ "Use of freed value in iteration");
2020     }
2021
2022     if (sv) {
2023         SvTEMP_off(sv);
2024         SvREFCNT_inc_simple_void_NN(sv);
2025     }
2026     else
2027         sv = &PL_sv_undef;
2028     if (!av_is_stack && sv == &PL_sv_undef) {
2029         SV *lv = newSV_type(SVt_PVLV);
2030         LvTYPE(lv) = 'y';
2031         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2032         LvTARG(lv) = SvREFCNT_inc_simple(av);
2033         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2034         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2035         sv = lv;
2036     }
2037
2038     oldsv = *itersvp;
2039     *itersvp = sv;
2040     SvREFCNT_dec(oldsv);
2041
2042     RETPUSHYES;
2043 }
2044
2045 PP(pp_subst)
2046 {
2047     dVAR; dSP; dTARG;
2048     register PMOP *pm = cPMOP;
2049     PMOP *rpm = pm;
2050     register char *s;
2051     char *strend;
2052     register char *m;
2053     const char *c;
2054     register char *d;
2055     STRLEN clen;
2056     I32 iters = 0;
2057     I32 maxiters;
2058     register I32 i;
2059     bool once;
2060     U8 rxtainted;
2061     char *orig;
2062     U8 r_flags;
2063     register REGEXP *rx = PM_GETRE(pm);
2064     STRLEN len;
2065     int force_on_match = 0;
2066     const I32 oldsave = PL_savestack_ix;
2067     STRLEN slen;
2068     bool doutf8 = FALSE;
2069     I32 matched;
2070 #ifdef PERL_OLD_COPY_ON_WRITE
2071     bool is_cow;
2072 #endif
2073     SV *nsv = NULL;
2074
2075     /* known replacement string? */
2076     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2077     if (PL_op->op_flags & OPf_STACKED)
2078         TARG = POPs;
2079     else if (PL_op->op_private & OPpTARGET_MY)
2080         GETTARGET;
2081     else {
2082         TARG = DEFSV;
2083         EXTEND(SP,1);
2084     }
2085
2086 #ifdef PERL_OLD_COPY_ON_WRITE
2087     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2088        because they make integers such as 256 "false".  */
2089     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2090 #else
2091     if (SvIsCOW(TARG))
2092         sv_force_normal_flags(TARG,0);
2093 #endif
2094     if (
2095 #ifdef PERL_OLD_COPY_ON_WRITE
2096         !is_cow &&
2097 #endif
2098         (SvREADONLY(TARG)
2099          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2100                || SvTYPE(TARG) > SVt_PVLV)
2101              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2102         DIE(aTHX_ "%s", PL_no_modify);
2103     PUTBACK;
2104
2105     s = SvPV_mutable(TARG, len);
2106     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2107         force_on_match = 1;
2108     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2109                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2110     if (PL_tainted)
2111         rxtainted |= 2;
2112     TAINT_NOT;
2113
2114     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2115
2116   force_it:
2117     if (!pm || !s)
2118         DIE(aTHX_ "panic: pp_subst");
2119
2120     strend = s + len;
2121     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2122     maxiters = 2 * slen + 10;   /* We can match twice at each
2123                                    position, once with zero-length,
2124                                    second time with non-zero. */
2125
2126     if (!RX_PRELEN(rx) && PL_curpm) {
2127         pm = PL_curpm;
2128         rx = PM_GETRE(pm);
2129     }
2130     r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2131             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2132                ? REXEC_COPY_STR : 0;
2133     if (SvSCREAM(TARG))
2134         r_flags |= REXEC_SCREAM;
2135
2136     orig = m = s;
2137     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2138         PL_bostr = orig;
2139         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2140
2141         if (!s)
2142             goto nope;
2143         /* How to do it in subst? */
2144 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2145              && !PL_sawampersand
2146              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2147              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2148                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2149                       && (r_flags & REXEC_SCREAM))))
2150             goto yup;
2151 */
2152     }
2153
2154     /* only replace once? */
2155     once = !(rpm->op_pmflags & PMf_GLOBAL);
2156     matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2157                          r_flags | REXEC_CHECKED);
2158     /* known replacement string? */
2159     if (dstr) {
2160         /* replacement needing upgrading? */
2161         if (DO_UTF8(TARG) && !doutf8) {
2162              nsv = sv_newmortal();
2163              SvSetSV(nsv, dstr);
2164              if (PL_encoding)
2165                   sv_recode_to_utf8(nsv, PL_encoding);
2166              else
2167                   sv_utf8_upgrade(nsv);
2168              c = SvPV_const(nsv, clen);
2169              doutf8 = TRUE;
2170         }
2171         else {
2172             c = SvPV_const(dstr, clen);
2173             doutf8 = DO_UTF8(dstr);
2174         }
2175     }
2176     else {
2177         c = NULL;
2178         doutf8 = FALSE;
2179     }
2180
2181     /* can do inplace substitution? */
2182     if (c
2183 #ifdef PERL_OLD_COPY_ON_WRITE
2184         && !is_cow
2185 #endif
2186         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2187         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2188         && (!doutf8 || SvUTF8(TARG))) {
2189         if (!matched)
2190         {
2191             SPAGAIN;
2192             PUSHs(&PL_sv_no);
2193             LEAVE_SCOPE(oldsave);
2194             RETURN;
2195         }
2196 #ifdef PERL_OLD_COPY_ON_WRITE
2197         if (SvIsCOW(TARG)) {
2198             assert (!force_on_match);
2199             goto have_a_cow;
2200         }
2201 #endif
2202         if (force_on_match) {
2203             force_on_match = 0;
2204             s = SvPV_force(TARG, len);
2205             goto force_it;
2206         }
2207         d = s;
2208         PL_curpm = pm;
2209         SvSCREAM_off(TARG);     /* disable possible screamer */
2210         if (once) {
2211             rxtainted |= RX_MATCH_TAINTED(rx);
2212             m = orig + RX_OFFS(rx)[0].start;
2213             d = orig + RX_OFFS(rx)[0].end;
2214             s = orig;
2215             if (m - s > strend - d) {  /* faster to shorten from end */
2216                 if (clen) {
2217                     Copy(c, m, clen, char);
2218                     m += clen;
2219                 }
2220                 i = strend - d;
2221                 if (i > 0) {
2222                     Move(d, m, i, char);
2223                     m += i;
2224                 }
2225                 *m = '\0';
2226                 SvCUR_set(TARG, m - s);
2227             }
2228             else if ((i = m - s)) {     /* faster from front */
2229                 d -= clen;
2230                 m = d;
2231                 Move(s, d - i, i, char);
2232                 sv_chop(TARG, d-i);
2233                 if (clen)
2234                     Copy(c, m, clen, char);
2235             }
2236             else if (clen) {
2237                 d -= clen;
2238                 sv_chop(TARG, d);
2239                 Copy(c, d, clen, char);
2240             }
2241             else {
2242                 sv_chop(TARG, d);
2243             }
2244             TAINT_IF(rxtainted & 1);
2245             SPAGAIN;
2246             PUSHs(&PL_sv_yes);
2247         }
2248         else {
2249             do {
2250                 if (iters++ > maxiters)
2251                     DIE(aTHX_ "Substitution loop");
2252                 rxtainted |= RX_MATCH_TAINTED(rx);
2253                 m = RX_OFFS(rx)[0].start + orig;
2254                 if ((i = m - s)) {
2255                     if (s != d)
2256                         Move(s, d, i, char);
2257                     d += i;
2258                 }
2259                 if (clen) {
2260                     Copy(c, d, clen, char);
2261                     d += clen;
2262                 }
2263                 s = RX_OFFS(rx)[0].end + orig;
2264             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2265                                  TARG, NULL,
2266                                  /* don't match same null twice */
2267                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2268             if (s != d) {
2269                 i = strend - s;
2270                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2271                 Move(s, d, i+1, char);          /* include the NUL */
2272             }
2273             TAINT_IF(rxtainted & 1);
2274             SPAGAIN;
2275             mPUSHi((I32)iters);
2276         }
2277         (void)SvPOK_only_UTF8(TARG);
2278         TAINT_IF(rxtainted);
2279         if (SvSMAGICAL(TARG)) {
2280             PUTBACK;
2281             mg_set(TARG);
2282             SPAGAIN;
2283         }
2284         SvTAINT(TARG);
2285         if (doutf8)
2286             SvUTF8_on(TARG);
2287         LEAVE_SCOPE(oldsave);
2288         RETURN;
2289     }
2290
2291     if (matched)
2292     {
2293         if (force_on_match) {
2294             force_on_match = 0;
2295             s = SvPV_force(TARG, len);
2296             goto force_it;
2297         }
2298 #ifdef PERL_OLD_COPY_ON_WRITE
2299       have_a_cow:
2300 #endif
2301         rxtainted |= RX_MATCH_TAINTED(rx);
2302         dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2303         SAVEFREESV(dstr);
2304         PL_curpm = pm;
2305         if (!c) {
2306             register PERL_CONTEXT *cx;
2307             SPAGAIN;
2308             PUSHSUBST(cx);
2309             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2310         }
2311         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2312         do {
2313             if (iters++ > maxiters)
2314                 DIE(aTHX_ "Substitution loop");
2315             rxtainted |= RX_MATCH_TAINTED(rx);
2316             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2317                 m = s;
2318                 s = orig;
2319                 orig = RX_SUBBEG(rx);
2320                 s = orig + (m - s);
2321                 strend = s + (strend - m);
2322             }
2323             m = RX_OFFS(rx)[0].start + orig;
2324             if (doutf8 && !SvUTF8(dstr))
2325                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2326             else
2327                 sv_catpvn(dstr, s, m-s);
2328             s = RX_OFFS(rx)[0].end + orig;
2329             if (clen)
2330                 sv_catpvn(dstr, c, clen);
2331             if (once)
2332                 break;
2333         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2334                              TARG, NULL, r_flags));
2335         if (doutf8 && !DO_UTF8(TARG))
2336             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2337         else
2338             sv_catpvn(dstr, s, strend - s);
2339
2340 #ifdef PERL_OLD_COPY_ON_WRITE
2341         /* The match may make the string COW. If so, brilliant, because that's
2342            just saved us one malloc, copy and free - the regexp has donated
2343            the old buffer, and we malloc an entirely new one, rather than the
2344            regexp malloc()ing a buffer and copying our original, only for
2345            us to throw it away here during the substitution.  */
2346         if (SvIsCOW(TARG)) {
2347             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2348         } else
2349 #endif
2350         {
2351             SvPV_free(TARG);
2352         }
2353         SvPV_set(TARG, SvPVX(dstr));
2354         SvCUR_set(TARG, SvCUR(dstr));
2355         SvLEN_set(TARG, SvLEN(dstr));
2356         doutf8 |= DO_UTF8(dstr);
2357         SvPV_set(dstr, NULL);
2358
2359         TAINT_IF(rxtainted & 1);
2360         SPAGAIN;
2361         mPUSHi((I32)iters);
2362
2363         (void)SvPOK_only(TARG);
2364         if (doutf8)
2365             SvUTF8_on(TARG);
2366         TAINT_IF(rxtainted);
2367         SvSETMAGIC(TARG);
2368         SvTAINT(TARG);
2369         LEAVE_SCOPE(oldsave);
2370         RETURN;
2371     }
2372     goto ret_no;
2373
2374 nope:
2375 ret_no:
2376     SPAGAIN;
2377     PUSHs(&PL_sv_no);
2378     LEAVE_SCOPE(oldsave);
2379     RETURN;
2380 }
2381
2382 PP(pp_grepwhile)
2383 {
2384     dVAR; dSP;
2385
2386     if (SvTRUEx(POPs))
2387         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2388     ++*PL_markstack_ptr;
2389     LEAVE;                                      /* exit inner scope */
2390
2391     /* All done yet? */
2392     if (PL_stack_base + *PL_markstack_ptr > SP) {
2393         I32 items;
2394         const I32 gimme = GIMME_V;
2395
2396         LEAVE;                                  /* exit outer scope */
2397         (void)POPMARK;                          /* pop src */
2398         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2399         (void)POPMARK;                          /* pop dst */
2400         SP = PL_stack_base + POPMARK;           /* pop original mark */
2401         if (gimme == G_SCALAR) {
2402             if (PL_op->op_private & OPpGREP_LEX) {
2403                 SV* const sv = sv_newmortal();
2404                 sv_setiv(sv, items);
2405                 PUSHs(sv);
2406             }
2407             else {
2408                 dTARGET;
2409                 XPUSHi(items);
2410             }
2411         }
2412         else if (gimme == G_ARRAY)
2413             SP += items;
2414         RETURN;
2415     }
2416     else {
2417         SV *src;
2418
2419         ENTER;                                  /* enter inner scope */
2420         SAVEVPTR(PL_curpm);
2421
2422         src = PL_stack_base[*PL_markstack_ptr];
2423         SvTEMP_off(src);
2424         if (PL_op->op_private & OPpGREP_LEX)
2425             PAD_SVl(PL_op->op_targ) = src;
2426         else
2427             DEFSV_set(src);
2428
2429         RETURNOP(cLOGOP->op_other);
2430     }
2431 }
2432
2433 PP(pp_leavesub)
2434 {
2435     dVAR; dSP;
2436     SV **mark;
2437     SV **newsp;
2438     PMOP *newpm;
2439     I32 gimme;
2440     register PERL_CONTEXT *cx;
2441     SV *sv;
2442
2443     if (CxMULTICALL(&cxstack[cxstack_ix]))
2444         return 0;
2445
2446     POPBLOCK(cx,newpm);
2447     cxstack_ix++; /* temporarily protect top context */
2448
2449     TAINT_NOT;
2450     if (gimme == G_SCALAR) {
2451         MARK = newsp + 1;
2452         if (MARK <= SP) {
2453             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2454                 if (SvTEMP(TOPs)) {
2455                     *MARK = SvREFCNT_inc(TOPs);
2456                     FREETMPS;
2457                     sv_2mortal(*MARK);
2458                 }
2459                 else {
2460                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2461                     FREETMPS;
2462                     *MARK = sv_mortalcopy(sv);
2463                     SvREFCNT_dec(sv);
2464                 }
2465             }
2466             else
2467                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2468         }
2469         else {
2470             MEXTEND(MARK, 0);
2471             *MARK = &PL_sv_undef;
2472         }
2473         SP = MARK;
2474     }
2475     else if (gimme == G_ARRAY) {
2476         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2477             if (!SvTEMP(*MARK)) {
2478                 *MARK = sv_mortalcopy(*MARK);
2479                 TAINT_NOT;      /* Each item is independent */
2480             }
2481         }
2482     }
2483     PUTBACK;
2484
2485     LEAVE;
2486     cxstack_ix--;
2487     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2488     PL_curpm = newpm;   /* ... and pop $1 et al */
2489
2490     LEAVESUB(sv);
2491     return cx->blk_sub.retop;
2492 }
2493
2494 /* This duplicates the above code because the above code must not
2495  * get any slower by more conditions */
2496 PP(pp_leavesublv)
2497 {
2498     dVAR; dSP;
2499     SV **mark;
2500     SV **newsp;
2501     PMOP *newpm;
2502     I32 gimme;
2503     register PERL_CONTEXT *cx;
2504     SV *sv;
2505
2506     if (CxMULTICALL(&cxstack[cxstack_ix]))
2507         return 0;
2508
2509     POPBLOCK(cx,newpm);
2510     cxstack_ix++; /* temporarily protect top context */
2511
2512     TAINT_NOT;
2513
2514     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2515         /* We are an argument to a function or grep().
2516          * This kind of lvalueness was legal before lvalue
2517          * subroutines too, so be backward compatible:
2518          * cannot report errors.  */
2519
2520         /* Scalar context *is* possible, on the LHS of -> only,
2521          * as in f()->meth().  But this is not an lvalue. */
2522         if (gimme == G_SCALAR)
2523             goto temporise;
2524         if (gimme == G_ARRAY) {
2525             if (!CvLVALUE(cx->blk_sub.cv))
2526                 goto temporise_array;
2527             EXTEND_MORTAL(SP - newsp);
2528             for (mark = newsp + 1; mark <= SP; mark++) {
2529                 if (SvTEMP(*mark))
2530                     NOOP;
2531                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2532                     *mark = sv_mortalcopy(*mark);
2533                 else {
2534                     /* Can be a localized value subject to deletion. */
2535                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2536                     SvREFCNT_inc_void(*mark);
2537                 }
2538             }
2539         }
2540     }
2541     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2542         /* Here we go for robustness, not for speed, so we change all
2543          * the refcounts so the caller gets a live guy. Cannot set
2544          * TEMP, so sv_2mortal is out of question. */
2545         if (!CvLVALUE(cx->blk_sub.cv)) {
2546             LEAVE;
2547             cxstack_ix--;
2548             POPSUB(cx,sv);
2549             PL_curpm = newpm;
2550             LEAVESUB(sv);
2551             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2552         }
2553         if (gimme == G_SCALAR) {
2554             MARK = newsp + 1;
2555             EXTEND_MORTAL(1);
2556             if (MARK == SP) {
2557                 /* Temporaries are bad unless they happen to be elements
2558                  * of a tied hash or array */
2559                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2560                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2561                     LEAVE;
2562                     cxstack_ix--;
2563                     POPSUB(cx,sv);
2564                     PL_curpm = newpm;
2565                     LEAVESUB(sv);
2566                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2567                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2568                         : "a readonly value" : "a temporary");
2569                 }
2570                 else {                  /* Can be a localized value
2571                                          * subject to deletion. */
2572                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2573                     SvREFCNT_inc_void(*mark);
2574                 }
2575             }
2576             else {                      /* Should not happen? */
2577                 LEAVE;
2578                 cxstack_ix--;
2579                 POPSUB(cx,sv);
2580                 PL_curpm = newpm;
2581                 LEAVESUB(sv);
2582                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2583                     (MARK > SP ? "Empty array" : "Array"));
2584             }
2585             SP = MARK;
2586         }
2587         else if (gimme == G_ARRAY) {
2588             EXTEND_MORTAL(SP - newsp);
2589             for (mark = newsp + 1; mark <= SP; mark++) {
2590                 if (*mark != &PL_sv_undef
2591                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2592                     /* Might be flattened array after $#array =  */
2593                     PUTBACK;
2594                     LEAVE;
2595                     cxstack_ix--;
2596                     POPSUB(cx,sv);
2597                     PL_curpm = newpm;
2598                     LEAVESUB(sv);
2599                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2600                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2601                 }
2602                 else {
2603                     /* Can be a localized value subject to deletion. */
2604                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2605                     SvREFCNT_inc_void(*mark);
2606                 }
2607             }
2608         }
2609     }
2610     else {
2611         if (gimme == G_SCALAR) {
2612           temporise:
2613             MARK = newsp + 1;
2614             if (MARK <= SP) {
2615                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2616                     if (SvTEMP(TOPs)) {
2617                         *MARK = SvREFCNT_inc(TOPs);
2618                         FREETMPS;
2619                         sv_2mortal(*MARK);
2620                     }
2621                     else {
2622                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2623                         FREETMPS;
2624                         *MARK = sv_mortalcopy(sv);
2625                         SvREFCNT_dec(sv);
2626                     }
2627                 }
2628                 else
2629                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2630             }
2631             else {
2632                 MEXTEND(MARK, 0);
2633                 *MARK = &PL_sv_undef;
2634             }
2635             SP = MARK;
2636         }
2637         else if (gimme == G_ARRAY) {
2638           temporise_array:
2639             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2640                 if (!SvTEMP(*MARK)) {
2641                     *MARK = sv_mortalcopy(*MARK);
2642                     TAINT_NOT;  /* Each item is independent */
2643                 }
2644             }
2645         }
2646     }
2647     PUTBACK;
2648
2649     LEAVE;
2650     cxstack_ix--;
2651     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2652     PL_curpm = newpm;   /* ... and pop $1 et al */
2653
2654     LEAVESUB(sv);
2655     return cx->blk_sub.retop;
2656 }
2657
2658 PP(pp_entersub)
2659 {
2660     dVAR; dSP; dPOPss;
2661     GV *gv;
2662     register CV *cv;
2663     register PERL_CONTEXT *cx;
2664     I32 gimme;
2665     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2666
2667     if (!sv)
2668         DIE(aTHX_ "Not a CODE reference");
2669     switch (SvTYPE(sv)) {
2670         /* This is overwhelming the most common case:  */
2671     case SVt_PVGV:
2672         if (!isGV_with_GP(sv))
2673             DIE(aTHX_ "Not a CODE reference");
2674         if (!(cv = GvCVu((const GV *)sv))) {
2675             HV *stash;
2676             cv = sv_2cv(sv, &stash, &gv, 0);
2677         }
2678         if (!cv) {
2679             ENTER;
2680             SAVETMPS;
2681             goto try_autoload;
2682         }
2683         break;
2684     default:
2685         if (!SvROK(sv)) {
2686             const char *sym;
2687             STRLEN len;
2688             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2689                 if (hasargs)
2690                     SP = PL_stack_base + POPMARK;
2691                 RETURN;
2692             }
2693             if (SvGMAGICAL(sv)) {
2694                 mg_get(sv);
2695                 if (SvROK(sv))
2696                     goto got_rv;
2697                 if (SvPOKp(sv)) {
2698                     sym = SvPVX_const(sv);
2699                     len = SvCUR(sv);
2700                 } else {
2701                     sym = NULL;
2702                     len = 0;
2703                 }
2704             }
2705             else {
2706                 sym = SvPV_const(sv, len);
2707             }
2708             if (!sym)
2709                 DIE(aTHX_ PL_no_usym, "a subroutine");
2710             if (PL_op->op_private & HINT_STRICT_REFS)
2711                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2712             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2713             break;
2714         }
2715   got_rv:
2716         {
2717             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2718             tryAMAGICunDEREF(to_cv);
2719         }
2720         cv = MUTABLE_CV(SvRV(sv));
2721         if (SvTYPE(cv) == SVt_PVCV)
2722             break;
2723         /* FALL THROUGH */
2724     case SVt_PVHV:
2725     case SVt_PVAV:
2726         DIE(aTHX_ "Not a CODE reference");
2727         /* This is the second most common case:  */
2728     case SVt_PVCV:
2729         cv = MUTABLE_CV(sv);
2730         break;
2731     }
2732
2733     ENTER;
2734     SAVETMPS;
2735
2736   retry:
2737     if (!CvROOT(cv) && !CvXSUB(cv)) {
2738         GV* autogv;
2739         SV* sub_name;
2740
2741         /* anonymous or undef'd function leaves us no recourse */
2742         if (CvANON(cv) || !(gv = CvGV(cv)))
2743             DIE(aTHX_ "Undefined subroutine called");
2744
2745         /* autoloaded stub? */
2746         if (cv != GvCV(gv)) {
2747             cv = GvCV(gv);
2748         }
2749         /* should call AUTOLOAD now? */
2750         else {
2751 try_autoload:
2752             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2753                                    FALSE)))
2754             {
2755                 cv = GvCV(autogv);
2756             }
2757             /* sorry */
2758             else {
2759                 sub_name = sv_newmortal();
2760                 gv_efullname3(sub_name, gv, NULL);
2761                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2762             }
2763         }
2764         if (!cv)
2765             DIE(aTHX_ "Not a CODE reference");
2766         goto retry;
2767     }
2768
2769     gimme = GIMME_V;
2770     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2771          Perl_get_db_sub(aTHX_ &sv, cv);
2772          if (CvISXSUB(cv))
2773              PL_curcopdb = PL_curcop;
2774          cv = GvCV(PL_DBsub);
2775
2776         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2777             DIE(aTHX_ "No DB::sub routine defined");
2778     }
2779
2780     if (!(CvISXSUB(cv))) {
2781         /* This path taken at least 75% of the time   */
2782         dMARK;
2783         register I32 items = SP - MARK;
2784         AV* const padlist = CvPADLIST(cv);
2785         PUSHBLOCK(cx, CXt_SUB, MARK);
2786         PUSHSUB(cx);
2787         cx->blk_sub.retop = PL_op->op_next;
2788         CvDEPTH(cv)++;
2789         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2790          * that eval'' ops within this sub know the correct lexical space.
2791          * Owing the speed considerations, we choose instead to search for
2792          * the cv using find_runcv() when calling doeval().
2793          */
2794         if (CvDEPTH(cv) >= 2) {
2795             PERL_STACK_OVERFLOW_CHECK();
2796             pad_push(padlist, CvDEPTH(cv));
2797         }
2798         SAVECOMPPAD();
2799         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2800         if (hasargs) {
2801             AV *const av = MUTABLE_AV(PAD_SVl(0));
2802             if (AvREAL(av)) {
2803                 /* @_ is normally not REAL--this should only ever
2804                  * happen when DB::sub() calls things that modify @_ */
2805                 av_clear(av);
2806                 AvREAL_off(av);
2807                 AvREIFY_on(av);
2808             }
2809             cx->blk_sub.savearray = GvAV(PL_defgv);
2810             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2811             CX_CURPAD_SAVE(cx->blk_sub);
2812             cx->blk_sub.argarray = av;
2813             ++MARK;
2814
2815             if (items > AvMAX(av) + 1) {
2816                 SV **ary = AvALLOC(av);
2817                 if (AvARRAY(av) != ary) {
2818                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2819                     AvARRAY(av) = ary;
2820                 }
2821                 if (items > AvMAX(av) + 1) {
2822                     AvMAX(av) = items - 1;
2823                     Renew(ary,items,SV*);
2824                     AvALLOC(av) = ary;
2825                     AvARRAY(av) = ary;
2826                 }
2827             }
2828             Copy(MARK,AvARRAY(av),items,SV*);
2829             AvFILLp(av) = items - 1;
2830
2831             while (items--) {
2832                 if (*MARK)
2833                     SvTEMP_off(*MARK);
2834                 MARK++;
2835             }
2836         }
2837         /* warning must come *after* we fully set up the context
2838          * stuff so that __WARN__ handlers can safely dounwind()
2839          * if they want to
2840          */
2841         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2842             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2843             sub_crush_depth(cv);
2844         RETURNOP(CvSTART(cv));
2845     }
2846     else {
2847         I32 markix = TOPMARK;
2848
2849         PUTBACK;
2850
2851         if (!hasargs) {
2852             /* Need to copy @_ to stack. Alternative may be to
2853              * switch stack to @_, and copy return values
2854              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2855             AV * const av = GvAV(PL_defgv);
2856             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2857
2858             if (items) {
2859                 /* Mark is at the end of the stack. */
2860                 EXTEND(SP, items);
2861                 Copy(AvARRAY(av), SP + 1, items, SV*);
2862                 SP += items;
2863                 PUTBACK ;
2864             }
2865         }
2866         /* We assume first XSUB in &DB::sub is the called one. */
2867         if (PL_curcopdb) {
2868             SAVEVPTR(PL_curcop);
2869             PL_curcop = PL_curcopdb;
2870             PL_curcopdb = NULL;
2871         }
2872         /* Do we need to open block here? XXXX */
2873         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2874             (void)(*CvXSUB(cv))(aTHX_ cv);
2875
2876         /* Enforce some sanity in scalar context. */
2877         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2878             if (markix > PL_stack_sp - PL_stack_base)
2879                 *(PL_stack_base + markix) = &PL_sv_undef;
2880             else
2881                 *(PL_stack_base + markix) = *PL_stack_sp;
2882             PL_stack_sp = PL_stack_base + markix;
2883         }
2884         LEAVE;
2885         return NORMAL;
2886     }
2887 }
2888
2889 void
2890 Perl_sub_crush_depth(pTHX_ CV *cv)
2891 {
2892     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2893
2894     if (CvANON(cv))
2895         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2896     else {
2897         SV* const tmpstr = sv_newmortal();
2898         gv_efullname3(tmpstr, CvGV(cv), NULL);
2899         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2900                     SVfARG(tmpstr));
2901     }
2902 }
2903
2904 PP(pp_aelem)
2905 {
2906     dVAR; dSP;
2907     SV** svp;
2908     SV* const elemsv = POPs;
2909     IV elem = SvIV(elemsv);
2910     AV *const av = MUTABLE_AV(POPs);
2911     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2912     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2913     SV *sv;
2914
2915     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2916         Perl_warner(aTHX_ packWARN(WARN_MISC),
2917                     "Use of reference \"%"SVf"\" as array index",
2918                     SVfARG(elemsv));
2919     if (elem > 0)
2920         elem -= CopARYBASE_get(PL_curcop);
2921     if (SvTYPE(av) != SVt_PVAV)
2922         RETPUSHUNDEF;
2923     svp = av_fetch(av, elem, lval && !defer);
2924     if (lval) {
2925 #ifdef PERL_MALLOC_WRAP
2926          if (SvUOK(elemsv)) {
2927               const UV uv = SvUV(elemsv);
2928               elem = uv > IV_MAX ? IV_MAX : uv;
2929          }
2930          else if (SvNOK(elemsv))
2931               elem = (IV)SvNV(elemsv);
2932          if (elem > 0) {
2933               static const char oom_array_extend[] =
2934                 "Out of memory during array extend"; /* Duplicated in av.c */
2935               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2936          }
2937 #endif
2938         if (!svp || *svp == &PL_sv_undef) {
2939             SV* lv;
2940             if (!defer)
2941                 DIE(aTHX_ PL_no_aelem, elem);
2942             lv = sv_newmortal();
2943             sv_upgrade(lv, SVt_PVLV);
2944             LvTYPE(lv) = 'y';
2945             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2946             LvTARG(lv) = SvREFCNT_inc_simple(av);
2947             LvTARGOFF(lv) = elem;
2948             LvTARGLEN(lv) = 1;
2949             PUSHs(lv);
2950             RETURN;
2951         }
2952         if (PL_op->op_private & OPpLVAL_INTRO)
2953             save_aelem(av, elem, svp);
2954         else if (PL_op->op_private & OPpDEREF)
2955             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2956     }
2957     sv = (svp ? *svp : &PL_sv_undef);
2958     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2959         sv = sv_mortalcopy(sv);
2960     PUSHs(sv);
2961     RETURN;
2962 }
2963
2964 void
2965 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2966 {
2967     PERL_ARGS_ASSERT_VIVIFY_REF;
2968
2969     SvGETMAGIC(sv);
2970     if (!SvOK(sv)) {
2971         if (SvREADONLY(sv))
2972             Perl_croak(aTHX_ "%s", PL_no_modify);
2973         prepare_SV_for_RV(sv);
2974         switch (to_what) {
2975         case OPpDEREF_SV:
2976             SvRV_set(sv, newSV(0));
2977             break;
2978         case OPpDEREF_AV:
2979             SvRV_set(sv, MUTABLE_SV(newAV()));
2980             break;
2981         case OPpDEREF_HV:
2982             SvRV_set(sv, MUTABLE_SV(newHV()));
2983             break;
2984         }
2985         SvROK_on(sv);
2986         SvSETMAGIC(sv);
2987     }
2988 }
2989
2990 PP(pp_method)
2991 {
2992     dVAR; dSP;
2993     SV* const sv = TOPs;
2994
2995     if (SvROK(sv)) {
2996         SV* const rsv = SvRV(sv);
2997         if (SvTYPE(rsv) == SVt_PVCV) {
2998             SETs(rsv);
2999             RETURN;
3000         }
3001     }
3002
3003     SETs(method_common(sv, NULL));
3004     RETURN;
3005 }
3006
3007 PP(pp_method_named)
3008 {
3009     dVAR; dSP;
3010     SV* const sv = cSVOP_sv;
3011     U32 hash = SvSHARED_HASH(sv);
3012
3013     XPUSHs(method_common(sv, &hash));
3014     RETURN;
3015 }
3016
3017 STATIC SV *
3018 S_method_common(pTHX_ SV* meth, U32* hashp)
3019 {
3020     dVAR;
3021     SV* ob;
3022     GV* gv;
3023     HV* stash;
3024     STRLEN namelen;
3025     const char* packname = NULL;
3026     SV *packsv = NULL;
3027     STRLEN packlen;
3028     const char * const name = SvPV_const(meth, namelen);
3029     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3030
3031     PERL_ARGS_ASSERT_METHOD_COMMON;
3032
3033     if (!sv)
3034         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3035
3036     SvGETMAGIC(sv);
3037     if (SvROK(sv))
3038         ob = MUTABLE_SV(SvRV(sv));
3039     else {
3040         GV* iogv;
3041
3042         /* this isn't a reference */
3043         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3044           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3045           if (he) {
3046             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3047             goto fetch;
3048           }
3049         }
3050
3051         if (!SvOK(sv) ||
3052             !(packname) ||
3053             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3054             !(ob=MUTABLE_SV(GvIO(iogv))))
3055         {
3056             /* this isn't the name of a filehandle either */
3057             if (!packname ||
3058                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3059                     ? !isIDFIRST_utf8((U8*)packname)
3060                     : !isIDFIRST(*packname)
3061                 ))
3062             {
3063                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3064                            SvOK(sv) ? "without a package or object reference"
3065                                     : "on an undefined value");
3066             }
3067             /* assume it's a package name */
3068             stash = gv_stashpvn(packname, packlen, 0);
3069             if (!stash)
3070                 packsv = sv;
3071             else {
3072                 SV* const ref = newSViv(PTR2IV(stash));
3073                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3074             }
3075             goto fetch;
3076         }
3077         /* it _is_ a filehandle name -- replace with a reference */
3078         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3079     }
3080
3081     /* if we got here, ob should be a reference or a glob */
3082     if (!ob || !(SvOBJECT(ob)
3083                  || (SvTYPE(ob) == SVt_PVGV
3084                      && isGV_with_GP(ob)
3085                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3086                      && SvOBJECT(ob))))
3087     {
3088         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3089                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3090                    name);
3091     }
3092
3093     stash = SvSTASH(ob);
3094
3095   fetch:
3096     /* NOTE: stash may be null, hope hv_fetch_ent and
3097        gv_fetchmethod can cope (it seems they can) */
3098
3099     /* shortcut for simple names */
3100     if (hashp) {
3101         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3102         if (he) {
3103             gv = MUTABLE_GV(HeVAL(he));
3104             if (isGV(gv) && GvCV(gv) &&
3105                 (!GvCVGEN(gv) || GvCVGEN(gv)
3106                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3107                 return MUTABLE_SV(GvCV(gv));
3108         }
3109     }
3110
3111     gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name,
3112                               GV_AUTOLOAD | GV_CROAK);
3113
3114     assert(gv);
3115
3116     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3117 }
3118
3119 /*
3120  * Local variables:
3121  * c-indentation-style: bsd
3122  * c-basic-offset: 4
3123  * indent-tabs-mode: t
3124  * End:
3125  *
3126  * ex: set ts=8 sts=4 sw=4 noet:
3127  */