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