pp_hot.c

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