pp_hot.c

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