pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  13  * shaking the air.
  14  *
  15  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  16  *                     Fire, Foes!  Awake!
  17  */
  18
  19 /* This file contains 'hot' pp ("push/pop") functions that
  20  * execute the opcodes that make up a perl program. A typical pp function
  21  * expects to find its arguments on the stack, and usually pushes its
  22  * results onto the stack, hence the 'pp' terminology. Each OP structure
  23  * contains a pointer to the relevant pp_foo() function.
  24  *
  25  * By 'hot', we mean common ops whose execution speed is critical.
  26  * By gathering them together into a single file, we encourage
  27  * CPU cache hits on hot code. Also it could be taken as a warning not to
  28  * change any code in this file unless you're sure it won't affect
  29  * performance.
  30  */
  31
  32 #include "EXTERN.h"
  33 #define PERL_IN_PP_HOT_C
  34 #include "perl.h"
  35
  36 /* Hot code. */
  37
  38 PP(pp_const)
  39 {
  40     dVAR;
  41     dSP;
  42     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                 SvPCS_IMPORTED_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, INT2PTR(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 == (UV)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 == (UV)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 == (UV)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), (void*)truebase, (void*)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 (type == OP_RCATLINE && SvGMAGICAL(sv))
1654             mg_get(sv);
1655         if (SvROK(sv)) {
1656             if (type == OP_RCATLINE)
1657                 SvPV_force_nolen(sv);
1658             else
1659                 sv_unref(sv);
1660         }
1661         else if (isGV_with_GP(sv)) {
1662             SvPV_force_nolen(sv);
1663         }
1664         SvUPGRADE(sv, SVt_PV);
1665         tmplen = SvLEN(sv);     /* remember if already alloced */
1666         if (!tmplen && !SvREADONLY(sv))
1667             Sv_Grow(sv, 80);    /* try short-buffering it */
1668         offset = 0;
1669         if (type == OP_RCATLINE && SvOK(sv)) {
1670             if (!SvPOK(sv)) {
1671                 SvPV_force_nolen(sv);
1672             }
1673             offset = SvCUR(sv);
1674         }
1675     }
1676     else {
1677         sv = sv_2mortal(newSV(80));
1678         offset = 0;
1679     }
1680
1681     /* This should not be marked tainted if the fp is marked clean */
1682 #define MAYBE_TAINT_LINE(io, sv) \
1683     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1684         TAINT;                          \
1685         SvTAINTED_on(sv);               \
1686     }
1687
1688 /* delay EOF state for a snarfed empty file */
1689 #define SNARF_EOF(gimme,rs,io,sv) \
1690     (gimme != G_SCALAR || SvCUR(sv)                                     \
1691      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1692
1693     for (;;) {
1694         PUTBACK;
1695         if (!sv_gets(sv, fp, offset)
1696             && (type == OP_GLOB
1697                 || SNARF_EOF(gimme, PL_rs, io, sv)
1698                 || PerlIO_error(fp)))
1699         {
1700             PerlIO_clearerr(fp);
1701             if (IoFLAGS(io) & IOf_ARGV) {
1702                 fp = nextargv(PL_last_in_gv);
1703                 if (fp)
1704                     continue;
1705                 (void)do_close(PL_last_in_gv, FALSE);
1706             }
1707             else if (type == OP_GLOB) {
1708                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1709                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1710                            "glob failed (child exited with status %d%s)",
1711                            (int)(STATUS_CURRENT >> 8),
1712                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1713                 }
1714             }
1715             if (gimme == G_SCALAR) {
1716                 if (type != OP_RCATLINE) {
1717                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1718                     SvOK_off(TARG);
1719                 }
1720                 SPAGAIN;
1721                 PUSHTARG;
1722             }
1723             MAYBE_TAINT_LINE(io, sv);
1724             RETURN;
1725         }
1726         MAYBE_TAINT_LINE(io, sv);
1727         IoLINES(io)++;
1728         IoFLAGS(io) |= IOf_NOLINE;
1729         SvSETMAGIC(sv);
1730         SPAGAIN;
1731         XPUSHs(sv);
1732         if (type == OP_GLOB) {
1733             const char *t1;
1734
1735             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1736                 char * const tmps = SvEND(sv) - 1;
1737                 if (*tmps == *SvPVX_const(PL_rs)) {
1738                     *tmps = '\0';
1739                     SvCUR_set(sv, SvCUR(sv) - 1);
1740                 }
1741             }
1742             for (t1 = SvPVX_const(sv); *t1; t1++)
1743                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1744                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1745                         break;
1746             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1747                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1748                 continue;
1749             }
1750         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1751              if (ckWARN(WARN_UTF8)) {
1752                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1753                 const STRLEN len = SvCUR(sv) - offset;
1754                 const U8 *f;
1755
1756                 if (!is_utf8_string_loc(s, len, &f))
1757                     /* Emulate :encoding(utf8) warning in the same case. */
1758                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1759                                 "utf8 \"\\x%02X\" does not map to Unicode",
1760                                 f < (U8*)SvEND(sv) ? *f : 0);
1761              }
1762         }
1763         if (gimme == G_ARRAY) {
1764             if (SvLEN(sv) - SvCUR(sv) > 20) {
1765                 SvPV_shrink_to_cur(sv);
1766             }
1767             sv = sv_2mortal(newSV(80));
1768             continue;
1769         }
1770         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1771             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1772             const STRLEN new_len
1773                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1774             SvPV_renew(sv, new_len);
1775         }
1776         RETURN;
1777     }
1778 }
1779
1780 PP(pp_enter)
1781 {
1782     dVAR; dSP;
1783     register PERL_CONTEXT *cx;
1784     I32 gimme = OP_GIMME(PL_op, -1);
1785
1786     if (gimme == -1) {
1787         if (cxstack_ix >= 0)
1788             gimme = cxstack[cxstack_ix].blk_gimme;
1789         else
1790             gimme = G_SCALAR;
1791     }
1792
1793     ENTER;
1794
1795     SAVETMPS;
1796     PUSHBLOCK(cx, CXt_BLOCK, SP);
1797
1798     RETURN;
1799 }
1800
1801 PP(pp_helem)
1802 {
1803     dVAR; dSP;
1804     HE* he;
1805     SV **svp;
1806     SV * const keysv = POPs;
1807     HV * const hv = (HV*)POPs;
1808     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1809     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1810     SV *sv;
1811     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1812     I32 preeminent = 0;
1813
1814     if (SvTYPE(hv) != SVt_PVHV)
1815         RETPUSHUNDEF;
1816
1817     if (PL_op->op_private & OPpLVAL_INTRO) {
1818         MAGIC *mg;
1819         HV *stash;
1820         /* does the element we're localizing already exist? */
1821         preeminent = /* can we determine whether it exists? */
1822             (    !SvRMAGICAL(hv)
1823                 || mg_find((SV*)hv, PERL_MAGIC_env)
1824                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1825                         /* Try to preserve the existenceness of a tied hash
1826                         * element by using EXISTS and DELETE if possible.
1827                         * Fallback to FETCH and STORE otherwise */
1828                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1829                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1830                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1831                 )
1832             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1833     }
1834     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1835     svp = he ? &HeVAL(he) : NULL;
1836     if (lval) {
1837         if (!svp || *svp == &PL_sv_undef) {
1838             SV* lv;
1839             SV* key2;
1840             if (!defer) {
1841                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1842             }
1843             lv = sv_newmortal();
1844             sv_upgrade(lv, SVt_PVLV);
1845             LvTYPE(lv) = 'y';
1846             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1847             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1848             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1849             LvTARGLEN(lv) = 1;
1850             PUSHs(lv);
1851             RETURN;
1852         }
1853         if (PL_op->op_private & OPpLVAL_INTRO) {
1854             if (HvNAME_get(hv) && isGV(*svp))
1855                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1856             else {
1857                 if (!preeminent) {
1858                     STRLEN keylen;
1859                     const char * const key = SvPV_const(keysv, keylen);
1860                     SAVEDELETE(hv, savepvn(key,keylen),
1861                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1862                 } else
1863                     save_helem(hv, keysv, svp);
1864             }
1865         }
1866         else if (PL_op->op_private & OPpDEREF)
1867             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1868     }
1869     sv = (svp ? *svp : &PL_sv_undef);
1870     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1871      * Pushing the magical RHS on to the stack is useless, since
1872      * that magic is soon destined to be misled by the local(),
1873      * and thus the later pp_sassign() will fail to mg_get() the
1874      * old value.  This should also cure problems with delayed
1875      * mg_get()s.  GSAR 98-07-03 */
1876     if (!lval && SvGMAGICAL(sv))
1877         sv = sv_mortalcopy(sv);
1878     PUSHs(sv);
1879     RETURN;
1880 }
1881
1882 PP(pp_leave)
1883 {
1884     dVAR; dSP;
1885     register PERL_CONTEXT *cx;
1886     SV **newsp;
1887     PMOP *newpm;
1888     I32 gimme;
1889
1890     if (PL_op->op_flags & OPf_SPECIAL) {
1891         cx = &cxstack[cxstack_ix];
1892         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1893     }
1894
1895     POPBLOCK(cx,newpm);
1896
1897     gimme = OP_GIMME(PL_op, -1);
1898     if (gimme == -1) {
1899         if (cxstack_ix >= 0)
1900             gimme = cxstack[cxstack_ix].blk_gimme;
1901         else
1902             gimme = G_SCALAR;
1903     }
1904
1905     TAINT_NOT;
1906     if (gimme == G_VOID)
1907         SP = newsp;
1908     else if (gimme == G_SCALAR) {
1909         register SV **mark;
1910         MARK = newsp + 1;
1911         if (MARK <= SP) {
1912             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1913                 *MARK = TOPs;
1914             else
1915                 *MARK = sv_mortalcopy(TOPs);
1916         } else {
1917             MEXTEND(mark,0);
1918             *MARK = &PL_sv_undef;
1919         }
1920         SP = MARK;
1921     }
1922     else if (gimme == G_ARRAY) {
1923         /* in case LEAVE wipes old return values */
1924         register SV **mark;
1925         for (mark = newsp + 1; mark <= SP; mark++) {
1926             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1927                 *mark = sv_mortalcopy(*mark);
1928                 TAINT_NOT;      /* Each item is independent */
1929             }
1930         }
1931     }
1932     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1933
1934     LEAVE;
1935
1936     RETURN;
1937 }
1938
1939 PP(pp_iter)
1940 {
1941     dVAR; dSP;
1942     register PERL_CONTEXT *cx;
1943     SV *sv, *oldsv;
1944     AV* av;
1945     SV **itersvp;
1946
1947     EXTEND(SP, 1);
1948     cx = &cxstack[cxstack_ix];
1949     if (CxTYPE(cx) != CXt_LOOP)
1950         DIE(aTHX_ "panic: pp_iter");
1951
1952     itersvp = CxITERVAR(cx);
1953     av = cx->blk_loop.iterary;
1954     if (SvTYPE(av) != SVt_PVAV) {
1955         /* iterate ($min .. $max) */
1956         if (cx->blk_loop.iterlval) {
1957             /* string increment */
1958             register SV* cur = cx->blk_loop.iterlval;
1959             STRLEN maxlen = 0;
1960             const char *max =
1961               SvOK((SV*)av) ?
1962               SvPV_const((SV*)av, maxlen) : (const char *)"";
1963             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1964                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1965                     /* safe to reuse old SV */
1966                     sv_setsv(*itersvp, cur);
1967                 }
1968                 else
1969                 {
1970                     /* we need a fresh SV every time so that loop body sees a
1971                      * completely new SV for closures/references to work as
1972                      * they used to */
1973                     oldsv = *itersvp;
1974                     *itersvp = newSVsv(cur);
1975                     SvREFCNT_dec(oldsv);
1976                 }
1977                 if (strEQ(SvPVX_const(cur), max))
1978                     sv_setiv(cur, 0); /* terminate next time */
1979                 else
1980                     sv_inc(cur);
1981                 RETPUSHYES;
1982             }
1983             RETPUSHNO;
1984         }
1985         /* integer increment */
1986         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1987             RETPUSHNO;
1988
1989         /* don't risk potential race */
1990         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1991             /* safe to reuse old SV */
1992             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1993         }
1994         else
1995         {
1996             /* we need a fresh SV every time so that loop body sees a
1997              * completely new SV for closures/references to work as they
1998              * used to */
1999             oldsv = *itersvp;
2000             *itersvp = newSViv(cx->blk_loop.iterix++);
2001             SvREFCNT_dec(oldsv);
2002         }
2003         RETPUSHYES;
2004     }
2005
2006     /* iterate array */
2007     if (PL_op->op_private & OPpITER_REVERSED) {
2008         /* In reverse, use itermax as the min :-)  */
2009         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
2010             RETPUSHNO;
2011
2012         if (SvMAGICAL(av) || AvREIFY(av)) {
2013             SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
2014             sv = svp ? *svp : NULL;
2015         }
2016         else {
2017             sv = AvARRAY(av)[--cx->blk_loop.iterix];
2018         }
2019     }
2020     else {
2021         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
2022                                     AvFILL(av)))
2023             RETPUSHNO;
2024
2025         if (SvMAGICAL(av) || AvREIFY(av)) {
2026             SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
2027             sv = svp ? *svp : NULL;
2028         }
2029         else {
2030             sv = AvARRAY(av)[++cx->blk_loop.iterix];
2031         }
2032     }
2033
2034     if (sv && SvIS_FREED(sv)) {
2035         *itersvp = NULL;
2036         Perl_croak(aTHX_ "Use of freed value in iteration");
2037     }
2038
2039     if (sv)
2040         SvTEMP_off(sv);
2041     else
2042         sv = &PL_sv_undef;
2043     if (av != PL_curstack && sv == &PL_sv_undef) {
2044         SV *lv = cx->blk_loop.iterlval;
2045         if (lv && SvREFCNT(lv) > 1) {
2046             SvREFCNT_dec(lv);
2047             lv = NULL;
2048         }
2049         if (lv)
2050             SvREFCNT_dec(LvTARG(lv));
2051         else {
2052             lv = cx->blk_loop.iterlval = newSV(0);
2053             sv_upgrade(lv, SVt_PVLV);
2054             LvTYPE(lv) = 'y';
2055             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2056         }
2057         LvTARG(lv) = SvREFCNT_inc_simple(av);
2058         LvTARGOFF(lv) = cx->blk_loop.iterix;
2059         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2060         sv = (SV*)lv;
2061     }
2062
2063     oldsv = *itersvp;
2064     *itersvp = SvREFCNT_inc_simple_NN(sv);
2065     SvREFCNT_dec(oldsv);
2066
2067     RETPUSHYES;
2068 }
2069
2070 PP(pp_subst)
2071 {
2072     dVAR; dSP; dTARG;
2073     register PMOP *pm = cPMOP;
2074     PMOP *rpm = pm;
2075     register char *s;
2076     char *strend;
2077     register char *m;
2078     const char *c;
2079     register char *d;
2080     STRLEN clen;
2081     I32 iters = 0;
2082     I32 maxiters;
2083     register I32 i;
2084     bool once;
2085     bool rxtainted;
2086     char *orig;
2087     I32 r_flags;
2088     register REGEXP *rx = PM_GETRE(pm);
2089     STRLEN len;
2090     int force_on_match = 0;
2091     const I32 oldsave = PL_savestack_ix;
2092     STRLEN slen;
2093     bool doutf8 = FALSE;
2094 #ifdef PERL_OLD_COPY_ON_WRITE
2095     bool is_cow;
2096 #endif
2097     SV *nsv = NULL;
2098
2099     /* known replacement string? */
2100     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2101     if (PL_op->op_flags & OPf_STACKED)
2102         TARG = POPs;
2103     else if (PL_op->op_private & OPpTARGET_MY)
2104         GETTARGET;
2105     else {
2106         TARG = DEFSV;
2107         EXTEND(SP,1);
2108     }
2109
2110 #ifdef PERL_OLD_COPY_ON_WRITE
2111     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2112        because they make integers such as 256 "false".  */
2113     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2114 #else
2115     if (SvIsCOW(TARG))
2116         sv_force_normal_flags(TARG,0);
2117 #endif
2118     if (
2119 #ifdef PERL_OLD_COPY_ON_WRITE
2120         !is_cow &&
2121 #endif
2122         (SvREADONLY(TARG)
2123          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2124                || SvTYPE(TARG) > SVt_PVLV)
2125              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2126         DIE(aTHX_ PL_no_modify);
2127     PUTBACK;
2128
2129     s = SvPV_mutable(TARG, len);
2130     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2131         force_on_match = 1;
2132     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2133                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2134     if (PL_tainted)
2135         rxtainted |= 2;
2136     TAINT_NOT;
2137
2138     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2139
2140   force_it:
2141     if (!pm || !s)
2142         DIE(aTHX_ "panic: pp_subst");
2143
2144     strend = s + len;
2145     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2146     maxiters = 2 * slen + 10;   /* We can match twice at each
2147                                    position, once with zero-length,
2148                                    second time with non-zero. */
2149
2150     if (!rx->prelen && PL_curpm) {
2151         pm = PL_curpm;
2152         rx = PM_GETRE(pm);
2153     }
2154     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2155             || (pm->op_pmflags & PMf_EVAL))
2156                ? REXEC_COPY_STR : 0;
2157     if (SvSCREAM(TARG))
2158         r_flags |= REXEC_SCREAM;
2159
2160     orig = m = s;
2161     if (rx->extflags & RXf_USE_INTUIT) {
2162         PL_bostr = orig;
2163         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2164
2165         if (!s)
2166             goto nope;
2167         /* How to do it in subst? */
2168 /*      if ( (rx->extflags & RXf_CHECK_ALL)
2169              && !PL_sawampersand
2170              && ((rx->extflags & RXf_NOSCAN)
2171                  || !((rx->extflags & RXf_INTUIT_TAIL)
2172                       && (r_flags & REXEC_SCREAM))))
2173             goto yup;
2174 */
2175     }
2176
2177     /* only replace once? */
2178     once = !(rpm->op_pmflags & PMf_GLOBAL);
2179
2180     /* known replacement string? */
2181     if (dstr) {
2182         /* replacement needing upgrading? */
2183         if (DO_UTF8(TARG) && !doutf8) {
2184              nsv = sv_newmortal();
2185              SvSetSV(nsv, dstr);
2186              if (PL_encoding)
2187                   sv_recode_to_utf8(nsv, PL_encoding);
2188              else
2189                   sv_utf8_upgrade(nsv);
2190              c = SvPV_const(nsv, clen);
2191              doutf8 = TRUE;
2192         }
2193         else {
2194             c = SvPV_const(dstr, clen);
2195             doutf8 = DO_UTF8(dstr);
2196         }
2197     }
2198     else {
2199         c = NULL;
2200         doutf8 = FALSE;
2201     }
2202
2203     /* can do inplace substitution? */
2204     if (c
2205 #ifdef PERL_OLD_COPY_ON_WRITE
2206         && !is_cow
2207 #endif
2208         && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2209         && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2210         && (!doutf8 || SvUTF8(TARG))) {
2211         if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2212                          r_flags | REXEC_CHECKED))
2213         {
2214             SPAGAIN;
2215             PUSHs(&PL_sv_no);
2216             LEAVE_SCOPE(oldsave);
2217             RETURN;
2218         }
2219 #ifdef PERL_OLD_COPY_ON_WRITE
2220         if (SvIsCOW(TARG)) {
2221             assert (!force_on_match);
2222             goto have_a_cow;
2223         }
2224 #endif
2225         if (force_on_match) {
2226             force_on_match = 0;
2227             s = SvPV_force(TARG, len);
2228             goto force_it;
2229         }
2230         d = s;
2231         PL_curpm = pm;
2232         SvSCREAM_off(TARG);     /* disable possible screamer */
2233         if (once) {
2234             rxtainted |= RX_MATCH_TAINTED(rx);
2235             m = orig + rx->startp[0];
2236             d = orig + rx->endp[0];
2237             s = orig;
2238             if (m - s > strend - d) {  /* faster to shorten from end */
2239                 if (clen) {
2240                     Copy(c, m, clen, char);
2241                     m += clen;
2242                 }
2243                 i = strend - d;
2244                 if (i > 0) {
2245                     Move(d, m, i, char);
2246                     m += i;
2247                 }
2248                 *m = '\0';
2249                 SvCUR_set(TARG, m - s);
2250             }
2251             else if ((i = m - s)) {     /* faster from front */
2252                 d -= clen;
2253                 m = d;
2254                 sv_chop(TARG, d-i);
2255                 s += i;
2256                 while (i--)
2257                     *--d = *--s;
2258                 if (clen)
2259                     Copy(c, m, clen, char);
2260             }
2261             else if (clen) {
2262                 d -= clen;
2263                 sv_chop(TARG, d);
2264                 Copy(c, d, clen, char);
2265             }
2266             else {
2267                 sv_chop(TARG, d);
2268             }
2269             TAINT_IF(rxtainted & 1);
2270             SPAGAIN;
2271             PUSHs(&PL_sv_yes);
2272         }
2273         else {
2274             do {
2275                 if (iters++ > maxiters)
2276                     DIE(aTHX_ "Substitution loop");
2277                 rxtainted |= RX_MATCH_TAINTED(rx);
2278                 m = rx->startp[0] + orig;
2279                 if ((i = m - s)) {
2280                     if (s != d)
2281                         Move(s, d, i, char);
2282                     d += i;
2283                 }
2284                 if (clen) {
2285                     Copy(c, d, clen, char);
2286                     d += clen;
2287                 }
2288                 s = rx->endp[0] + orig;
2289             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2290                                  TARG, NULL,
2291                                  /* don't match same null twice */
2292                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2293             if (s != d) {
2294                 i = strend - s;
2295                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2296                 Move(s, d, i+1, char);          /* include the NUL */
2297             }
2298             TAINT_IF(rxtainted & 1);
2299             SPAGAIN;
2300             PUSHs(sv_2mortal(newSViv((I32)iters)));
2301         }
2302         (void)SvPOK_only_UTF8(TARG);
2303         TAINT_IF(rxtainted);
2304         if (SvSMAGICAL(TARG)) {
2305             PUTBACK;
2306             mg_set(TARG);
2307             SPAGAIN;
2308         }
2309         SvTAINT(TARG);
2310         if (doutf8)
2311             SvUTF8_on(TARG);
2312         LEAVE_SCOPE(oldsave);
2313         RETURN;
2314     }
2315
2316     if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2317                     r_flags | REXEC_CHECKED))
2318     {
2319         if (force_on_match) {
2320             force_on_match = 0;
2321             s = SvPV_force(TARG, len);
2322             goto force_it;
2323         }
2324 #ifdef PERL_OLD_COPY_ON_WRITE
2325       have_a_cow:
2326 #endif
2327         rxtainted |= RX_MATCH_TAINTED(rx);
2328         dstr = newSVpvn(m, s-m);
2329         SAVEFREESV(dstr);
2330         if (DO_UTF8(TARG))
2331             SvUTF8_on(dstr);
2332         PL_curpm = pm;
2333         if (!c) {
2334             register PERL_CONTEXT *cx;
2335             SPAGAIN;
2336             PUSHSUBST(cx);
2337             RETURNOP(cPMOP->op_pmreplroot);
2338         }
2339         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2340         do {
2341             if (iters++ > maxiters)
2342                 DIE(aTHX_ "Substitution loop");
2343             rxtainted |= RX_MATCH_TAINTED(rx);
2344             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2345                 m = s;
2346                 s = orig;
2347                 orig = rx->subbeg;
2348                 s = orig + (m - s);
2349                 strend = s + (strend - m);
2350             }
2351             m = rx->startp[0] + orig;
2352             if (doutf8 && !SvUTF8(dstr))
2353                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2354             else
2355                 sv_catpvn(dstr, s, m-s);
2356             s = rx->endp[0] + orig;
2357             if (clen)
2358                 sv_catpvn(dstr, c, clen);
2359             if (once)
2360                 break;
2361         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2362                              TARG, NULL, r_flags));
2363         if (doutf8 && !DO_UTF8(TARG))
2364             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2365         else
2366             sv_catpvn(dstr, s, strend - s);
2367
2368 #ifdef PERL_OLD_COPY_ON_WRITE
2369         /* The match may make the string COW. If so, brilliant, because that's
2370            just saved us one malloc, copy and free - the regexp has donated
2371            the old buffer, and we malloc an entirely new one, rather than the
2372            regexp malloc()ing a buffer and copying our original, only for
2373            us to throw it away here during the substitution.  */
2374         if (SvIsCOW(TARG)) {
2375             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2376         } else
2377 #endif
2378         {
2379             SvPV_free(TARG);
2380         }
2381         SvPV_set(TARG, SvPVX(dstr));
2382         SvCUR_set(TARG, SvCUR(dstr));
2383         SvLEN_set(TARG, SvLEN(dstr));
2384         doutf8 |= DO_UTF8(dstr);
2385         SvPV_set(dstr, NULL);
2386
2387         TAINT_IF(rxtainted & 1);
2388         SPAGAIN;
2389         PUSHs(sv_2mortal(newSViv((I32)iters)));
2390
2391         (void)SvPOK_only(TARG);
2392         if (doutf8)
2393             SvUTF8_on(TARG);
2394         TAINT_IF(rxtainted);
2395         SvSETMAGIC(TARG);
2396         SvTAINT(TARG);
2397         LEAVE_SCOPE(oldsave);
2398         RETURN;
2399     }
2400     goto ret_no;
2401
2402 nope:
2403 ret_no:
2404     SPAGAIN;
2405     PUSHs(&PL_sv_no);
2406     LEAVE_SCOPE(oldsave);
2407     RETURN;
2408 }
2409
2410 PP(pp_grepwhile)
2411 {
2412     dVAR; dSP;
2413
2414     if (SvTRUEx(POPs))
2415         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2416     ++*PL_markstack_ptr;
2417     LEAVE;                                      /* exit inner scope */
2418
2419     /* All done yet? */
2420     if (PL_stack_base + *PL_markstack_ptr > SP) {
2421         I32 items;
2422         const I32 gimme = GIMME_V;
2423
2424         LEAVE;                                  /* exit outer scope */
2425         (void)POPMARK;                          /* pop src */
2426         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2427         (void)POPMARK;                          /* pop dst */
2428         SP = PL_stack_base + POPMARK;           /* pop original mark */
2429         if (gimme == G_SCALAR) {
2430             if (PL_op->op_private & OPpGREP_LEX) {
2431                 SV* const sv = sv_newmortal();
2432                 sv_setiv(sv, items);
2433                 PUSHs(sv);
2434             }
2435             else {
2436                 dTARGET;
2437                 XPUSHi(items);
2438             }
2439         }
2440         else if (gimme == G_ARRAY)
2441             SP += items;
2442         RETURN;
2443     }
2444     else {
2445         SV *src;
2446
2447         ENTER;                                  /* enter inner scope */
2448         SAVEVPTR(PL_curpm);
2449
2450         src = PL_stack_base[*PL_markstack_ptr];
2451         SvTEMP_off(src);
2452         if (PL_op->op_private & OPpGREP_LEX)
2453             PAD_SVl(PL_op->op_targ) = src;
2454         else
2455             DEFSV = src;
2456
2457         RETURNOP(cLOGOP->op_other);
2458     }
2459 }
2460
2461 PP(pp_leavesub)
2462 {
2463     dVAR; dSP;
2464     SV **mark;
2465     SV **newsp;
2466     PMOP *newpm;
2467     I32 gimme;
2468     register PERL_CONTEXT *cx;
2469     SV *sv;
2470
2471     if (CxMULTICALL(&cxstack[cxstack_ix]))
2472         return 0;
2473
2474     POPBLOCK(cx,newpm);
2475     cxstack_ix++; /* temporarily protect top context */
2476
2477     TAINT_NOT;
2478     if (gimme == G_SCALAR) {
2479         MARK = newsp + 1;
2480         if (MARK <= SP) {
2481             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2482                 if (SvTEMP(TOPs)) {
2483                     *MARK = SvREFCNT_inc(TOPs);
2484                     FREETMPS;
2485                     sv_2mortal(*MARK);
2486                 }
2487                 else {
2488                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2489                     FREETMPS;
2490                     *MARK = sv_mortalcopy(sv);
2491                     SvREFCNT_dec(sv);
2492                 }
2493             }
2494             else
2495                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2496         }
2497         else {
2498             MEXTEND(MARK, 0);
2499             *MARK = &PL_sv_undef;
2500         }
2501         SP = MARK;
2502     }
2503     else if (gimme == G_ARRAY) {
2504         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2505             if (!SvTEMP(*MARK)) {
2506                 *MARK = sv_mortalcopy(*MARK);
2507                 TAINT_NOT;      /* Each item is independent */
2508             }
2509         }
2510     }
2511     PUTBACK;
2512
2513     LEAVE;
2514     cxstack_ix--;
2515     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2516     PL_curpm = newpm;   /* ... and pop $1 et al */
2517
2518     LEAVESUB(sv);
2519     return cx->blk_sub.retop;
2520 }
2521
2522 /* This duplicates the above code because the above code must not
2523  * get any slower by more conditions */
2524 PP(pp_leavesublv)
2525 {
2526     dVAR; dSP;
2527     SV **mark;
2528     SV **newsp;
2529     PMOP *newpm;
2530     I32 gimme;
2531     register PERL_CONTEXT *cx;
2532     SV *sv;
2533
2534     if (CxMULTICALL(&cxstack[cxstack_ix]))
2535         return 0;
2536
2537     POPBLOCK(cx,newpm);
2538     cxstack_ix++; /* temporarily protect top context */
2539
2540     TAINT_NOT;
2541
2542     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2543         /* We are an argument to a function or grep().
2544          * This kind of lvalueness was legal before lvalue
2545          * subroutines too, so be backward compatible:
2546          * cannot report errors.  */
2547
2548         /* Scalar context *is* possible, on the LHS of -> only,
2549          * as in f()->meth().  But this is not an lvalue. */
2550         if (gimme == G_SCALAR)
2551             goto temporise;
2552         if (gimme == G_ARRAY) {
2553             if (!CvLVALUE(cx->blk_sub.cv))
2554                 goto temporise_array;
2555             EXTEND_MORTAL(SP - newsp);
2556             for (mark = newsp + 1; mark <= SP; mark++) {
2557                 if (SvTEMP(*mark))
2558                     NOOP;
2559                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2560                     *mark = sv_mortalcopy(*mark);
2561                 else {
2562                     /* Can be a localized value subject to deletion. */
2563                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2564                     SvREFCNT_inc_void(*mark);
2565                 }
2566             }
2567         }
2568     }
2569     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2570         /* Here we go for robustness, not for speed, so we change all
2571          * the refcounts so the caller gets a live guy. Cannot set
2572          * TEMP, so sv_2mortal is out of question. */
2573         if (!CvLVALUE(cx->blk_sub.cv)) {
2574             LEAVE;
2575             cxstack_ix--;
2576             POPSUB(cx,sv);
2577             PL_curpm = newpm;
2578             LEAVESUB(sv);
2579             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2580         }
2581         if (gimme == G_SCALAR) {
2582             MARK = newsp + 1;
2583             EXTEND_MORTAL(1);
2584             if (MARK == SP) {
2585                 /* Temporaries are bad unless they happen to be elements
2586                  * of a tied hash or array */
2587                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2588                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2589                     LEAVE;
2590                     cxstack_ix--;
2591                     POPSUB(cx,sv);
2592                     PL_curpm = newpm;
2593                     LEAVESUB(sv);
2594                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2595                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2596                         : "a readonly value" : "a temporary");
2597                 }
2598                 else {                  /* Can be a localized value
2599                                          * subject to deletion. */
2600                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2601                     SvREFCNT_inc_void(*mark);
2602                 }
2603             }
2604             else {                      /* Should not happen? */
2605                 LEAVE;
2606                 cxstack_ix--;
2607                 POPSUB(cx,sv);
2608                 PL_curpm = newpm;
2609                 LEAVESUB(sv);
2610                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2611                     (MARK > SP ? "Empty array" : "Array"));
2612             }
2613             SP = MARK;
2614         }
2615         else if (gimme == G_ARRAY) {
2616             EXTEND_MORTAL(SP - newsp);
2617             for (mark = newsp + 1; mark <= SP; mark++) {
2618                 if (*mark != &PL_sv_undef
2619                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2620                     /* Might be flattened array after $#array =  */
2621                     PUTBACK;
2622                     LEAVE;
2623                     cxstack_ix--;
2624                     POPSUB(cx,sv);
2625                     PL_curpm = newpm;
2626                     LEAVESUB(sv);
2627                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2628                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2629                 }
2630                 else {
2631                     /* Can be a localized value subject to deletion. */
2632                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2633                     SvREFCNT_inc_void(*mark);
2634                 }
2635             }
2636         }
2637     }
2638     else {
2639         if (gimme == G_SCALAR) {
2640           temporise:
2641             MARK = newsp + 1;
2642             if (MARK <= SP) {
2643                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2644                     if (SvTEMP(TOPs)) {
2645                         *MARK = SvREFCNT_inc(TOPs);
2646                         FREETMPS;
2647                         sv_2mortal(*MARK);
2648                     }
2649                     else {
2650                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2651                         FREETMPS;
2652                         *MARK = sv_mortalcopy(sv);
2653                         SvREFCNT_dec(sv);
2654                     }
2655                 }
2656                 else
2657                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2658             }
2659             else {
2660                 MEXTEND(MARK, 0);
2661                 *MARK = &PL_sv_undef;
2662             }
2663             SP = MARK;
2664         }
2665         else if (gimme == G_ARRAY) {
2666           temporise_array:
2667             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2668                 if (!SvTEMP(*MARK)) {
2669                     *MARK = sv_mortalcopy(*MARK);
2670                     TAINT_NOT;  /* Each item is independent */
2671                 }
2672             }
2673         }
2674     }
2675     PUTBACK;
2676
2677     LEAVE;
2678     cxstack_ix--;
2679     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2680     PL_curpm = newpm;   /* ... and pop $1 et al */
2681
2682     LEAVESUB(sv);
2683     return cx->blk_sub.retop;
2684 }
2685
2686 PP(pp_entersub)
2687 {
2688     dVAR; dSP; dPOPss;
2689     GV *gv;
2690     register CV *cv;
2691     register PERL_CONTEXT *cx;
2692     I32 gimme;
2693     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2694
2695     if (!sv)
2696         DIE(aTHX_ "Not a CODE reference");
2697     switch (SvTYPE(sv)) {
2698         /* This is overwhelming the most common case:  */
2699     case SVt_PVGV:
2700         if (!(cv = GvCVu((GV*)sv))) {
2701             HV *stash;
2702             cv = sv_2cv(sv, &stash, &gv, 0);
2703         }
2704         if (!cv) {
2705             ENTER;
2706             SAVETMPS;
2707             goto try_autoload;
2708         }
2709         break;
2710     default:
2711         if (!SvROK(sv)) {
2712             const char *sym;
2713             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2714                 if (hasargs)
2715                     SP = PL_stack_base + POPMARK;
2716                 RETURN;
2717             }
2718             if (SvGMAGICAL(sv)) {
2719                 mg_get(sv);
2720                 if (SvROK(sv))
2721                     goto got_rv;
2722                 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2723             }
2724             else {
2725                 sym = SvPV_nolen_const(sv);
2726             }
2727             if (!sym)
2728                 DIE(aTHX_ PL_no_usym, "a subroutine");
2729             if (PL_op->op_private & HINT_STRICT_REFS)
2730                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2731             cv = get_cv(sym, TRUE);
2732             break;
2733         }
2734   got_rv:
2735         {
2736             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2737             tryAMAGICunDEREF(to_cv);
2738         }
2739         cv = (CV*)SvRV(sv);
2740         if (SvTYPE(cv) == SVt_PVCV)
2741             break;
2742         /* FALL THROUGH */
2743     case SVt_PVHV:
2744     case SVt_PVAV:
2745         DIE(aTHX_ "Not a CODE reference");
2746         /* This is the second most common case:  */
2747     case SVt_PVCV:
2748         cv = (CV*)sv;
2749         break;
2750     }
2751
2752     ENTER;
2753     SAVETMPS;
2754
2755   retry:
2756     if (!CvROOT(cv) && !CvXSUB(cv)) {
2757         GV* autogv;
2758         SV* sub_name;
2759
2760         /* anonymous or undef'd function leaves us no recourse */
2761         if (CvANON(cv) || !(gv = CvGV(cv)))
2762             DIE(aTHX_ "Undefined subroutine called");
2763
2764         /* autoloaded stub? */
2765         if (cv != GvCV(gv)) {
2766             cv = GvCV(gv);
2767         }
2768         /* should call AUTOLOAD now? */
2769         else {
2770 try_autoload:
2771             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2772                                    FALSE)))
2773             {
2774                 cv = GvCV(autogv);
2775             }
2776             /* sorry */
2777             else {
2778                 sub_name = sv_newmortal();
2779                 gv_efullname3(sub_name, gv, NULL);
2780                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2781             }
2782         }
2783         if (!cv)
2784             DIE(aTHX_ "Not a CODE reference");
2785         goto retry;
2786     }
2787
2788     gimme = GIMME_V;
2789     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2790         if (CvASSERTION(cv) && PL_DBassertion)
2791             sv_setiv(PL_DBassertion, 1);
2792
2793          Perl_get_db_sub(aTHX_ &sv, cv);
2794          if (CvISXSUB(cv))
2795              PL_curcopdb = PL_curcop;
2796          cv = GvCV(PL_DBsub);
2797
2798         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2799             DIE(aTHX_ "No DB::sub routine defined");
2800     }
2801
2802     if (!(CvISXSUB(cv))) {
2803         /* This path taken at least 75% of the time   */
2804         dMARK;
2805         register I32 items = SP - MARK;
2806         AV* const padlist = CvPADLIST(cv);
2807         PUSHBLOCK(cx, CXt_SUB, MARK);
2808         PUSHSUB(cx);
2809         cx->blk_sub.retop = PL_op->op_next;
2810         CvDEPTH(cv)++;
2811         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2812          * that eval'' ops within this sub know the correct lexical space.
2813          * Owing the speed considerations, we choose instead to search for
2814          * the cv using find_runcv() when calling doeval().
2815          */
2816         if (CvDEPTH(cv) >= 2) {
2817             PERL_STACK_OVERFLOW_CHECK();
2818             pad_push(padlist, CvDEPTH(cv));
2819         }
2820         SAVECOMPPAD();
2821         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2822         if (hasargs) {
2823             AV* const av = (AV*)PAD_SVl(0);
2824             if (AvREAL(av)) {
2825                 /* @_ is normally not REAL--this should only ever
2826                  * happen when DB::sub() calls things that modify @_ */
2827                 av_clear(av);
2828                 AvREAL_off(av);
2829                 AvREIFY_on(av);
2830             }
2831             cx->blk_sub.savearray = GvAV(PL_defgv);
2832             GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2833             CX_CURPAD_SAVE(cx->blk_sub);
2834             cx->blk_sub.argarray = av;
2835             ++MARK;
2836
2837             if (items > AvMAX(av) + 1) {
2838                 SV **ary = AvALLOC(av);
2839                 if (AvARRAY(av) != ary) {
2840                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2841                     AvARRAY(av) = ary;
2842                 }
2843                 if (items > AvMAX(av) + 1) {
2844                     AvMAX(av) = items - 1;
2845                     Renew(ary,items,SV*);
2846                     AvALLOC(av) = ary;
2847                     AvARRAY(av) = ary;
2848                 }
2849             }
2850             Copy(MARK,AvARRAY(av),items,SV*);
2851             AvFILLp(av) = items - 1;
2852
2853             while (items--) {
2854                 if (*MARK)
2855                     SvTEMP_off(*MARK);
2856                 MARK++;
2857             }
2858         }
2859         /* warning must come *after* we fully set up the context
2860          * stuff so that __WARN__ handlers can safely dounwind()
2861          * if they want to
2862          */
2863         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2864             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2865             sub_crush_depth(cv);
2866 #if 0
2867         DEBUG_S(PerlIO_printf(Perl_debug_log,
2868                               "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2869 #endif
2870         RETURNOP(CvSTART(cv));
2871     }
2872     else {
2873         I32 markix = TOPMARK;
2874
2875         PUTBACK;
2876
2877         if (!hasargs) {
2878             /* Need to copy @_ to stack. Alternative may be to
2879              * switch stack to @_, and copy return values
2880              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2881             AV * const av = GvAV(PL_defgv);
2882             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2883
2884             if (items) {
2885                 /* Mark is at the end of the stack. */
2886                 EXTEND(SP, items);
2887                 Copy(AvARRAY(av), SP + 1, items, SV*);
2888                 SP += items;
2889                 PUTBACK ;
2890             }
2891         }
2892         /* We assume first XSUB in &DB::sub is the called one. */
2893         if (PL_curcopdb) {
2894             SAVEVPTR(PL_curcop);
2895             PL_curcop = PL_curcopdb;
2896             PL_curcopdb = NULL;
2897         }
2898         /* Do we need to open block here? XXXX */
2899         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2900             (void)(*CvXSUB(cv))(aTHX_ cv);
2901
2902         /* Enforce some sanity in scalar context. */
2903         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2904             if (markix > PL_stack_sp - PL_stack_base)
2905                 *(PL_stack_base + markix) = &PL_sv_undef;
2906             else
2907                 *(PL_stack_base + markix) = *PL_stack_sp;
2908             PL_stack_sp = PL_stack_base + markix;
2909         }
2910         LEAVE;
2911         return NORMAL;
2912     }
2913 }
2914
2915 void
2916 Perl_sub_crush_depth(pTHX_ CV *cv)
2917 {
2918     if (CvANON(cv))
2919         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2920     else {
2921         SV* const tmpstr = sv_newmortal();
2922         gv_efullname3(tmpstr, CvGV(cv), NULL);
2923         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2924                     SVfARG(tmpstr));
2925     }
2926 }
2927
2928 PP(pp_aelem)
2929 {
2930     dVAR; dSP;
2931     SV** svp;
2932     SV* const elemsv = POPs;
2933     IV elem = SvIV(elemsv);
2934     AV* const av = (AV*)POPs;
2935     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2936     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2937     SV *sv;
2938
2939     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2940         Perl_warner(aTHX_ packWARN(WARN_MISC),
2941                     "Use of reference \"%"SVf"\" as array index",
2942                     SVfARG(elemsv));
2943     if (elem > 0)
2944         elem -= CopARYBASE_get(PL_curcop);
2945     if (SvTYPE(av) != SVt_PVAV)
2946         RETPUSHUNDEF;
2947     svp = av_fetch(av, elem, lval && !defer);
2948     if (lval) {
2949 #ifdef PERL_MALLOC_WRAP
2950          if (SvUOK(elemsv)) {
2951               const UV uv = SvUV(elemsv);
2952               elem = uv > IV_MAX ? IV_MAX : uv;
2953          }
2954          else if (SvNOK(elemsv))
2955               elem = (IV)SvNV(elemsv);
2956          if (elem > 0) {
2957               static const char oom_array_extend[] =
2958                 "Out of memory during array extend"; /* Duplicated in av.c */
2959               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2960          }
2961 #endif
2962         if (!svp || *svp == &PL_sv_undef) {
2963             SV* lv;
2964             if (!defer)
2965                 DIE(aTHX_ PL_no_aelem, elem);
2966             lv = sv_newmortal();
2967             sv_upgrade(lv, SVt_PVLV);
2968             LvTYPE(lv) = 'y';
2969             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2970             LvTARG(lv) = SvREFCNT_inc_simple(av);
2971             LvTARGOFF(lv) = elem;
2972             LvTARGLEN(lv) = 1;
2973             PUSHs(lv);
2974             RETURN;
2975         }
2976         if (PL_op->op_private & OPpLVAL_INTRO)
2977             save_aelem(av, elem, svp);
2978         else if (PL_op->op_private & OPpDEREF)
2979             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2980     }
2981     sv = (svp ? *svp : &PL_sv_undef);
2982     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2983         sv = sv_mortalcopy(sv);
2984     PUSHs(sv);
2985     RETURN;
2986 }
2987
2988 void
2989 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2990 {
2991     SvGETMAGIC(sv);
2992     if (!SvOK(sv)) {
2993         if (SvREADONLY(sv))
2994             Perl_croak(aTHX_ PL_no_modify);
2995         if (SvTYPE(sv) < SVt_RV)
2996             sv_upgrade(sv, SVt_RV);
2997         else if (SvTYPE(sv) >= SVt_PV) {
2998             SvPV_free(sv);
2999             SvLEN_set(sv, 0);
3000             SvCUR_set(sv, 0);
3001         }
3002         switch (to_what) {
3003         case OPpDEREF_SV:
3004             SvRV_set(sv, newSV(0));
3005             break;
3006         case OPpDEREF_AV:
3007             SvRV_set(sv, (SV*)newAV());
3008             break;
3009         case OPpDEREF_HV:
3010             SvRV_set(sv, (SV*)newHV());
3011             break;
3012         }
3013         SvROK_on(sv);
3014         SvSETMAGIC(sv);
3015     }
3016 }
3017
3018 PP(pp_method)
3019 {
3020     dVAR; dSP;
3021     SV* const sv = TOPs;
3022
3023     if (SvROK(sv)) {
3024         SV* const rsv = SvRV(sv);
3025         if (SvTYPE(rsv) == SVt_PVCV) {
3026             SETs(rsv);
3027             RETURN;
3028         }
3029     }
3030
3031     SETs(method_common(sv, NULL));
3032     RETURN;
3033 }
3034
3035 PP(pp_method_named)
3036 {
3037     dVAR; dSP;
3038     SV* const sv = cSVOP_sv;
3039     U32 hash = SvSHARED_HASH(sv);
3040
3041     XPUSHs(method_common(sv, &hash));
3042     RETURN;
3043 }
3044
3045 STATIC SV *
3046 S_method_common(pTHX_ SV* meth, U32* hashp)
3047 {
3048     dVAR;
3049     SV* ob;
3050     GV* gv;
3051     HV* stash;
3052     STRLEN namelen;
3053     const char* packname = NULL;
3054     SV *packsv = NULL;
3055     STRLEN packlen;
3056     const char * const name = SvPV_const(meth, namelen);
3057     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3058
3059     if (!sv)
3060         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3061
3062     SvGETMAGIC(sv);
3063     if (SvROK(sv))
3064         ob = (SV*)SvRV(sv);
3065     else {
3066         GV* iogv;
3067
3068         /* this isn't a reference */
3069         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3070           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3071           if (he) {
3072             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3073             goto fetch;
3074           }
3075         }
3076
3077         if (!SvOK(sv) ||
3078             !(packname) ||
3079             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3080             !(ob=(SV*)GvIO(iogv)))
3081         {
3082             /* this isn't the name of a filehandle either */
3083             if (!packname ||
3084                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3085                     ? !isIDFIRST_utf8((U8*)packname)
3086                     : !isIDFIRST(*packname)
3087                 ))
3088             {
3089                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3090                            SvOK(sv) ? "without a package or object reference"
3091                                     : "on an undefined value");
3092             }
3093             /* assume it's a package name */
3094             stash = gv_stashpvn(packname, packlen, FALSE);
3095             if (!stash)
3096                 packsv = sv;
3097             else {
3098                 SV* const ref = newSViv(PTR2IV(stash));
3099                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3100             }
3101             goto fetch;
3102         }
3103         /* it _is_ a filehandle name -- replace with a reference */
3104         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3105     }
3106
3107     /* if we got here, ob should be a reference or a glob */
3108     if (!ob || !(SvOBJECT(ob)
3109                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3110                      && SvOBJECT(ob))))
3111     {
3112         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3113                    name);
3114     }
3115
3116     stash = SvSTASH(ob);
3117
3118   fetch:
3119     /* NOTE: stash may be null, hope hv_fetch_ent and
3120        gv_fetchmethod can cope (it seems they can) */
3121
3122     /* shortcut for simple names */
3123     if (hashp) {
3124         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3125         if (he) {
3126             gv = (GV*)HeVAL(he);
3127             if (isGV(gv) && GvCV(gv) &&
3128                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3129                 return (SV*)GvCV(gv);
3130         }
3131     }
3132
3133     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3134
3135     if (!gv) {
3136         /* This code tries to figure out just what went wrong with
3137            gv_fetchmethod.  It therefore needs to duplicate a lot of
3138            the internals of that function.  We can't move it inside
3139            Perl_gv_fetchmethod_autoload(), however, since that would
3140            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3141            don't want that.
3142         */
3143         const char* leaf = name;
3144         const char* sep = NULL;
3145         const char* p;
3146
3147         for (p = name; *p; p++) {
3148             if (*p == '\'')
3149                 sep = p, leaf = p + 1;
3150             else if (*p == ':' && *(p + 1) == ':')
3151                 sep = p, leaf = p + 2;
3152         }
3153         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3154             /* the method name is unqualified or starts with SUPER:: */
3155             bool need_strlen = 1;
3156             if (sep) {
3157                 packname = CopSTASHPV(PL_curcop);
3158             }
3159             else if (stash) {
3160                 HEK * const packhek = HvNAME_HEK(stash);
3161                 if (packhek) {
3162                     packname = HEK_KEY(packhek);
3163                     packlen = HEK_LEN(packhek);
3164                     need_strlen = 0;
3165                 } else {
3166                     goto croak;
3167                 }
3168             }
3169
3170             if (!packname) {
3171             croak:
3172                 Perl_croak(aTHX_
3173                            "Can't use anonymous symbol table for method lookup");
3174             }
3175             else if (need_strlen)
3176                 packlen = strlen(packname);
3177
3178         }
3179         else {
3180             /* the method name is qualified */
3181             packname = name;
3182             packlen = sep - name;
3183         }
3184
3185         /* we're relying on gv_fetchmethod not autovivifying the stash */
3186         if (gv_stashpvn(packname, packlen, FALSE)) {
3187             Perl_croak(aTHX_
3188                        "Can't locate object method \"%s\" via package \"%.*s\"",
3189                        leaf, (int)packlen, packname);
3190         }
3191         else {
3192             Perl_croak(aTHX_
3193                        "Can't locate object method \"%s\" via package \"%.*s\""
3194                        " (perhaps you forgot to load \"%.*s\"?)",
3195                        leaf, (int)packlen, packname, (int)packlen, packname);
3196         }
3197     }
3198     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3199 }
3200
3201 /*
3202  * Local variables:
3203  * c-indentation-style: bsd
3204  * c-basic-offset: 4
3205  * indent-tabs-mode: t
3206  * End:
3207  *
3208  * ex: set ts=8 sts=4 sw=4 noet:
3209  */