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