pp_hot.c

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