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