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