pp_hot.c

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