pp_hot.c

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