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_IV);
 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, pkg ? SvPV_nolen(pkg) : NULL);
1198     if (rx->extflags & RXf_TAINTED)
1199         SvTAINTED_on(rv);
1200     sv_upgrade(sv, SVt_REGEXP);
1201     ((struct xregexp *)SvANY(sv))->xrx_regexp = ReREFCNT_inc(rx);
1202     XPUSHs(rv);
1203     RETURN;
1204 }
1205
1206 PP(pp_match)
1207 {
1208     dVAR; dSP; dTARG;
1209     register PMOP *pm = cPMOP;
1210     PMOP *dynpm = pm;
1211     register const char *t;
1212     register const char *s;
1213     const char *strend;
1214     I32 global;
1215     I32 r_flags = REXEC_CHECKED;
1216     const char *truebase;                       /* Start of string  */
1217     register REGEXP *rx = PM_GETRE(pm);
1218     bool rxtainted;
1219     const I32 gimme = GIMME;
1220     STRLEN len;
1221     I32 minmatch = 0;
1222     const I32 oldsave = PL_savestack_ix;
1223     I32 update_minmatch = 1;
1224     I32 had_zerolen = 0;
1225     U32 gpos = 0;
1226
1227     if (PL_op->op_flags & OPf_STACKED)
1228         TARG = POPs;
1229     else if (PL_op->op_private & OPpTARGET_MY)
1230         GETTARGET;
1231     else {
1232         TARG = DEFSV;
1233         EXTEND(SP,1);
1234     }
1235
1236     PUTBACK;                            /* EVAL blocks need stack_sp. */
1237     s = SvPV_const(TARG, len);
1238     if (!s)
1239         DIE(aTHX_ "panic: pp_match");
1240     strend = s + len;
1241     rxtainted = ((rx->extflags & RXf_TAINTED) ||
1242                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1243     TAINT_NOT;
1244
1245     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1246
1247     /* PMdf_USED is set after a ?? matches once */
1248     if (
1249 #ifdef USE_ITHREADS
1250         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1251 #else
1252         pm->op_pmflags & PMf_USED
1253 #endif
1254     ) {
1255       failure:
1256         if (gimme == G_ARRAY)
1257             RETURN;
1258         RETPUSHNO;
1259     }
1260
1261
1262
1263     /* empty pattern special-cased to use last successful pattern if possible */
1264     if (!RX_PRELEN(rx) && PL_curpm) {
1265         pm = PL_curpm;
1266         rx = PM_GETRE(pm);
1267     }
1268
1269     if (rx->minlen > (I32)len)
1270         goto failure;
1271
1272     truebase = t = s;
1273
1274     /* XXXX What part of this is needed with true \G-support? */
1275     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1276         rx->offs[0].start = -1;
1277         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1278             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1279             if (mg && mg->mg_len >= 0) {
1280                 if (!(rx->extflags & RXf_GPOS_SEEN))
1281                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1282                 else if (rx->extflags & RXf_ANCH_GPOS) {
1283                     r_flags |= REXEC_IGNOREPOS;
1284                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1285                 } else if (rx->extflags & RXf_GPOS_FLOAT)
1286                     gpos = mg->mg_len;
1287                 else
1288                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1289                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1290                 update_minmatch = 0;
1291             }
1292         }
1293     }
1294     /* XXX: comment out !global get safe $1 vars after a
1295        match, BUT be aware that this leads to dramatic slowdowns on
1296        /g matches against large strings.  So far a solution to this problem
1297        appears to be quite tricky.
1298        Test for the unsafe vars are TODO for now. */
1299     if ((  !global &&  rx->nparens)
1300             || SvTEMP(TARG) || PL_sawampersand ||
1301             (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1302         r_flags |= REXEC_COPY_STR;
1303     if (SvSCREAM(TARG))
1304         r_flags |= REXEC_SCREAM;
1305
1306 play_it_again:
1307     if (global && rx->offs[0].start != -1) {
1308         t = s = rx->offs[0].end + truebase - rx->gofs;
1309         if ((s + rx->minlen) > strend || s < truebase)
1310             goto nope;
1311         if (update_minmatch++)
1312             minmatch = had_zerolen;
1313     }
1314     if (rx->extflags & RXf_USE_INTUIT &&
1315         DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1316         /* FIXME - can PL_bostr be made const char *?  */
1317         PL_bostr = (char *)truebase;
1318         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1319
1320         if (!s)
1321             goto nope;
1322         if ( (rx->extflags & RXf_CHECK_ALL)
1323              && !PL_sawampersand
1324              && !(rx->extflags & RXf_PMf_KEEPCOPY)
1325              && ((rx->extflags & RXf_NOSCAN)
1326                  || !((rx->extflags & RXf_INTUIT_TAIL)
1327                       && (r_flags & REXEC_SCREAM)))
1328              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1329             goto yup;
1330     }
1331     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1332                     minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1333     {
1334         PL_curpm = pm;
1335         if (dynpm->op_pmflags & PMf_ONCE) {
1336 #ifdef USE_ITHREADS
1337             SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1338 #else
1339             dynpm->op_pmflags |= PMf_USED;
1340 #endif
1341         }
1342         goto gotcha;
1343     }
1344     else
1345         goto ret_no;
1346     /*NOTREACHED*/
1347
1348   gotcha:
1349     if (rxtainted)
1350         RX_MATCH_TAINTED_on(rx);
1351     TAINT_IF(RX_MATCH_TAINTED(rx));
1352     if (gimme == G_ARRAY) {
1353         const I32 nparens = rx->nparens;
1354         I32 i = (global && !nparens) ? 1 : 0;
1355
1356         SPAGAIN;                        /* EVAL blocks could move the stack. */
1357         EXTEND(SP, nparens + i);
1358         EXTEND_MORTAL(nparens + i);
1359         for (i = !i; i <= nparens; i++) {
1360             PUSHs(sv_newmortal());
1361             if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
1362                 const I32 len = rx->offs[i].end - rx->offs[i].start;
1363                 s = rx->offs[i].start + truebase;
1364                 if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
1365                     len < 0 || len > strend - s)
1366                     DIE(aTHX_ "panic: pp_match start/end pointers");
1367                 sv_setpvn(*SP, s, len);
1368                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1369                     SvUTF8_on(*SP);
1370             }
1371         }
1372         if (global) {
1373             if (dynpm->op_pmflags & PMf_CONTINUE) {
1374                 MAGIC* mg = NULL;
1375                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1376                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1377                 if (!mg) {
1378 #ifdef PERL_OLD_COPY_ON_WRITE
1379                     if (SvIsCOW(TARG))
1380                         sv_force_normal_flags(TARG, 0);
1381 #endif
1382                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1383                                      &PL_vtbl_mglob, NULL, 0);
1384                 }
1385                 if (rx->offs[0].start != -1) {
1386                     mg->mg_len = rx->offs[0].end;
1387                     if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1388                         mg->mg_flags |= MGf_MINMATCH;
1389                     else
1390                         mg->mg_flags &= ~MGf_MINMATCH;
1391                 }
1392             }
1393             had_zerolen = (rx->offs[0].start != -1
1394                            && (rx->offs[0].start + rx->gofs
1395                                == (UV)rx->offs[0].end));
1396             PUTBACK;                    /* EVAL blocks may use stack */
1397             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1398             goto play_it_again;
1399         }
1400         else if (!nparens)
1401             XPUSHs(&PL_sv_yes);
1402         LEAVE_SCOPE(oldsave);
1403         RETURN;
1404     }
1405     else {
1406         if (global) {
1407             MAGIC* mg;
1408             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1409                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1410             else
1411                 mg = NULL;
1412             if (!mg) {
1413 #ifdef PERL_OLD_COPY_ON_WRITE
1414                 if (SvIsCOW(TARG))
1415                     sv_force_normal_flags(TARG, 0);
1416 #endif
1417                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1418                                  &PL_vtbl_mglob, NULL, 0);
1419             }
1420             if (rx->offs[0].start != -1) {
1421                 mg->mg_len = rx->offs[0].end;
1422                 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1423                     mg->mg_flags |= MGf_MINMATCH;
1424                 else
1425                     mg->mg_flags &= ~MGf_MINMATCH;
1426             }
1427         }
1428         LEAVE_SCOPE(oldsave);
1429         RETPUSHYES;
1430     }
1431
1432 yup:                                    /* Confirmed by INTUIT */
1433     if (rxtainted)
1434         RX_MATCH_TAINTED_on(rx);
1435     TAINT_IF(RX_MATCH_TAINTED(rx));
1436     PL_curpm = pm;
1437     if (dynpm->op_pmflags & PMf_ONCE) {
1438 #ifdef USE_ITHREADS
1439         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1440 #else
1441         dynpm->op_pmflags |= PMf_USED;
1442 #endif
1443     }
1444     if (RX_MATCH_COPIED(rx))
1445         Safefree(rx->subbeg);
1446     RX_MATCH_COPIED_off(rx);
1447     rx->subbeg = NULL;
1448     if (global) {
1449         /* FIXME - should rx->subbeg be const char *?  */
1450         rx->subbeg = (char *) truebase;
1451         rx->offs[0].start = s - truebase;
1452         if (RX_MATCH_UTF8(rx)) {
1453             char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1454             rx->offs[0].end = t - truebase;
1455         }
1456         else {
1457             rx->offs[0].end = s - truebase + rx->minlenret;
1458         }
1459         rx->sublen = strend - truebase;
1460         goto gotcha;
1461     }
1462     if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) {
1463         I32 off;
1464 #ifdef PERL_OLD_COPY_ON_WRITE
1465         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1466             if (DEBUG_C_TEST) {
1467                 PerlIO_printf(Perl_debug_log,
1468                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1469                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1470                               (int)(t-truebase));
1471             }
1472             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1473             rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1474             assert (SvPOKp(rx->saved_copy));
1475         } else
1476 #endif
1477         {
1478
1479             rx->subbeg = savepvn(t, strend - t);
1480 #ifdef PERL_OLD_COPY_ON_WRITE
1481             rx->saved_copy = NULL;
1482 #endif
1483         }
1484         rx->sublen = strend - t;
1485         RX_MATCH_COPIED_on(rx);
1486         off = rx->offs[0].start = s - t;
1487         rx->offs[0].end = off + rx->minlenret;
1488     }
1489     else {                      /* startp/endp are used by @- @+. */
1490         rx->offs[0].start = s - truebase;
1491         rx->offs[0].end = s - truebase + rx->minlenret;
1492     }
1493     /* including rx->nparens in the below code seems highly suspicious.
1494        -dmq */
1495     rx->nparens = rx->lastparen = rx->lastcloseparen = 0;       /* used by @-, @+, and $^N */
1496     LEAVE_SCOPE(oldsave);
1497     RETPUSHYES;
1498
1499 nope:
1500 ret_no:
1501     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1502         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1503             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1504             if (mg)
1505                 mg->mg_len = -1;
1506         }
1507     }
1508     LEAVE_SCOPE(oldsave);
1509     if (gimme == G_ARRAY)
1510         RETURN;
1511     RETPUSHNO;
1512 }
1513
1514 OP *
1515 Perl_do_readline(pTHX)
1516 {
1517     dVAR; dSP; dTARGETSTACKED;
1518     register SV *sv;
1519     STRLEN tmplen = 0;
1520     STRLEN offset;
1521     PerlIO *fp;
1522     register IO * const io = GvIO(PL_last_in_gv);
1523     register const I32 type = PL_op->op_type;
1524     const I32 gimme = GIMME_V;
1525
1526     if (io) {
1527         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1528         if (mg) {
1529             PUSHMARK(SP);
1530             XPUSHs(SvTIED_obj((SV*)io, mg));
1531             PUTBACK;
1532             ENTER;
1533             call_method("READLINE", gimme);
1534             LEAVE;
1535             SPAGAIN;
1536             if (gimme == G_SCALAR) {
1537                 SV* const result = POPs;
1538                 SvSetSV_nosteal(TARG, result);
1539                 PUSHTARG;
1540             }
1541             RETURN;
1542         }
1543     }
1544     fp = NULL;
1545     if (io) {
1546         fp = IoIFP(io);
1547         if (!fp) {
1548             if (IoFLAGS(io) & IOf_ARGV) {
1549                 if (IoFLAGS(io) & IOf_START) {
1550                     IoLINES(io) = 0;
1551                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1552                         IoFLAGS(io) &= ~IOf_START;
1553                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1554                         sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1555                         SvSETMAGIC(GvSV(PL_last_in_gv));
1556                         fp = IoIFP(io);
1557                         goto have_fp;
1558                     }
1559                 }
1560                 fp = nextargv(PL_last_in_gv);
1561                 if (!fp) { /* Note: fp != IoIFP(io) */
1562                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1563                 }
1564             }
1565             else if (type == OP_GLOB)
1566                 fp = Perl_start_glob(aTHX_ POPs, io);
1567         }
1568         else if (type == OP_GLOB)
1569             SP--;
1570         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1571             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1572         }
1573     }
1574     if (!fp) {
1575         if ((!io || !(IoFLAGS(io) & IOf_START))
1576             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1577         {
1578             if (type == OP_GLOB)
1579                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1580                             "glob failed (can't start child: %s)",
1581                             Strerror(errno));
1582             else
1583                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1584         }
1585         if (gimme == G_SCALAR) {
1586             /* undef TARG, and push that undefined value */
1587             if (type != OP_RCATLINE) {
1588                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1589                 SvOK_off(TARG);
1590             }
1591             PUSHTARG;
1592         }
1593         RETURN;
1594     }
1595   have_fp:
1596     if (gimme == G_SCALAR) {
1597         sv = TARG;
1598         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1599             mg_get(sv);
1600         if (SvROK(sv)) {
1601             if (type == OP_RCATLINE)
1602                 SvPV_force_nolen(sv);
1603             else
1604                 sv_unref(sv);
1605         }
1606         else if (isGV_with_GP(sv)) {
1607             SvPV_force_nolen(sv);
1608         }
1609         SvUPGRADE(sv, SVt_PV);
1610         tmplen = SvLEN(sv);     /* remember if already alloced */
1611         if (!tmplen && !SvREADONLY(sv))
1612             Sv_Grow(sv, 80);    /* try short-buffering it */
1613         offset = 0;
1614         if (type == OP_RCATLINE && SvOK(sv)) {
1615             if (!SvPOK(sv)) {
1616                 SvPV_force_nolen(sv);
1617             }
1618             offset = SvCUR(sv);
1619         }
1620     }
1621     else {
1622         sv = sv_2mortal(newSV(80));
1623         offset = 0;
1624     }
1625
1626     /* This should not be marked tainted if the fp is marked clean */
1627 #define MAYBE_TAINT_LINE(io, sv) \
1628     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1629         TAINT;                          \
1630         SvTAINTED_on(sv);               \
1631     }
1632
1633 /* delay EOF state for a snarfed empty file */
1634 #define SNARF_EOF(gimme,rs,io,sv) \
1635     (gimme != G_SCALAR || SvCUR(sv)                                     \
1636      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1637
1638     for (;;) {
1639         PUTBACK;
1640         if (!sv_gets(sv, fp, offset)
1641             && (type == OP_GLOB
1642                 || SNARF_EOF(gimme, PL_rs, io, sv)
1643                 || PerlIO_error(fp)))
1644         {
1645             PerlIO_clearerr(fp);
1646             if (IoFLAGS(io) & IOf_ARGV) {
1647                 fp = nextargv(PL_last_in_gv);
1648                 if (fp)
1649                     continue;
1650                 (void)do_close(PL_last_in_gv, FALSE);
1651             }
1652             else if (type == OP_GLOB) {
1653                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1654                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1655                            "glob failed (child exited with status %d%s)",
1656                            (int)(STATUS_CURRENT >> 8),
1657                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1658                 }
1659             }
1660             if (gimme == G_SCALAR) {
1661                 if (type != OP_RCATLINE) {
1662                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1663                     SvOK_off(TARG);
1664                 }
1665                 SPAGAIN;
1666                 PUSHTARG;
1667             }
1668             MAYBE_TAINT_LINE(io, sv);
1669             RETURN;
1670         }
1671         MAYBE_TAINT_LINE(io, sv);
1672         IoLINES(io)++;
1673         IoFLAGS(io) |= IOf_NOLINE;
1674         SvSETMAGIC(sv);
1675         SPAGAIN;
1676         XPUSHs(sv);
1677         if (type == OP_GLOB) {
1678             const char *t1;
1679
1680             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1681                 char * const tmps = SvEND(sv) - 1;
1682                 if (*tmps == *SvPVX_const(PL_rs)) {
1683                     *tmps = '\0';
1684                     SvCUR_set(sv, SvCUR(sv) - 1);
1685                 }
1686             }
1687             for (t1 = SvPVX_const(sv); *t1; t1++)
1688                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1689                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1690                         break;
1691             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1692                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1693                 continue;
1694             }
1695         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1696              if (ckWARN(WARN_UTF8)) {
1697                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1698                 const STRLEN len = SvCUR(sv) - offset;
1699                 const U8 *f;
1700
1701                 if (!is_utf8_string_loc(s, len, &f))
1702                     /* Emulate :encoding(utf8) warning in the same case. */
1703                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1704                                 "utf8 \"\\x%02X\" does not map to Unicode",
1705                                 f < (U8*)SvEND(sv) ? *f : 0);
1706              }
1707         }
1708         if (gimme == G_ARRAY) {
1709             if (SvLEN(sv) - SvCUR(sv) > 20) {
1710                 SvPV_shrink_to_cur(sv);
1711             }
1712             sv = sv_2mortal(newSV(80));
1713             continue;
1714         }
1715         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1716             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1717             const STRLEN new_len
1718                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1719             SvPV_renew(sv, new_len);
1720         }
1721         RETURN;
1722     }
1723 }
1724
1725 PP(pp_enter)
1726 {
1727     dVAR; dSP;
1728     register PERL_CONTEXT *cx;
1729     I32 gimme = OP_GIMME(PL_op, -1);
1730
1731     if (gimme == -1) {
1732         if (cxstack_ix >= 0)
1733             gimme = cxstack[cxstack_ix].blk_gimme;
1734         else
1735             gimme = G_SCALAR;
1736     }
1737
1738     ENTER;
1739
1740     SAVETMPS;
1741     PUSHBLOCK(cx, CXt_BLOCK, SP);
1742
1743     RETURN;
1744 }
1745
1746 PP(pp_helem)
1747 {
1748     dVAR; dSP;
1749     HE* he;
1750     SV **svp;
1751     SV * const keysv = POPs;
1752     HV * const hv = (HV*)POPs;
1753     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1754     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1755     SV *sv;
1756     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1757     I32 preeminent = 0;
1758
1759     if (SvTYPE(hv) != SVt_PVHV)
1760         RETPUSHUNDEF;
1761
1762     if (PL_op->op_private & OPpLVAL_INTRO) {
1763         MAGIC *mg;
1764         HV *stash;
1765         /* does the element we're localizing already exist? */
1766         preeminent = /* can we determine whether it exists? */
1767             (    !SvRMAGICAL(hv)
1768                 || mg_find((SV*)hv, PERL_MAGIC_env)
1769                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1770                         /* Try to preserve the existenceness of a tied hash
1771                         * element by using EXISTS and DELETE if possible.
1772                         * Fallback to FETCH and STORE otherwise */
1773                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1774                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1775                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1776                 )
1777             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1778     }
1779     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1780     svp = he ? &HeVAL(he) : NULL;
1781     if (lval) {
1782         if (!svp || *svp == &PL_sv_undef) {
1783             SV* lv;
1784             SV* key2;
1785             if (!defer) {
1786                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1787             }
1788             lv = sv_newmortal();
1789             sv_upgrade(lv, SVt_PVLV);
1790             LvTYPE(lv) = 'y';
1791             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1792             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1793             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1794             LvTARGLEN(lv) = 1;
1795             PUSHs(lv);
1796             RETURN;
1797         }
1798         if (PL_op->op_private & OPpLVAL_INTRO) {
1799             if (HvNAME_get(hv) && isGV(*svp))
1800                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1801             else {
1802                 if (!preeminent) {
1803                     STRLEN keylen;
1804                     const char * const key = SvPV_const(keysv, keylen);
1805                     SAVEDELETE(hv, savepvn(key,keylen),
1806                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1807                 } else
1808                     save_helem(hv, keysv, svp);
1809             }
1810         }
1811         else if (PL_op->op_private & OPpDEREF)
1812             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1813     }
1814     sv = (svp ? *svp : &PL_sv_undef);
1815     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1816      * Pushing the magical RHS on to the stack is useless, since
1817      * that magic is soon destined to be misled by the local(),
1818      * and thus the later pp_sassign() will fail to mg_get() the
1819      * old value.  This should also cure problems with delayed
1820      * mg_get()s.  GSAR 98-07-03 */
1821     if (!lval && SvGMAGICAL(sv))
1822         sv = sv_mortalcopy(sv);
1823     PUSHs(sv);
1824     RETURN;
1825 }
1826
1827 PP(pp_leave)
1828 {
1829     dVAR; dSP;
1830     register PERL_CONTEXT *cx;
1831     SV **newsp;
1832     PMOP *newpm;
1833     I32 gimme;
1834
1835     if (PL_op->op_flags & OPf_SPECIAL) {
1836         cx = &cxstack[cxstack_ix];
1837         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1838     }
1839
1840     POPBLOCK(cx,newpm);
1841
1842     gimme = OP_GIMME(PL_op, -1);
1843     if (gimme == -1) {
1844         if (cxstack_ix >= 0)
1845             gimme = cxstack[cxstack_ix].blk_gimme;
1846         else
1847             gimme = G_SCALAR;
1848     }
1849
1850     TAINT_NOT;
1851     if (gimme == G_VOID)
1852         SP = newsp;
1853     else if (gimme == G_SCALAR) {
1854         register SV **mark;
1855         MARK = newsp + 1;
1856         if (MARK <= SP) {
1857             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1858                 *MARK = TOPs;
1859             else
1860                 *MARK = sv_mortalcopy(TOPs);
1861         } else {
1862             MEXTEND(mark,0);
1863             *MARK = &PL_sv_undef;
1864         }
1865         SP = MARK;
1866     }
1867     else if (gimme == G_ARRAY) {
1868         /* in case LEAVE wipes old return values */
1869         register SV **mark;
1870         for (mark = newsp + 1; mark <= SP; mark++) {
1871             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1872                 *mark = sv_mortalcopy(*mark);
1873                 TAINT_NOT;      /* Each item is independent */
1874             }
1875         }
1876     }
1877     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1878
1879     LEAVE;
1880
1881     RETURN;
1882 }
1883
1884 PP(pp_iter)
1885 {
1886     dVAR; dSP;
1887     register PERL_CONTEXT *cx;
1888     SV *sv, *oldsv;
1889     AV* av;
1890     SV **itersvp;
1891
1892     EXTEND(SP, 1);
1893     cx = &cxstack[cxstack_ix];
1894     if (CxTYPE(cx) != CXt_LOOP)
1895         DIE(aTHX_ "panic: pp_iter");
1896
1897     itersvp = CxITERVAR(cx);
1898     av = cx->blk_loop.iterary;
1899     if (SvTYPE(av) != SVt_PVAV) {
1900         /* iterate ($min .. $max) */
1901         if (cx->blk_loop.iterlval) {
1902             /* string increment */
1903             register SV* cur = cx->blk_loop.iterlval;
1904             STRLEN maxlen = 0;
1905             const char *max =
1906               SvOK((SV*)av) ?
1907               SvPV_const((SV*)av, maxlen) : (const char *)"";
1908             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1909                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1910                     /* safe to reuse old SV */
1911                     sv_setsv(*itersvp, cur);
1912                 }
1913                 else
1914                 {
1915                     /* we need a fresh SV every time so that loop body sees a
1916                      * completely new SV for closures/references to work as
1917                      * they used to */
1918                     oldsv = *itersvp;
1919                     *itersvp = newSVsv(cur);
1920                     SvREFCNT_dec(oldsv);
1921                 }
1922                 if (strEQ(SvPVX_const(cur), max))
1923                     sv_setiv(cur, 0); /* terminate next time */
1924                 else
1925                     sv_inc(cur);
1926                 RETPUSHYES;
1927             }
1928             RETPUSHNO;
1929         }
1930         /* integer increment */
1931         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1932             RETPUSHNO;
1933
1934         /* don't risk potential race */
1935         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1936             /* safe to reuse old SV */
1937             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1938         }
1939         else
1940         {
1941             /* we need a fresh SV every time so that loop body sees a
1942              * completely new SV for closures/references to work as they
1943              * used to */
1944             oldsv = *itersvp;
1945             *itersvp = newSViv(cx->blk_loop.iterix++);
1946             SvREFCNT_dec(oldsv);
1947         }
1948         RETPUSHYES;
1949     }
1950
1951     /* iterate array */
1952     if (PL_op->op_private & OPpITER_REVERSED) {
1953         /* In reverse, use itermax as the min :-)  */
1954         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1955             RETPUSHNO;
1956
1957         if (SvMAGICAL(av) || AvREIFY(av)) {
1958             SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1959             sv = svp ? *svp : NULL;
1960         }
1961         else {
1962             sv = AvARRAY(av)[--cx->blk_loop.iterix];
1963         }
1964     }
1965     else {
1966         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1967                                     AvFILL(av)))
1968             RETPUSHNO;
1969
1970         if (SvMAGICAL(av) || AvREIFY(av)) {
1971             SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1972             sv = svp ? *svp : NULL;
1973         }
1974         else {
1975             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1976         }
1977     }
1978
1979     if (sv && SvIS_FREED(sv)) {
1980         *itersvp = NULL;
1981         Perl_croak(aTHX_ "Use of freed value in iteration");
1982     }
1983
1984     if (sv)
1985         SvTEMP_off(sv);
1986     else
1987         sv = &PL_sv_undef;
1988     if (av != PL_curstack && sv == &PL_sv_undef) {
1989         SV *lv = cx->blk_loop.iterlval;
1990         if (lv && SvREFCNT(lv) > 1) {
1991             SvREFCNT_dec(lv);
1992             lv = NULL;
1993         }
1994         if (lv)
1995             SvREFCNT_dec(LvTARG(lv));
1996         else {
1997             lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1998             LvTYPE(lv) = 'y';
1999             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2000         }
2001         LvTARG(lv) = SvREFCNT_inc_simple(av);
2002         LvTARGOFF(lv) = cx->blk_loop.iterix;
2003         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2004         sv = (SV*)lv;
2005     }
2006
2007     oldsv = *itersvp;
2008     *itersvp = SvREFCNT_inc_simple_NN(sv);
2009     SvREFCNT_dec(oldsv);
2010
2011     RETPUSHYES;
2012 }
2013
2014 PP(pp_subst)
2015 {
2016     dVAR; dSP; dTARG;
2017     register PMOP *pm = cPMOP;
2018     PMOP *rpm = pm;
2019     register char *s;
2020     char *strend;
2021     register char *m;
2022     const char *c;
2023     register char *d;
2024     STRLEN clen;
2025     I32 iters = 0;
2026     I32 maxiters;
2027     register I32 i;
2028     bool once;
2029     bool rxtainted;
2030     char *orig;
2031     I32 r_flags;
2032     register REGEXP *rx = PM_GETRE(pm);
2033     STRLEN len;
2034     int force_on_match = 0;
2035     const I32 oldsave = PL_savestack_ix;
2036     STRLEN slen;
2037     bool doutf8 = FALSE;
2038     I32 matched;
2039 #ifdef PERL_OLD_COPY_ON_WRITE
2040     bool is_cow;
2041 #endif
2042     SV *nsv = NULL;
2043
2044     /* known replacement string? */
2045     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2046     if (PL_op->op_flags & OPf_STACKED)
2047         TARG = POPs;
2048     else if (PL_op->op_private & OPpTARGET_MY)
2049         GETTARGET;
2050     else {
2051         TARG = DEFSV;
2052         EXTEND(SP,1);
2053     }
2054
2055 #ifdef PERL_OLD_COPY_ON_WRITE
2056     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2057        because they make integers such as 256 "false".  */
2058     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2059 #else
2060     if (SvIsCOW(TARG))
2061         sv_force_normal_flags(TARG,0);
2062 #endif
2063     if (
2064 #ifdef PERL_OLD_COPY_ON_WRITE
2065         !is_cow &&
2066 #endif
2067         (SvREADONLY(TARG)
2068          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2069                || SvTYPE(TARG) > SVt_PVLV)
2070              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2071         DIE(aTHX_ PL_no_modify);
2072     PUTBACK;
2073
2074     s = SvPV_mutable(TARG, len);
2075     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2076         force_on_match = 1;
2077     rxtainted = ((rx->extflags & RXf_TAINTED) ||
2078                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2079     if (PL_tainted)
2080         rxtainted |= 2;
2081     TAINT_NOT;
2082
2083     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2084
2085   force_it:
2086     if (!pm || !s)
2087         DIE(aTHX_ "panic: pp_subst");
2088
2089     strend = s + len;
2090     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2091     maxiters = 2 * slen + 10;   /* We can match twice at each
2092                                    position, once with zero-length,
2093                                    second time with non-zero. */
2094
2095     if (!RX_PRELEN(rx) && PL_curpm) {
2096         pm = PL_curpm;
2097         rx = PM_GETRE(pm);
2098     }
2099     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2100             || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2101                ? REXEC_COPY_STR : 0;
2102     if (SvSCREAM(TARG))
2103         r_flags |= REXEC_SCREAM;
2104
2105     orig = m = s;
2106     if (rx->extflags & RXf_USE_INTUIT) {
2107         PL_bostr = orig;
2108         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2109
2110         if (!s)
2111             goto nope;
2112         /* How to do it in subst? */
2113 /*      if ( (rx->extflags & RXf_CHECK_ALL)
2114              && !PL_sawampersand
2115              && !(rx->extflags & RXf_KEEPCOPY)
2116              && ((rx->extflags & RXf_NOSCAN)
2117                  || !((rx->extflags & RXf_INTUIT_TAIL)
2118                       && (r_flags & REXEC_SCREAM))))
2119             goto yup;
2120 */
2121     }
2122
2123     /* only replace once? */
2124     once = !(rpm->op_pmflags & PMf_GLOBAL);
2125     matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2126                          r_flags | REXEC_CHECKED);
2127     /* known replacement string? */
2128     if (dstr) {
2129         /* replacement needing upgrading? */
2130         if (DO_UTF8(TARG) && !doutf8) {
2131              nsv = sv_newmortal();
2132              SvSetSV(nsv, dstr);
2133              if (PL_encoding)
2134                   sv_recode_to_utf8(nsv, PL_encoding);
2135              else
2136                   sv_utf8_upgrade(nsv);
2137              c = SvPV_const(nsv, clen);
2138              doutf8 = TRUE;
2139         }
2140         else {
2141             c = SvPV_const(dstr, clen);
2142             doutf8 = DO_UTF8(dstr);
2143         }
2144     }
2145     else {
2146         c = NULL;
2147         doutf8 = FALSE;
2148     }
2149
2150     /* can do inplace substitution? */
2151     if (c
2152 #ifdef PERL_OLD_COPY_ON_WRITE
2153         && !is_cow
2154 #endif
2155         && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2156         && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2157         && (!doutf8 || SvUTF8(TARG))) {
2158         if (!matched)
2159         {
2160             SPAGAIN;
2161             PUSHs(&PL_sv_no);
2162             LEAVE_SCOPE(oldsave);
2163             RETURN;
2164         }
2165 #ifdef PERL_OLD_COPY_ON_WRITE
2166         if (SvIsCOW(TARG)) {
2167             assert (!force_on_match);
2168             goto have_a_cow;
2169         }
2170 #endif
2171         if (force_on_match) {
2172             force_on_match = 0;
2173             s = SvPV_force(TARG, len);
2174             goto force_it;
2175         }
2176         d = s;
2177         PL_curpm = pm;
2178         SvSCREAM_off(TARG);     /* disable possible screamer */
2179         if (once) {
2180             rxtainted |= RX_MATCH_TAINTED(rx);
2181             m = orig + rx->offs[0].start;
2182             d = orig + rx->offs[0].end;
2183             s = orig;
2184             if (m - s > strend - d) {  /* faster to shorten from end */
2185                 if (clen) {
2186                     Copy(c, m, clen, char);
2187                     m += clen;
2188                 }
2189                 i = strend - d;
2190                 if (i > 0) {
2191                     Move(d, m, i, char);
2192                     m += i;
2193                 }
2194                 *m = '\0';
2195                 SvCUR_set(TARG, m - s);
2196             }
2197             else if ((i = m - s)) {     /* faster from front */
2198                 d -= clen;
2199                 m = d;
2200                 Move(s, d - i, i, char);
2201                 sv_chop(TARG, d-i);
2202                 if (clen)
2203                     Copy(c, m, clen, char);
2204             }
2205             else if (clen) {
2206                 d -= clen;
2207                 sv_chop(TARG, d);
2208                 Copy(c, d, clen, char);
2209             }
2210             else {
2211                 sv_chop(TARG, d);
2212             }
2213             TAINT_IF(rxtainted & 1);
2214             SPAGAIN;
2215             PUSHs(&PL_sv_yes);
2216         }
2217         else {
2218             do {
2219                 if (iters++ > maxiters)
2220                     DIE(aTHX_ "Substitution loop");
2221                 rxtainted |= RX_MATCH_TAINTED(rx);
2222                 m = rx->offs[0].start + orig;
2223                 if ((i = m - s)) {
2224                     if (s != d)
2225                         Move(s, d, i, char);
2226                     d += i;
2227                 }
2228                 if (clen) {
2229                     Copy(c, d, clen, char);
2230                     d += clen;
2231                 }
2232                 s = rx->offs[0].end + orig;
2233             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2234                                  TARG, NULL,
2235                                  /* don't match same null twice */
2236                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2237             if (s != d) {
2238                 i = strend - s;
2239                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2240                 Move(s, d, i+1, char);          /* include the NUL */
2241             }
2242             TAINT_IF(rxtainted & 1);
2243             SPAGAIN;
2244             PUSHs(sv_2mortal(newSViv((I32)iters)));
2245         }
2246         (void)SvPOK_only_UTF8(TARG);
2247         TAINT_IF(rxtainted);
2248         if (SvSMAGICAL(TARG)) {
2249             PUTBACK;
2250             mg_set(TARG);
2251             SPAGAIN;
2252         }
2253         SvTAINT(TARG);
2254         if (doutf8)
2255             SvUTF8_on(TARG);
2256         LEAVE_SCOPE(oldsave);
2257         RETURN;
2258     }
2259
2260     if (matched)
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         prepare_SV_for_RV(sv);
2943         switch (to_what) {
2944         case OPpDEREF_SV:
2945             SvRV_set(sv, newSV(0));
2946             break;
2947         case OPpDEREF_AV:
2948             SvRV_set(sv, (SV*)newAV());
2949             break;
2950         case OPpDEREF_HV:
2951             SvRV_set(sv, (SV*)newHV());
2952             break;
2953         }
2954         SvROK_on(sv);
2955         SvSETMAGIC(sv);
2956     }
2957 }
2958
2959 PP(pp_method)
2960 {
2961     dVAR; dSP;
2962     SV* const sv = TOPs;
2963
2964     if (SvROK(sv)) {
2965         SV* const rsv = SvRV(sv);
2966         if (SvTYPE(rsv) == SVt_PVCV) {
2967             SETs(rsv);
2968             RETURN;
2969         }
2970     }
2971
2972     SETs(method_common(sv, NULL));
2973     RETURN;
2974 }
2975
2976 PP(pp_method_named)
2977 {
2978     dVAR; dSP;
2979     SV* const sv = cSVOP_sv;
2980     U32 hash = SvSHARED_HASH(sv);
2981
2982     XPUSHs(method_common(sv, &hash));
2983     RETURN;
2984 }
2985
2986 STATIC SV *
2987 S_method_common(pTHX_ SV* meth, U32* hashp)
2988 {
2989     dVAR;
2990     SV* ob;
2991     GV* gv;
2992     HV* stash;
2993     STRLEN namelen;
2994     const char* packname = NULL;
2995     SV *packsv = NULL;
2996     STRLEN packlen;
2997     const char * const name = SvPV_const(meth, namelen);
2998     SV * const sv = *(PL_stack_base + TOPMARK + 1);
2999
3000     if (!sv)
3001         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3002
3003     SvGETMAGIC(sv);
3004     if (SvROK(sv))
3005         ob = (SV*)SvRV(sv);
3006     else {
3007         GV* iogv;
3008
3009         /* this isn't a reference */
3010         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3011           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3012           if (he) {
3013             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3014             goto fetch;
3015           }
3016         }
3017
3018         if (!SvOK(sv) ||
3019             !(packname) ||
3020             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3021             !(ob=(SV*)GvIO(iogv)))
3022         {
3023             /* this isn't the name of a filehandle either */
3024             if (!packname ||
3025                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3026                     ? !isIDFIRST_utf8((U8*)packname)
3027                     : !isIDFIRST(*packname)
3028                 ))
3029             {
3030                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3031                            SvOK(sv) ? "without a package or object reference"
3032                                     : "on an undefined value");
3033             }
3034             /* assume it's a package name */
3035             stash = gv_stashpvn(packname, packlen, 0);
3036             if (!stash)
3037                 packsv = sv;
3038             else {
3039                 SV* const ref = newSViv(PTR2IV(stash));
3040                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3041             }
3042             goto fetch;
3043         }
3044         /* it _is_ a filehandle name -- replace with a reference */
3045         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3046     }
3047
3048     /* if we got here, ob should be a reference or a glob */
3049     if (!ob || !(SvOBJECT(ob)
3050                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3051                      && SvOBJECT(ob))))
3052     {
3053         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3054                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3055                    name);
3056     }
3057
3058     stash = SvSTASH(ob);
3059
3060   fetch:
3061     /* NOTE: stash may be null, hope hv_fetch_ent and
3062        gv_fetchmethod can cope (it seems they can) */
3063
3064     /* shortcut for simple names */
3065     if (hashp) {
3066         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3067         if (he) {
3068             gv = (GV*)HeVAL(he);
3069             if (isGV(gv) && GvCV(gv) &&
3070                 (!GvCVGEN(gv) || GvCVGEN(gv)
3071                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3072                 return (SV*)GvCV(gv);
3073         }
3074     }
3075
3076     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3077
3078     if (!gv) {
3079         /* This code tries to figure out just what went wrong with
3080            gv_fetchmethod.  It therefore needs to duplicate a lot of
3081            the internals of that function.  We can't move it inside
3082            Perl_gv_fetchmethod_autoload(), however, since that would
3083            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3084            don't want that.
3085         */
3086         const char* leaf = name;
3087         const char* sep = NULL;
3088         const char* p;
3089
3090         for (p = name; *p; p++) {
3091             if (*p == '\'')
3092                 sep = p, leaf = p + 1;
3093             else if (*p == ':' && *(p + 1) == ':')
3094                 sep = p, leaf = p + 2;
3095         }
3096         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3097             /* the method name is unqualified or starts with SUPER:: */
3098 #ifndef USE_ITHREADS
3099             if (sep)
3100                 stash = CopSTASH(PL_curcop);
3101 #else
3102             bool need_strlen = 1;
3103             if (sep) {
3104                 packname = CopSTASHPV(PL_curcop);
3105             }
3106             else
3107 #endif
3108             if (stash) {
3109                 HEK * const packhek = HvNAME_HEK(stash);
3110                 if (packhek) {
3111                     packname = HEK_KEY(packhek);
3112                     packlen = HEK_LEN(packhek);
3113 #ifdef USE_ITHREADS
3114                     need_strlen = 0;
3115 #endif
3116                 } else {
3117                     goto croak;
3118                 }
3119             }
3120
3121             if (!packname) {
3122             croak:
3123                 Perl_croak(aTHX_
3124                            "Can't use anonymous symbol table for method lookup");
3125             }
3126 #ifdef USE_ITHREADS
3127             if (need_strlen)
3128                 packlen = strlen(packname);
3129 #endif
3130
3131         }
3132         else {
3133             /* the method name is qualified */
3134             packname = name;
3135             packlen = sep - name;
3136         }
3137
3138         /* we're relying on gv_fetchmethod not autovivifying the stash */
3139         if (gv_stashpvn(packname, packlen, 0)) {
3140             Perl_croak(aTHX_
3141                        "Can't locate object method \"%s\" via package \"%.*s\"",
3142                        leaf, (int)packlen, packname);
3143         }
3144         else {
3145             Perl_croak(aTHX_
3146                        "Can't locate object method \"%s\" via package \"%.*s\""
3147                        " (perhaps you forgot to load \"%.*s\"?)",
3148                        leaf, (int)packlen, packname, (int)packlen, packname);
3149         }
3150     }
3151     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3152 }
3153
3154 /*
3155  * Local variables:
3156  * c-indentation-style: bsd
3157  * c-basic-offset: 4
3158  * indent-tabs-mode: t
3159  * End:
3160  *
3161  * ex: set ts=8 sts=4 sw=4 noet:
3162  */