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 bool 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     if (PL_op->op_private & OPpASSIGN_STATE) {
1084         if (SvPADSTALE(*firstlelem))
1085             SvPADSTALE_off(*firstlelem);
1086         else
1087             RETURN; /* ignore assignment */
1088     }
1089
1090     relem = firstrelem;
1091     lelem = firstlelem;
1092     ary = NULL;
1093     hash = NULL;
1094
1095     while (lelem <= lastlelem) {
1096         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1097         sv = *lelem++;
1098         switch (SvTYPE(sv)) {
1099         case SVt_PVAV:
1100             ary = (AV*)sv;
1101             magic = SvMAGICAL(ary) != 0;
1102             av_clear(ary);
1103             av_extend(ary, lastrelem - relem);
1104             i = 0;
1105             while (relem <= lastrelem) {        /* gobble up all the rest */
1106                 SV **didstore;
1107                 assert(*relem);
1108                 sv = newSVsv(*relem);
1109                 *(relem++) = sv;
1110                 didstore = av_store(ary,i++,sv);
1111                 if (magic) {
1112                     if (SvSMAGICAL(sv))
1113                         mg_set(sv);
1114                     if (!didstore)
1115                         sv_2mortal(sv);
1116                 }
1117                 TAINT_NOT;
1118             }
1119             break;
1120         case SVt_PVHV: {                                /* normal hash */
1121                 SV *tmpstr;
1122
1123                 hash = (HV*)sv;
1124                 magic = SvMAGICAL(hash) != 0;
1125                 hv_clear(hash);
1126                 firsthashrelem = relem;
1127
1128                 while (relem < lastrelem) {     /* gobble up all the rest */
1129                     HE *didstore;
1130                     sv = *relem ? *relem : &PL_sv_no;
1131                     relem++;
1132                     tmpstr = newSV(0);
1133                     if (*relem)
1134                         sv_setsv(tmpstr,*relem);        /* value */
1135                     *(relem++) = tmpstr;
1136                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1137                         /* key overwrites an existing entry */
1138                         duplicates += 2;
1139                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1140                     if (magic) {
1141                         if (SvSMAGICAL(tmpstr))
1142                             mg_set(tmpstr);
1143                         if (!didstore)
1144                             sv_2mortal(tmpstr);
1145                     }
1146                     TAINT_NOT;
1147                 }
1148                 if (relem == lastrelem) {
1149                     do_oddball(hash, relem, firstrelem);
1150                     relem++;
1151                 }
1152             }
1153             break;
1154         default:
1155             if (SvIMMORTAL(sv)) {
1156                 if (relem <= lastrelem)
1157                     relem++;
1158                 break;
1159             }
1160             if (relem <= lastrelem) {
1161                 sv_setsv(sv, *relem);
1162                 *(relem++) = sv;
1163             }
1164             else
1165                 sv_setsv(sv, &PL_sv_undef);
1166             SvSETMAGIC(sv);
1167             break;
1168         }
1169     }
1170     if (PL_delaymagic & ~DM_DELAY) {
1171         if (PL_delaymagic & DM_UID) {
1172 #ifdef HAS_SETRESUID
1173             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1174                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1175                             (Uid_t)-1);
1176 #else
1177 #  ifdef HAS_SETREUID
1178             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1179                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1180 #  else
1181 #    ifdef HAS_SETRUID
1182             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1183                 (void)setruid(PL_uid);
1184                 PL_delaymagic &= ~DM_RUID;
1185             }
1186 #    endif /* HAS_SETRUID */
1187 #    ifdef HAS_SETEUID
1188             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1189                 (void)seteuid(PL_euid);
1190                 PL_delaymagic &= ~DM_EUID;
1191             }
1192 #    endif /* HAS_SETEUID */
1193             if (PL_delaymagic & DM_UID) {
1194                 if (PL_uid != PL_euid)
1195                     DIE(aTHX_ "No setreuid available");
1196                 (void)PerlProc_setuid(PL_uid);
1197             }
1198 #  endif /* HAS_SETREUID */
1199 #endif /* HAS_SETRESUID */
1200             PL_uid = PerlProc_getuid();
1201             PL_euid = PerlProc_geteuid();
1202         }
1203         if (PL_delaymagic & DM_GID) {
1204 #ifdef HAS_SETRESGID
1205             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1206                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1207                             (Gid_t)-1);
1208 #else
1209 #  ifdef HAS_SETREGID
1210             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1211                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1212 #  else
1213 #    ifdef HAS_SETRGID
1214             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1215                 (void)setrgid(PL_gid);
1216                 PL_delaymagic &= ~DM_RGID;
1217             }
1218 #    endif /* HAS_SETRGID */
1219 #    ifdef HAS_SETEGID
1220             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1221                 (void)setegid(PL_egid);
1222                 PL_delaymagic &= ~DM_EGID;
1223             }
1224 #    endif /* HAS_SETEGID */
1225             if (PL_delaymagic & DM_GID) {
1226                 if (PL_gid != PL_egid)
1227                     DIE(aTHX_ "No setregid available");
1228                 (void)PerlProc_setgid(PL_gid);
1229             }
1230 #  endif /* HAS_SETREGID */
1231 #endif /* HAS_SETRESGID */
1232             PL_gid = PerlProc_getgid();
1233             PL_egid = PerlProc_getegid();
1234         }
1235         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1236     }
1237     PL_delaymagic = 0;
1238
1239     if (gimme == G_VOID)
1240         SP = firstrelem - 1;
1241     else if (gimme == G_SCALAR) {
1242         dTARGET;
1243         SP = firstrelem;
1244         SETi(lastrelem - firstrelem + 1 - duplicates);
1245     }
1246     else {
1247         if (ary)
1248             SP = lastrelem;
1249         else if (hash) {
1250             if (duplicates) {
1251                 /* Removes from the stack the entries which ended up as
1252                  * duplicated keys in the hash (fix for [perl #24380]) */
1253                 Move(firsthashrelem + duplicates,
1254                         firsthashrelem, duplicates, SV**);
1255                 lastrelem -= duplicates;
1256             }
1257             SP = lastrelem;
1258         }
1259         else
1260             SP = firstrelem + (lastlelem - firstlelem);
1261         lelem = firstlelem + (relem - firstrelem);
1262         while (relem <= SP)
1263             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1264     }
1265     RETURN;
1266 }
1267
1268 PP(pp_qr)
1269 {
1270     dVAR; dSP;
1271     register PMOP * const pm = cPMOP;
1272     SV * const rv = sv_newmortal();
1273     SV * const sv = newSVrv(rv, "Regexp");
1274     if (pm->op_pmdynflags & PMdf_TAINTED)
1275         SvTAINTED_on(rv);
1276     sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1277     RETURNX(PUSHs(rv));
1278 }
1279
1280 PP(pp_match)
1281 {
1282     dVAR; dSP; dTARG;
1283     register PMOP *pm = cPMOP;
1284     PMOP *dynpm = pm;
1285     register const char *t;
1286     register const char *s;
1287     const char *strend;
1288     I32 global;
1289     I32 r_flags = REXEC_CHECKED;
1290     const char *truebase;                       /* Start of string  */
1291     register REGEXP *rx = PM_GETRE(pm);
1292     bool rxtainted;
1293     const I32 gimme = GIMME;
1294     STRLEN len;
1295     I32 minmatch = 0;
1296     const I32 oldsave = PL_savestack_ix;
1297     I32 update_minmatch = 1;
1298     I32 had_zerolen = 0;
1299
1300     if (PL_op->op_flags & OPf_STACKED)
1301         TARG = POPs;
1302     else if (PL_op->op_private & OPpTARGET_MY)
1303         GETTARGET;
1304     else {
1305         TARG = DEFSV;
1306         EXTEND(SP,1);
1307     }
1308
1309     PUTBACK;                            /* EVAL blocks need stack_sp. */
1310     s = SvPV_const(TARG, len);
1311     if (!s)
1312         DIE(aTHX_ "panic: pp_match");
1313     strend = s + len;
1314     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1315                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1316     TAINT_NOT;
1317
1318     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1319
1320     /* PMdf_USED is set after a ?? matches once */
1321     if (pm->op_pmdynflags & PMdf_USED) {
1322       failure:
1323         if (gimme == G_ARRAY)
1324             RETURN;
1325         RETPUSHNO;
1326     }
1327
1328     /* empty pattern special-cased to use last successful pattern if possible */
1329     if (!rx->prelen && PL_curpm) {
1330         pm = PL_curpm;
1331         rx = PM_GETRE(pm);
1332     }
1333
1334     if (rx->minlen > (I32)len)
1335         goto failure;
1336
1337     truebase = t = s;
1338
1339     /* XXXX What part of this is needed with true \G-support? */
1340     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1341         rx->startp[0] = -1;
1342         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1343             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1344             if (mg && mg->mg_len >= 0) {
1345                 if (!(rx->reganch & ROPT_GPOS_SEEN))
1346                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1347                 else if (rx->reganch & ROPT_ANCH_GPOS) {
1348                     r_flags |= REXEC_IGNOREPOS;
1349                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1350                 }
1351                 minmatch = (mg->mg_flags & MGf_MINMATCH);
1352                 update_minmatch = 0;
1353             }
1354         }
1355     }
1356     if ((!global && rx->nparens)
1357             || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
1358         r_flags |= REXEC_COPY_STR;
1359     if (SvSCREAM(TARG))
1360         r_flags |= REXEC_SCREAM;
1361
1362 play_it_again:
1363     if (global && rx->startp[0] != -1) {
1364         t = s = rx->endp[0] + truebase;
1365         if ((s + rx->minlen) > strend)
1366             goto nope;
1367         if (update_minmatch++)
1368             minmatch = had_zerolen;
1369     }
1370     if (rx->reganch & RE_USE_INTUIT &&
1371         DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1372         /* FIXME - can PL_bostr be made const char *?  */
1373         PL_bostr = (char *)truebase;
1374         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1375
1376         if (!s)
1377             goto nope;
1378         if ( (rx->reganch & ROPT_CHECK_ALL)
1379              && !PL_sawampersand
1380              && ((rx->reganch & ROPT_NOSCAN)
1381                  || !((rx->reganch & RE_INTUIT_TAIL)
1382                       && (r_flags & REXEC_SCREAM)))
1383              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1384             goto yup;
1385     }
1386     if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1387     {
1388         PL_curpm = pm;
1389         if (dynpm->op_pmflags & PMf_ONCE)
1390             dynpm->op_pmdynflags |= PMdf_USED;
1391         goto gotcha;
1392     }
1393     else
1394         goto ret_no;
1395     /*NOTREACHED*/
1396
1397   gotcha:
1398     if (rxtainted)
1399         RX_MATCH_TAINTED_on(rx);
1400     TAINT_IF(RX_MATCH_TAINTED(rx));
1401     if (gimme == G_ARRAY) {
1402         const I32 nparens = rx->nparens;
1403         I32 i = (global && !nparens) ? 1 : 0;
1404
1405         SPAGAIN;                        /* EVAL blocks could move the stack. */
1406         EXTEND(SP, nparens + i);
1407         EXTEND_MORTAL(nparens + i);
1408         for (i = !i; i <= nparens; i++) {
1409             PUSHs(sv_newmortal());
1410             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1411                 const I32 len = rx->endp[i] - rx->startp[i];
1412                 s = rx->startp[i] + truebase;
1413                 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1414                     len < 0 || len > strend - s)
1415                     DIE(aTHX_ "panic: pp_match start/end pointers");
1416                 sv_setpvn(*SP, s, len);
1417                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1418                     SvUTF8_on(*SP);
1419             }
1420         }
1421         if (global) {
1422             if (dynpm->op_pmflags & PMf_CONTINUE) {
1423                 MAGIC* mg = NULL;
1424                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1425                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1426                 if (!mg) {
1427 #ifdef PERL_OLD_COPY_ON_WRITE
1428                     if (SvIsCOW(TARG))
1429                         sv_force_normal_flags(TARG, 0);
1430 #endif
1431                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1432                                      &PL_vtbl_mglob, NULL, 0);
1433                 }
1434                 if (rx->startp[0] != -1) {
1435                     mg->mg_len = rx->endp[0];
1436                     if (rx->startp[0] == rx->endp[0])
1437                         mg->mg_flags |= MGf_MINMATCH;
1438                     else
1439                         mg->mg_flags &= ~MGf_MINMATCH;
1440                 }
1441             }
1442             had_zerolen = (rx->startp[0] != -1
1443                            && rx->startp[0] == rx->endp[0]);
1444             PUTBACK;                    /* EVAL blocks may use stack */
1445             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1446             goto play_it_again;
1447         }
1448         else if (!nparens)
1449             XPUSHs(&PL_sv_yes);
1450         LEAVE_SCOPE(oldsave);
1451         RETURN;
1452     }
1453     else {
1454         if (global) {
1455             MAGIC* mg;
1456             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1457                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1458             else
1459                 mg = NULL;
1460             if (!mg) {
1461 #ifdef PERL_OLD_COPY_ON_WRITE
1462                 if (SvIsCOW(TARG))
1463                     sv_force_normal_flags(TARG, 0);
1464 #endif
1465                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1466                                  &PL_vtbl_mglob, NULL, 0);
1467             }
1468             if (rx->startp[0] != -1) {
1469                 mg->mg_len = rx->endp[0];
1470                 if (rx->startp[0] == rx->endp[0])
1471                     mg->mg_flags |= MGf_MINMATCH;
1472                 else
1473                     mg->mg_flags &= ~MGf_MINMATCH;
1474             }
1475         }
1476         LEAVE_SCOPE(oldsave);
1477         RETPUSHYES;
1478     }
1479
1480 yup:                                    /* Confirmed by INTUIT */
1481     if (rxtainted)
1482         RX_MATCH_TAINTED_on(rx);
1483     TAINT_IF(RX_MATCH_TAINTED(rx));
1484     PL_curpm = pm;
1485     if (dynpm->op_pmflags & PMf_ONCE)
1486         dynpm->op_pmdynflags |= PMdf_USED;
1487     if (RX_MATCH_COPIED(rx))
1488         Safefree(rx->subbeg);
1489     RX_MATCH_COPIED_off(rx);
1490     rx->subbeg = NULL;
1491     if (global) {
1492         /* FIXME - should rx->subbeg be const char *?  */
1493         rx->subbeg = (char *) truebase;
1494         rx->startp[0] = s - truebase;
1495         if (RX_MATCH_UTF8(rx)) {
1496             char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1497             rx->endp[0] = t - truebase;
1498         }
1499         else {
1500             rx->endp[0] = s - truebase + rx->minlen;
1501         }
1502         rx->sublen = strend - truebase;
1503         goto gotcha;
1504     }
1505     if (PL_sawampersand) {
1506         I32 off;
1507 #ifdef PERL_OLD_COPY_ON_WRITE
1508         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1509             if (DEBUG_C_TEST) {
1510                 PerlIO_printf(Perl_debug_log,
1511                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1512                               (int) SvTYPE(TARG), truebase, t,
1513                               (int)(t-truebase));
1514             }
1515             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1516             rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1517             assert (SvPOKp(rx->saved_copy));
1518         } else
1519 #endif
1520         {
1521
1522             rx->subbeg = savepvn(t, strend - t);
1523 #ifdef PERL_OLD_COPY_ON_WRITE
1524             rx->saved_copy = NULL;
1525 #endif
1526         }
1527         rx->sublen = strend - t;
1528         RX_MATCH_COPIED_on(rx);
1529         off = rx->startp[0] = s - t;
1530         rx->endp[0] = off + rx->minlen;
1531     }
1532     else {                      /* startp/endp are used by @- @+. */
1533         rx->startp[0] = s - truebase;
1534         rx->endp[0] = s - truebase + rx->minlen;
1535     }
1536     rx->nparens = rx->lastparen = rx->lastcloseparen = 0;       /* used by @-, @+, and $^N */
1537     LEAVE_SCOPE(oldsave);
1538     RETPUSHYES;
1539
1540 nope:
1541 ret_no:
1542     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1543         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1544             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1545             if (mg)
1546                 mg->mg_len = -1;
1547         }
1548     }
1549     LEAVE_SCOPE(oldsave);
1550     if (gimme == G_ARRAY)
1551         RETURN;
1552     RETPUSHNO;
1553 }
1554
1555 OP *
1556 Perl_do_readline(pTHX)
1557 {
1558     dVAR; dSP; dTARGETSTACKED;
1559     register SV *sv;
1560     STRLEN tmplen = 0;
1561     STRLEN offset;
1562     PerlIO *fp;
1563     register IO * const io = GvIO(PL_last_in_gv);
1564     register const I32 type = PL_op->op_type;
1565     const I32 gimme = GIMME_V;
1566
1567     if (io) {
1568         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1569         if (mg) {
1570             PUSHMARK(SP);
1571             XPUSHs(SvTIED_obj((SV*)io, mg));
1572             PUTBACK;
1573             ENTER;
1574             call_method("READLINE", gimme);
1575             LEAVE;
1576             SPAGAIN;
1577             if (gimme == G_SCALAR) {
1578                 SV* const result = POPs;
1579                 SvSetSV_nosteal(TARG, result);
1580                 PUSHTARG;
1581             }
1582             RETURN;
1583         }
1584     }
1585     fp = NULL;
1586     if (io) {
1587         fp = IoIFP(io);
1588         if (!fp) {
1589             if (IoFLAGS(io) & IOf_ARGV) {
1590                 if (IoFLAGS(io) & IOf_START) {
1591                     IoLINES(io) = 0;
1592                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1593                         IoFLAGS(io) &= ~IOf_START;
1594                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1595                         sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1596                         SvSETMAGIC(GvSV(PL_last_in_gv));
1597                         fp = IoIFP(io);
1598                         goto have_fp;
1599                     }
1600                 }
1601                 fp = nextargv(PL_last_in_gv);
1602                 if (!fp) { /* Note: fp != IoIFP(io) */
1603                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1604                 }
1605             }
1606             else if (type == OP_GLOB)
1607                 fp = Perl_start_glob(aTHX_ POPs, io);
1608         }
1609         else if (type == OP_GLOB)
1610             SP--;
1611         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1612             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1613         }
1614     }
1615     if (!fp) {
1616         if ((!io || !(IoFLAGS(io) & IOf_START))
1617             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1618         {
1619             if (type == OP_GLOB)
1620                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1621                             "glob failed (can't start child: %s)",
1622                             Strerror(errno));
1623             else
1624                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1625         }
1626         if (gimme == G_SCALAR) {
1627             /* undef TARG, and push that undefined value */
1628             if (type != OP_RCATLINE) {
1629                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1630                 SvOK_off(TARG);
1631             }
1632             PUSHTARG;
1633         }
1634         RETURN;
1635     }
1636   have_fp:
1637     if (gimme == G_SCALAR) {
1638         sv = TARG;
1639         if (SvROK(sv))
1640             sv_unref(sv);
1641         else if (isGV_with_GP(sv)) {
1642             SvPV_force_nolen(sv);
1643         }
1644         SvUPGRADE(sv, SVt_PV);
1645         tmplen = SvLEN(sv);     /* remember if already alloced */
1646         if (!tmplen && !SvREADONLY(sv))
1647             Sv_Grow(sv, 80);    /* try short-buffering it */
1648         offset = 0;
1649         if (type == OP_RCATLINE && SvOK(sv)) {
1650             if (!SvPOK(sv)) {
1651                 SvPV_force_nolen(sv);
1652             }
1653             offset = SvCUR(sv);
1654         }
1655     }
1656     else {
1657         sv = sv_2mortal(newSV(80));
1658         offset = 0;
1659     }
1660
1661     /* This should not be marked tainted if the fp is marked clean */
1662 #define MAYBE_TAINT_LINE(io, sv) \
1663     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1664         TAINT;                          \
1665         SvTAINTED_on(sv);               \
1666     }
1667
1668 /* delay EOF state for a snarfed empty file */
1669 #define SNARF_EOF(gimme,rs,io,sv) \
1670     (gimme != G_SCALAR || SvCUR(sv)                                     \
1671      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1672
1673     for (;;) {
1674         PUTBACK;
1675         if (!sv_gets(sv, fp, offset)
1676             && (type == OP_GLOB
1677                 || SNARF_EOF(gimme, PL_rs, io, sv)
1678                 || PerlIO_error(fp)))
1679         {
1680             PerlIO_clearerr(fp);
1681             if (IoFLAGS(io) & IOf_ARGV) {
1682                 fp = nextargv(PL_last_in_gv);
1683                 if (fp)
1684                     continue;
1685                 (void)do_close(PL_last_in_gv, FALSE);
1686             }
1687             else if (type == OP_GLOB) {
1688                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1689                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1690                            "glob failed (child exited with status %d%s)",
1691                            (int)(STATUS_CURRENT >> 8),
1692                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1693                 }
1694             }
1695             if (gimme == G_SCALAR) {
1696                 if (type != OP_RCATLINE) {
1697                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1698                     SvOK_off(TARG);
1699                 }
1700                 SPAGAIN;
1701                 PUSHTARG;
1702             }
1703             MAYBE_TAINT_LINE(io, sv);
1704             RETURN;
1705         }
1706         MAYBE_TAINT_LINE(io, sv);
1707         IoLINES(io)++;
1708         IoFLAGS(io) |= IOf_NOLINE;
1709         SvSETMAGIC(sv);
1710         SPAGAIN;
1711         XPUSHs(sv);
1712         if (type == OP_GLOB) {
1713             const char *t1;
1714
1715             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1716                 char * const tmps = SvEND(sv) - 1;
1717                 if (*tmps == *SvPVX_const(PL_rs)) {
1718                     *tmps = '\0';
1719                     SvCUR_set(sv, SvCUR(sv) - 1);
1720                 }
1721             }
1722             for (t1 = SvPVX_const(sv); *t1; t1++)
1723                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1724                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1725                         break;
1726             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1727                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1728                 continue;
1729             }
1730         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1731              if (ckWARN(WARN_UTF8)) {
1732                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1733                 const STRLEN len = SvCUR(sv) - offset;
1734                 const U8 *f;
1735
1736                 if (!is_utf8_string_loc(s, len, &f))
1737                     /* Emulate :encoding(utf8) warning in the same case. */
1738                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1739                                 "utf8 \"\\x%02X\" does not map to Unicode",
1740                                 f < (U8*)SvEND(sv) ? *f : 0);
1741              }
1742         }
1743         if (gimme == G_ARRAY) {
1744             if (SvLEN(sv) - SvCUR(sv) > 20) {
1745                 SvPV_shrink_to_cur(sv);
1746             }
1747             sv = sv_2mortal(newSV(80));
1748             continue;
1749         }
1750         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1751             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1752             const STRLEN new_len
1753                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1754             SvPV_renew(sv, new_len);
1755         }
1756         RETURN;
1757     }
1758 }
1759
1760 PP(pp_enter)
1761 {
1762     dVAR; dSP;
1763     register PERL_CONTEXT *cx;
1764     I32 gimme = OP_GIMME(PL_op, -1);
1765
1766     if (gimme == -1) {
1767         if (cxstack_ix >= 0)
1768             gimme = cxstack[cxstack_ix].blk_gimme;
1769         else
1770             gimme = G_SCALAR;
1771     }
1772
1773     ENTER;
1774
1775     SAVETMPS;
1776     PUSHBLOCK(cx, CXt_BLOCK, SP);
1777
1778     RETURN;
1779 }
1780
1781 PP(pp_helem)
1782 {
1783     dVAR; dSP;
1784     HE* he;
1785     SV **svp;
1786     SV * const keysv = POPs;
1787     HV * const hv = (HV*)POPs;
1788     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1789     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1790     SV *sv;
1791     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1792     I32 preeminent = 0;
1793
1794     if (SvTYPE(hv) != SVt_PVHV)
1795         RETPUSHUNDEF;
1796
1797     if (PL_op->op_private & OPpLVAL_INTRO) {
1798         MAGIC *mg;
1799         HV *stash;
1800         /* does the element we're localizing already exist? */
1801         preeminent = /* can we determine whether it exists? */
1802             (    !SvRMAGICAL(hv)
1803                 || mg_find((SV*)hv, PERL_MAGIC_env)
1804                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1805                         /* Try to preserve the existenceness of a tied hash
1806                         * element by using EXISTS and DELETE if possible.
1807                         * Fallback to FETCH and STORE otherwise */
1808                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1809                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1810                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1811                 )
1812             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1813     }
1814     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1815     svp = he ? &HeVAL(he) : NULL;
1816     if (lval) {
1817         if (!svp || *svp == &PL_sv_undef) {
1818             SV* lv;
1819             SV* key2;
1820             if (!defer) {
1821                 DIE(aTHX_ PL_no_helem_sv, keysv);
1822             }
1823             lv = sv_newmortal();
1824             sv_upgrade(lv, SVt_PVLV);
1825             LvTYPE(lv) = 'y';
1826             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1827             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1828             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1829             LvTARGLEN(lv) = 1;
1830             PUSHs(lv);
1831             RETURN;
1832         }
1833         if (PL_op->op_private & OPpLVAL_INTRO) {
1834             if (HvNAME_get(hv) && isGV(*svp))
1835                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1836             else {
1837                 if (!preeminent) {
1838                     STRLEN keylen;
1839                     const char * const key = SvPV_const(keysv, keylen);
1840                     SAVEDELETE(hv, savepvn(key,keylen),
1841                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1842                 } else
1843                     save_helem(hv, keysv, svp);
1844             }
1845         }
1846         else if (PL_op->op_private & OPpDEREF)
1847             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1848     }
1849     sv = (svp ? *svp : &PL_sv_undef);
1850     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1851      * Pushing the magical RHS on to the stack is useless, since
1852      * that magic is soon destined to be misled by the local(),
1853      * and thus the later pp_sassign() will fail to mg_get() the
1854      * old value.  This should also cure problems with delayed
1855      * mg_get()s.  GSAR 98-07-03 */
1856     if (!lval && SvGMAGICAL(sv))
1857         sv = sv_mortalcopy(sv);
1858     PUSHs(sv);
1859     RETURN;
1860 }
1861
1862 PP(pp_leave)
1863 {
1864     dVAR; dSP;
1865     register PERL_CONTEXT *cx;
1866     SV **newsp;
1867     PMOP *newpm;
1868     I32 gimme;
1869
1870     if (PL_op->op_flags & OPf_SPECIAL) {
1871         cx = &cxstack[cxstack_ix];
1872         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1873     }
1874
1875     POPBLOCK(cx,newpm);
1876
1877     gimme = OP_GIMME(PL_op, -1);
1878     if (gimme == -1) {
1879         if (cxstack_ix >= 0)
1880             gimme = cxstack[cxstack_ix].blk_gimme;
1881         else
1882             gimme = G_SCALAR;
1883     }
1884
1885     TAINT_NOT;
1886     if (gimme == G_VOID)
1887         SP = newsp;
1888     else if (gimme == G_SCALAR) {
1889         register SV **mark;
1890         MARK = newsp + 1;
1891         if (MARK <= SP) {
1892             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1893                 *MARK = TOPs;
1894             else
1895                 *MARK = sv_mortalcopy(TOPs);
1896         } else {
1897             MEXTEND(mark,0);
1898             *MARK = &PL_sv_undef;
1899         }
1900         SP = MARK;
1901     }
1902     else if (gimme == G_ARRAY) {
1903         /* in case LEAVE wipes old return values */
1904         register SV **mark;
1905         for (mark = newsp + 1; mark <= SP; mark++) {
1906             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1907                 *mark = sv_mortalcopy(*mark);
1908                 TAINT_NOT;      /* Each item is independent */
1909             }
1910         }
1911     }
1912     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1913
1914     LEAVE;
1915
1916     RETURN;
1917 }
1918
1919 PP(pp_iter)
1920 {
1921     dVAR; dSP;
1922     register PERL_CONTEXT *cx;
1923     SV *sv, *oldsv;
1924     AV* av;
1925     SV **itersvp;
1926
1927     EXTEND(SP, 1);
1928     cx = &cxstack[cxstack_ix];
1929     if (CxTYPE(cx) != CXt_LOOP)
1930         DIE(aTHX_ "panic: pp_iter");
1931
1932     itersvp = CxITERVAR(cx);
1933     av = cx->blk_loop.iterary;
1934     if (SvTYPE(av) != SVt_PVAV) {
1935         /* iterate ($min .. $max) */
1936         if (cx->blk_loop.iterlval) {
1937             /* string increment */
1938             register SV* cur = cx->blk_loop.iterlval;
1939             STRLEN maxlen = 0;
1940             const char *max =
1941               SvOK((SV*)av) ?
1942               SvPV_const((SV*)av, maxlen) : (const char *)"";
1943             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1944                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1945                     /* safe to reuse old SV */
1946                     sv_setsv(*itersvp, cur);
1947                 }
1948                 else
1949                 {
1950                     /* we need a fresh SV every time so that loop body sees a
1951                      * completely new SV for closures/references to work as
1952                      * they used to */
1953                     oldsv = *itersvp;
1954                     *itersvp = newSVsv(cur);
1955                     SvREFCNT_dec(oldsv);
1956                 }
1957                 if (strEQ(SvPVX_const(cur), max))
1958                     sv_setiv(cur, 0); /* terminate next time */
1959                 else
1960                     sv_inc(cur);
1961                 RETPUSHYES;
1962             }
1963             RETPUSHNO;
1964         }
1965         /* integer increment */
1966         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1967             RETPUSHNO;
1968
1969         /* don't risk potential race */
1970         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1971             /* safe to reuse old SV */
1972             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1973         }
1974         else
1975         {
1976             /* we need a fresh SV every time so that loop body sees a
1977              * completely new SV for closures/references to work as they
1978              * used to */
1979             oldsv = *itersvp;
1980             *itersvp = newSViv(cx->blk_loop.iterix++);
1981             SvREFCNT_dec(oldsv);
1982         }
1983         RETPUSHYES;
1984     }
1985
1986     /* iterate array */
1987     if (PL_op->op_private & OPpITER_REVERSED) {
1988         /* In reverse, use itermax as the min :-)  */
1989         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1990             RETPUSHNO;
1991
1992         if (SvMAGICAL(av) || AvREIFY(av)) {
1993             SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1994             sv = svp ? *svp : NULL;
1995         }
1996         else {
1997             sv = AvARRAY(av)[--cx->blk_loop.iterix];
1998         }
1999     }
2000     else {
2001         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
2002                                     AvFILL(av)))
2003             RETPUSHNO;
2004
2005         if (SvMAGICAL(av) || AvREIFY(av)) {
2006             SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
2007             sv = svp ? *svp : NULL;
2008         }
2009         else {
2010             sv = AvARRAY(av)[++cx->blk_loop.iterix];
2011         }
2012     }
2013
2014     if (sv && SvIS_FREED(sv)) {
2015         *itersvp = NULL;
2016         Perl_croak(aTHX_ "Use of freed value in iteration");
2017     }
2018
2019     if (sv)
2020         SvTEMP_off(sv);
2021     else
2022         sv = &PL_sv_undef;
2023     if (av != PL_curstack && sv == &PL_sv_undef) {
2024         SV *lv = cx->blk_loop.iterlval;
2025         if (lv && SvREFCNT(lv) > 1) {
2026             SvREFCNT_dec(lv);
2027             lv = NULL;
2028         }
2029         if (lv)
2030             SvREFCNT_dec(LvTARG(lv));
2031         else {
2032             lv = cx->blk_loop.iterlval = newSV(0);
2033             sv_upgrade(lv, SVt_PVLV);
2034             LvTYPE(lv) = 'y';
2035             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2036         }
2037         LvTARG(lv) = SvREFCNT_inc_simple(av);
2038         LvTARGOFF(lv) = cx->blk_loop.iterix;
2039         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2040         sv = (SV*)lv;
2041     }
2042
2043     oldsv = *itersvp;
2044     *itersvp = SvREFCNT_inc_simple_NN(sv);
2045     SvREFCNT_dec(oldsv);
2046
2047     RETPUSHYES;
2048 }
2049
2050 PP(pp_subst)
2051 {
2052     dVAR; dSP; dTARG;
2053     register PMOP *pm = cPMOP;
2054     PMOP *rpm = pm;
2055     register char *s;
2056     char *strend;
2057     register char *m;
2058     const char *c;
2059     register char *d;
2060     STRLEN clen;
2061     I32 iters = 0;
2062     I32 maxiters;
2063     register I32 i;
2064     bool once;
2065     bool rxtainted;
2066     char *orig;
2067     I32 r_flags;
2068     register REGEXP *rx = PM_GETRE(pm);
2069     STRLEN len;
2070     int force_on_match = 0;
2071     const I32 oldsave = PL_savestack_ix;
2072     STRLEN slen;
2073     bool doutf8 = FALSE;
2074 #ifdef PERL_OLD_COPY_ON_WRITE
2075     bool is_cow;
2076 #endif
2077     SV *nsv = NULL;
2078
2079     /* known replacement string? */
2080     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2081     if (PL_op->op_flags & OPf_STACKED)
2082         TARG = POPs;
2083     else if (PL_op->op_private & OPpTARGET_MY)
2084         GETTARGET;
2085     else {
2086         TARG = DEFSV;
2087         EXTEND(SP,1);
2088     }
2089
2090 #ifdef PERL_OLD_COPY_ON_WRITE
2091     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2092        because they make integers such as 256 "false".  */
2093     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2094 #else
2095     if (SvIsCOW(TARG))
2096         sv_force_normal_flags(TARG,0);
2097 #endif
2098     if (
2099 #ifdef PERL_OLD_COPY_ON_WRITE
2100         !is_cow &&
2101 #endif
2102         (SvREADONLY(TARG)
2103         || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2104              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2105         DIE(aTHX_ PL_no_modify);
2106     PUTBACK;
2107
2108     s = SvPV_mutable(TARG, len);
2109     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2110         force_on_match = 1;
2111     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2112                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2113     if (PL_tainted)
2114         rxtainted |= 2;
2115     TAINT_NOT;
2116
2117     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2118
2119   force_it:
2120     if (!pm || !s)
2121         DIE(aTHX_ "panic: pp_subst");
2122
2123     strend = s + len;
2124     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2125     maxiters = 2 * slen + 10;   /* We can match twice at each
2126                                    position, once with zero-length,
2127                                    second time with non-zero. */
2128
2129     if (!rx->prelen && PL_curpm) {
2130         pm = PL_curpm;
2131         rx = PM_GETRE(pm);
2132     }
2133     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2134             || (pm->op_pmflags & PMf_EVAL))
2135                ? REXEC_COPY_STR : 0;
2136     if (SvSCREAM(TARG))
2137         r_flags |= REXEC_SCREAM;
2138
2139     orig = m = s;
2140     if (rx->reganch & RE_USE_INTUIT) {
2141         PL_bostr = orig;
2142         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2143
2144         if (!s)
2145             goto nope;
2146         /* How to do it in subst? */
2147 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2148              && !PL_sawampersand
2149              && ((rx->reganch & ROPT_NOSCAN)
2150                  || !((rx->reganch & RE_INTUIT_TAIL)
2151                       && (r_flags & REXEC_SCREAM))))
2152             goto yup;
2153 */
2154     }
2155
2156     /* only replace once? */
2157     once = !(rpm->op_pmflags & PMf_GLOBAL);
2158
2159     /* known replacement string? */
2160     if (dstr) {
2161         /* replacement needing upgrading? */
2162         if (DO_UTF8(TARG) && !doutf8) {
2163              nsv = sv_newmortal();
2164              SvSetSV(nsv, dstr);
2165              if (PL_encoding)
2166                   sv_recode_to_utf8(nsv, PL_encoding);
2167              else
2168                   sv_utf8_upgrade(nsv);
2169              c = SvPV_const(nsv, clen);
2170              doutf8 = TRUE;
2171         }
2172         else {
2173             c = SvPV_const(dstr, clen);
2174             doutf8 = DO_UTF8(dstr);
2175         }
2176     }
2177     else {
2178         c = NULL;
2179         doutf8 = FALSE;
2180     }
2181
2182     /* can do inplace substitution? */
2183     if (c
2184 #ifdef PERL_OLD_COPY_ON_WRITE
2185         && !is_cow
2186 #endif
2187         && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2188         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2189         && (!doutf8 || SvUTF8(TARG))) {
2190         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2191                          r_flags | REXEC_CHECKED))
2192         {
2193             SPAGAIN;
2194             PUSHs(&PL_sv_no);
2195             LEAVE_SCOPE(oldsave);
2196             RETURN;
2197         }
2198 #ifdef PERL_OLD_COPY_ON_WRITE
2199         if (SvIsCOW(TARG)) {
2200             assert (!force_on_match);
2201             goto have_a_cow;
2202         }
2203 #endif
2204         if (force_on_match) {
2205             force_on_match = 0;
2206             s = SvPV_force(TARG, len);
2207             goto force_it;
2208         }
2209         d = s;
2210         PL_curpm = pm;
2211         SvSCREAM_off(TARG);     /* disable possible screamer */
2212         if (once) {
2213             rxtainted |= RX_MATCH_TAINTED(rx);
2214             m = orig + rx->startp[0];
2215             d = orig + rx->endp[0];
2216             s = orig;
2217             if (m - s > strend - d) {  /* faster to shorten from end */
2218                 if (clen) {
2219                     Copy(c, m, clen, char);
2220                     m += clen;
2221                 }
2222                 i = strend - d;
2223                 if (i > 0) {
2224                     Move(d, m, i, char);
2225                     m += i;
2226                 }
2227                 *m = '\0';
2228                 SvCUR_set(TARG, m - s);
2229             }
2230             else if ((i = m - s)) {     /* faster from front */
2231                 d -= clen;
2232                 m = d;
2233                 sv_chop(TARG, d-i);
2234                 s += i;
2235                 while (i--)
2236                     *--d = *--s;
2237                 if (clen)
2238                     Copy(c, m, clen, char);
2239             }
2240             else if (clen) {
2241                 d -= clen;
2242                 sv_chop(TARG, d);
2243                 Copy(c, d, clen, char);
2244             }
2245             else {
2246                 sv_chop(TARG, d);
2247             }
2248             TAINT_IF(rxtainted & 1);
2249             SPAGAIN;
2250             PUSHs(&PL_sv_yes);
2251         }
2252         else {
2253             do {
2254                 if (iters++ > maxiters)
2255                     DIE(aTHX_ "Substitution loop");
2256                 rxtainted |= RX_MATCH_TAINTED(rx);
2257                 m = rx->startp[0] + orig;
2258                 if ((i = m - s)) {
2259                     if (s != d)
2260                         Move(s, d, i, char);
2261                     d += i;
2262                 }
2263                 if (clen) {
2264                     Copy(c, d, clen, char);
2265                     d += clen;
2266                 }
2267                 s = rx->endp[0] + orig;
2268             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2269                                  TARG, NULL,
2270                                  /* don't match same null twice */
2271                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2272             if (s != d) {
2273                 i = strend - s;
2274                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2275                 Move(s, d, i+1, char);          /* include the NUL */
2276             }
2277             TAINT_IF(rxtainted & 1);
2278             SPAGAIN;
2279             PUSHs(sv_2mortal(newSViv((I32)iters)));
2280         }
2281         (void)SvPOK_only_UTF8(TARG);
2282         TAINT_IF(rxtainted);
2283         if (SvSMAGICAL(TARG)) {
2284             PUTBACK;
2285             mg_set(TARG);
2286             SPAGAIN;
2287         }
2288         SvTAINT(TARG);
2289         if (doutf8)
2290             SvUTF8_on(TARG);
2291         LEAVE_SCOPE(oldsave);
2292         RETURN;
2293     }
2294
2295     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2296                     r_flags | REXEC_CHECKED))
2297     {
2298         if (force_on_match) {
2299             force_on_match = 0;
2300             s = SvPV_force(TARG, len);
2301             goto force_it;
2302         }
2303 #ifdef PERL_OLD_COPY_ON_WRITE
2304       have_a_cow:
2305 #endif
2306         rxtainted |= RX_MATCH_TAINTED(rx);
2307         dstr = newSVpvn(m, s-m);
2308         SAVEFREESV(dstr);
2309         if (DO_UTF8(TARG))
2310             SvUTF8_on(dstr);
2311         PL_curpm = pm;
2312         if (!c) {
2313             register PERL_CONTEXT *cx;
2314             SPAGAIN;
2315             PUSHSUBST(cx);
2316             RETURNOP(cPMOP->op_pmreplroot);
2317         }
2318         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2319         do {
2320             if (iters++ > maxiters)
2321                 DIE(aTHX_ "Substitution loop");
2322             rxtainted |= RX_MATCH_TAINTED(rx);
2323             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2324                 m = s;
2325                 s = orig;
2326                 orig = rx->subbeg;
2327                 s = orig + (m - s);
2328                 strend = s + (strend - m);
2329             }
2330             m = rx->startp[0] + orig;
2331             if (doutf8 && !SvUTF8(dstr))
2332                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2333             else
2334                 sv_catpvn(dstr, s, m-s);
2335             s = rx->endp[0] + orig;
2336             if (clen)
2337                 sv_catpvn(dstr, c, clen);
2338             if (once)
2339                 break;
2340         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2341                              TARG, NULL, r_flags));
2342         if (doutf8 && !DO_UTF8(TARG))
2343             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2344         else
2345             sv_catpvn(dstr, s, strend - s);
2346
2347 #ifdef PERL_OLD_COPY_ON_WRITE
2348         /* The match may make the string COW. If so, brilliant, because that's
2349            just saved us one malloc, copy and free - the regexp has donated
2350            the old buffer, and we malloc an entirely new one, rather than the
2351            regexp malloc()ing a buffer and copying our original, only for
2352            us to throw it away here during the substitution.  */
2353         if (SvIsCOW(TARG)) {
2354             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2355         } else
2356 #endif
2357         {
2358             SvPV_free(TARG);
2359         }
2360         SvPV_set(TARG, SvPVX(dstr));
2361         SvCUR_set(TARG, SvCUR(dstr));
2362         SvLEN_set(TARG, SvLEN(dstr));
2363         doutf8 |= DO_UTF8(dstr);
2364         SvPV_set(dstr, NULL);
2365
2366         TAINT_IF(rxtainted & 1);
2367         SPAGAIN;
2368         PUSHs(sv_2mortal(newSViv((I32)iters)));
2369
2370         (void)SvPOK_only(TARG);
2371         if (doutf8)
2372             SvUTF8_on(TARG);
2373         TAINT_IF(rxtainted);
2374         SvSETMAGIC(TARG);
2375         SvTAINT(TARG);
2376         LEAVE_SCOPE(oldsave);
2377         RETURN;
2378     }
2379     goto ret_no;
2380
2381 nope:
2382 ret_no:
2383     SPAGAIN;
2384     PUSHs(&PL_sv_no);
2385     LEAVE_SCOPE(oldsave);
2386     RETURN;
2387 }
2388
2389 PP(pp_grepwhile)
2390 {
2391     dVAR; dSP;
2392
2393     if (SvTRUEx(POPs))
2394         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2395     ++*PL_markstack_ptr;
2396     LEAVE;                                      /* exit inner scope */
2397
2398     /* All done yet? */
2399     if (PL_stack_base + *PL_markstack_ptr > SP) {
2400         I32 items;
2401         const I32 gimme = GIMME_V;
2402
2403         LEAVE;                                  /* exit outer scope */
2404         (void)POPMARK;                          /* pop src */
2405         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2406         (void)POPMARK;                          /* pop dst */
2407         SP = PL_stack_base + POPMARK;           /* pop original mark */
2408         if (gimme == G_SCALAR) {
2409             if (PL_op->op_private & OPpGREP_LEX) {
2410                 SV* const sv = sv_newmortal();
2411                 sv_setiv(sv, items);
2412                 PUSHs(sv);
2413             }
2414             else {
2415                 dTARGET;
2416                 XPUSHi(items);
2417             }
2418         }
2419         else if (gimme == G_ARRAY)
2420             SP += items;
2421         RETURN;
2422     }
2423     else {
2424         SV *src;
2425
2426         ENTER;                                  /* enter inner scope */
2427         SAVEVPTR(PL_curpm);
2428
2429         src = PL_stack_base[*PL_markstack_ptr];
2430         SvTEMP_off(src);
2431         if (PL_op->op_private & OPpGREP_LEX)
2432             PAD_SVl(PL_op->op_targ) = src;
2433         else
2434             DEFSV = src;
2435
2436         RETURNOP(cLOGOP->op_other);
2437     }
2438 }
2439
2440 PP(pp_leavesub)
2441 {
2442     dVAR; dSP;
2443     SV **mark;
2444     SV **newsp;
2445     PMOP *newpm;
2446     I32 gimme;
2447     register PERL_CONTEXT *cx;
2448     SV *sv;
2449
2450     if (CxMULTICALL(&cxstack[cxstack_ix]))
2451         return 0;
2452
2453     POPBLOCK(cx,newpm);
2454     cxstack_ix++; /* temporarily protect top context */
2455
2456     TAINT_NOT;
2457     if (gimme == G_SCALAR) {
2458         MARK = newsp + 1;
2459         if (MARK <= SP) {
2460             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2461                 if (SvTEMP(TOPs)) {
2462                     *MARK = SvREFCNT_inc(TOPs);
2463                     FREETMPS;
2464                     sv_2mortal(*MARK);
2465                 }
2466                 else {
2467                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2468                     FREETMPS;
2469                     *MARK = sv_mortalcopy(sv);
2470                     SvREFCNT_dec(sv);
2471                 }
2472             }
2473             else
2474                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2475         }
2476         else {
2477             MEXTEND(MARK, 0);
2478             *MARK = &PL_sv_undef;
2479         }
2480         SP = MARK;
2481     }
2482     else if (gimme == G_ARRAY) {
2483         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2484             if (!SvTEMP(*MARK)) {
2485                 *MARK = sv_mortalcopy(*MARK);
2486                 TAINT_NOT;      /* Each item is independent */
2487             }
2488         }
2489     }
2490     PUTBACK;
2491
2492     LEAVE;
2493     cxstack_ix--;
2494     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2495     PL_curpm = newpm;   /* ... and pop $1 et al */
2496
2497     LEAVESUB(sv);
2498     return cx->blk_sub.retop;
2499 }
2500
2501 /* This duplicates the above code because the above code must not
2502  * get any slower by more conditions */
2503 PP(pp_leavesublv)
2504 {
2505     dVAR; dSP;
2506     SV **mark;
2507     SV **newsp;
2508     PMOP *newpm;
2509     I32 gimme;
2510     register PERL_CONTEXT *cx;
2511     SV *sv;
2512
2513     if (CxMULTICALL(&cxstack[cxstack_ix]))
2514         return 0;
2515
2516     POPBLOCK(cx,newpm);
2517     cxstack_ix++; /* temporarily protect top context */
2518
2519     TAINT_NOT;
2520
2521     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2522         /* We are an argument to a function or grep().
2523          * This kind of lvalueness was legal before lvalue
2524          * subroutines too, so be backward compatible:
2525          * cannot report errors.  */
2526
2527         /* Scalar context *is* possible, on the LHS of -> only,
2528          * as in f()->meth().  But this is not an lvalue. */
2529         if (gimme == G_SCALAR)
2530             goto temporise;
2531         if (gimme == G_ARRAY) {
2532             if (!CvLVALUE(cx->blk_sub.cv))
2533                 goto temporise_array;
2534             EXTEND_MORTAL(SP - newsp);
2535             for (mark = newsp + 1; mark <= SP; mark++) {
2536                 if (SvTEMP(*mark))
2537                     NOOP;
2538                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2539                     *mark = sv_mortalcopy(*mark);
2540                 else {
2541                     /* Can be a localized value subject to deletion. */
2542                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2543                     SvREFCNT_inc_void(*mark);
2544                 }
2545             }
2546         }
2547     }
2548     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2549         /* Here we go for robustness, not for speed, so we change all
2550          * the refcounts so the caller gets a live guy. Cannot set
2551          * TEMP, so sv_2mortal is out of question. */
2552         if (!CvLVALUE(cx->blk_sub.cv)) {
2553             LEAVE;
2554             cxstack_ix--;
2555             POPSUB(cx,sv);
2556             PL_curpm = newpm;
2557             LEAVESUB(sv);
2558             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2559         }
2560         if (gimme == G_SCALAR) {
2561             MARK = newsp + 1;
2562             EXTEND_MORTAL(1);
2563             if (MARK == SP) {
2564                 /* Temporaries are bad unless they happen to be elements
2565                  * of a tied hash or array */
2566                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2567                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2568                     LEAVE;
2569                     cxstack_ix--;
2570                     POPSUB(cx,sv);
2571                     PL_curpm = newpm;
2572                     LEAVESUB(sv);
2573                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2574                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2575                         : "a readonly value" : "a temporary");
2576                 }
2577                 else {                  /* Can be a localized value
2578                                          * subject to deletion. */
2579                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2580                     SvREFCNT_inc_void(*mark);
2581                 }
2582             }
2583             else {                      /* Should not happen? */
2584                 LEAVE;
2585                 cxstack_ix--;
2586                 POPSUB(cx,sv);
2587                 PL_curpm = newpm;
2588                 LEAVESUB(sv);
2589                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2590                     (MARK > SP ? "Empty array" : "Array"));
2591             }
2592             SP = MARK;
2593         }
2594         else if (gimme == G_ARRAY) {
2595             EXTEND_MORTAL(SP - newsp);
2596             for (mark = newsp + 1; mark <= SP; mark++) {
2597                 if (*mark != &PL_sv_undef
2598                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2599                     /* Might be flattened array after $#array =  */
2600                     PUTBACK;
2601                     LEAVE;
2602                     cxstack_ix--;
2603                     POPSUB(cx,sv);
2604                     PL_curpm = newpm;
2605                     LEAVESUB(sv);
2606                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2607                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2608                 }
2609                 else {
2610                     /* Can be a localized value subject to deletion. */
2611                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2612                     SvREFCNT_inc_void(*mark);
2613                 }
2614             }
2615         }
2616     }
2617     else {
2618         if (gimme == G_SCALAR) {
2619           temporise:
2620             MARK = newsp + 1;
2621             if (MARK <= SP) {
2622                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2623                     if (SvTEMP(TOPs)) {
2624                         *MARK = SvREFCNT_inc(TOPs);
2625                         FREETMPS;
2626                         sv_2mortal(*MARK);
2627                     }
2628                     else {
2629                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2630                         FREETMPS;
2631                         *MARK = sv_mortalcopy(sv);
2632                         SvREFCNT_dec(sv);
2633                     }
2634                 }
2635                 else
2636                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2637             }
2638             else {
2639                 MEXTEND(MARK, 0);
2640                 *MARK = &PL_sv_undef;
2641             }
2642             SP = MARK;
2643         }
2644         else if (gimme == G_ARRAY) {
2645           temporise_array:
2646             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2647                 if (!SvTEMP(*MARK)) {
2648                     *MARK = sv_mortalcopy(*MARK);
2649                     TAINT_NOT;  /* Each item is independent */
2650                 }
2651             }
2652         }
2653     }
2654     PUTBACK;
2655
2656     LEAVE;
2657     cxstack_ix--;
2658     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2659     PL_curpm = newpm;   /* ... and pop $1 et al */
2660
2661     LEAVESUB(sv);
2662     return cx->blk_sub.retop;
2663 }
2664
2665
2666 STATIC CV *
2667 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2668 {
2669     dVAR;
2670     SV * const dbsv = GvSVn(PL_DBsub);
2671
2672     save_item(dbsv);
2673     if (!PERLDB_SUB_NN) {
2674         GV * const gv = CvGV(cv);
2675
2676         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2677              || strEQ(GvNAME(gv), "END")
2678              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2679                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2680             /* Use GV from the stack as a fallback. */
2681             /* GV is potentially non-unique, or contain different CV. */
2682             SV * const tmp = newRV((SV*)cv);
2683             sv_setsv(dbsv, tmp);
2684             SvREFCNT_dec(tmp);
2685         }
2686         else {
2687             gv_efullname3(dbsv, gv, NULL);
2688         }
2689     }
2690     else {
2691         const int type = SvTYPE(dbsv);
2692         if (type < SVt_PVIV && type != SVt_IV)
2693             sv_upgrade(dbsv, SVt_PVIV);
2694         (void)SvIOK_on(dbsv);
2695         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2696     }
2697
2698     if (CvISXSUB(cv))
2699         PL_curcopdb = PL_curcop;
2700     cv = GvCV(PL_DBsub);
2701     return cv;
2702 }
2703
2704 PP(pp_entersub)
2705 {
2706     dVAR; dSP; dPOPss;
2707     GV *gv;
2708     register CV *cv;
2709     register PERL_CONTEXT *cx;
2710     I32 gimme;
2711     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2712
2713     if (!sv)
2714         DIE(aTHX_ "Not a CODE reference");
2715     switch (SvTYPE(sv)) {
2716         /* This is overwhelming the most common case:  */
2717     case SVt_PVGV:
2718         if (!(cv = GvCVu((GV*)sv))) {
2719             HV *stash;
2720             cv = sv_2cv(sv, &stash, &gv, 0);
2721         }
2722         if (!cv) {
2723             ENTER;
2724             SAVETMPS;
2725             goto try_autoload;
2726         }
2727         break;
2728     default:
2729         if (!SvROK(sv)) {
2730             const char *sym;
2731             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2732                 if (hasargs)
2733                     SP = PL_stack_base + POPMARK;
2734                 RETURN;
2735             }
2736             if (SvGMAGICAL(sv)) {
2737                 mg_get(sv);
2738                 if (SvROK(sv))
2739                     goto got_rv;
2740                 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2741             }
2742             else {
2743                 sym = SvPV_nolen_const(sv);
2744             }
2745             if (!sym)
2746                 DIE(aTHX_ PL_no_usym, "a subroutine");
2747             if (PL_op->op_private & HINT_STRICT_REFS)
2748                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2749             cv = get_cv(sym, TRUE);
2750             break;
2751         }
2752   got_rv:
2753         {
2754             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2755             tryAMAGICunDEREF(to_cv);
2756         }
2757         cv = (CV*)SvRV(sv);
2758         if (SvTYPE(cv) == SVt_PVCV)
2759             break;
2760         /* FALL THROUGH */
2761     case SVt_PVHV:
2762     case SVt_PVAV:
2763         DIE(aTHX_ "Not a CODE reference");
2764         /* This is the second most common case:  */
2765     case SVt_PVCV:
2766         cv = (CV*)sv;
2767         break;
2768     }
2769
2770     ENTER;
2771     SAVETMPS;
2772
2773   retry:
2774     if (!CvROOT(cv) && !CvXSUB(cv)) {
2775         GV* autogv;
2776         SV* sub_name;
2777
2778         /* anonymous or undef'd function leaves us no recourse */
2779         if (CvANON(cv) || !(gv = CvGV(cv)))
2780             DIE(aTHX_ "Undefined subroutine called");
2781
2782         /* autoloaded stub? */
2783         if (cv != GvCV(gv)) {
2784             cv = GvCV(gv);
2785         }
2786         /* should call AUTOLOAD now? */
2787         else {
2788 try_autoload:
2789             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2790                                    FALSE)))
2791             {
2792                 cv = GvCV(autogv);
2793             }
2794             /* sorry */
2795             else {
2796                 sub_name = sv_newmortal();
2797                 gv_efullname3(sub_name, gv, NULL);
2798                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name);
2799             }
2800         }
2801         if (!cv)
2802             DIE(aTHX_ "Not a CODE reference");
2803         goto retry;
2804     }
2805
2806     gimme = GIMME_V;
2807     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2808         if (CvASSERTION(cv) && PL_DBassertion)
2809             sv_setiv(PL_DBassertion, 1);
2810
2811         cv = get_db_sub(&sv, cv);
2812         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2813             DIE(aTHX_ "No DB::sub routine defined");
2814     }
2815
2816     if (!(CvISXSUB(cv))) {
2817         /* This path taken at least 75% of the time   */
2818         dMARK;
2819         register I32 items = SP - MARK;
2820         AV* const padlist = CvPADLIST(cv);
2821         PUSHBLOCK(cx, CXt_SUB, MARK);
2822         PUSHSUB(cx);
2823         cx->blk_sub.retop = PL_op->op_next;
2824         CvDEPTH(cv)++;
2825         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2826          * that eval'' ops within this sub know the correct lexical space.
2827          * Owing the speed considerations, we choose instead to search for
2828          * the cv using find_runcv() when calling doeval().
2829          */
2830         if (CvDEPTH(cv) >= 2) {
2831             PERL_STACK_OVERFLOW_CHECK();
2832             pad_push(padlist, CvDEPTH(cv));
2833         }
2834         SAVECOMPPAD();
2835         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2836         if (hasargs) {
2837             AV* const av = (AV*)PAD_SVl(0);
2838             if (AvREAL(av)) {
2839                 /* @_ is normally not REAL--this should only ever
2840                  * happen when DB::sub() calls things that modify @_ */
2841                 av_clear(av);
2842                 AvREAL_off(av);
2843                 AvREIFY_on(av);
2844             }
2845             cx->blk_sub.savearray = GvAV(PL_defgv);
2846             GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2847             CX_CURPAD_SAVE(cx->blk_sub);
2848             cx->blk_sub.argarray = av;
2849             ++MARK;
2850
2851             if (items > AvMAX(av) + 1) {
2852                 SV **ary = AvALLOC(av);
2853                 if (AvARRAY(av) != ary) {
2854                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2855                     SvPV_set(av, (char*)ary);
2856                 }
2857                 if (items > AvMAX(av) + 1) {
2858                     AvMAX(av) = items - 1;
2859                     Renew(ary,items,SV*);
2860                     AvALLOC(av) = ary;
2861                     SvPV_set(av, (char*)ary);
2862                 }
2863             }
2864             Copy(MARK,AvARRAY(av),items,SV*);
2865             AvFILLp(av) = items - 1;
2866
2867             while (items--) {
2868                 if (*MARK)
2869                     SvTEMP_off(*MARK);
2870                 MARK++;
2871             }
2872         }
2873         /* warning must come *after* we fully set up the context
2874          * stuff so that __WARN__ handlers can safely dounwind()
2875          * if they want to
2876          */
2877         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2878             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2879             sub_crush_depth(cv);
2880 #if 0
2881         DEBUG_S(PerlIO_printf(Perl_debug_log,
2882                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2883 #endif
2884         RETURNOP(CvSTART(cv));
2885     }
2886     else {
2887         I32 markix = TOPMARK;
2888
2889         PUTBACK;
2890
2891         if (!hasargs) {
2892             /* Need to copy @_ to stack. Alternative may be to
2893              * switch stack to @_, and copy return values
2894              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2895             AV * const av = GvAV(PL_defgv);
2896             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2897
2898             if (items) {
2899                 /* Mark is at the end of the stack. */
2900                 EXTEND(SP, items);
2901                 Copy(AvARRAY(av), SP + 1, items, SV*);
2902                 SP += items;
2903                 PUTBACK ;
2904             }
2905         }
2906         /* We assume first XSUB in &DB::sub is the called one. */
2907         if (PL_curcopdb) {
2908             SAVEVPTR(PL_curcop);
2909             PL_curcop = PL_curcopdb;
2910             PL_curcopdb = NULL;
2911         }
2912         /* Do we need to open block here? XXXX */
2913         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2914             (void)(*CvXSUB(cv))(aTHX_ cv);
2915
2916         /* Enforce some sanity in scalar context. */
2917         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2918             if (markix > PL_stack_sp - PL_stack_base)
2919                 *(PL_stack_base + markix) = &PL_sv_undef;
2920             else
2921                 *(PL_stack_base + markix) = *PL_stack_sp;
2922             PL_stack_sp = PL_stack_base + markix;
2923         }
2924         LEAVE;
2925         return NORMAL;
2926     }
2927 }
2928
2929 void
2930 Perl_sub_crush_depth(pTHX_ CV *cv)
2931 {
2932     if (CvANON(cv))
2933         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2934     else {
2935         SV* const tmpstr = sv_newmortal();
2936         gv_efullname3(tmpstr, CvGV(cv), NULL);
2937         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2938                     (void*)tmpstr);
2939     }
2940 }
2941
2942 PP(pp_aelem)
2943 {
2944     dVAR; dSP;
2945     SV** svp;
2946     SV* const elemsv = POPs;
2947     IV elem = SvIV(elemsv);
2948     AV* const av = (AV*)POPs;
2949     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2950     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2951     SV *sv;
2952
2953     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2954         Perl_warner(aTHX_ packWARN(WARN_MISC),
2955                     "Use of reference \"%"SVf"\" as array index",
2956                     (void*)elemsv);
2957     if (elem > 0)
2958         elem -= CopARYBASE_get(PL_curcop);
2959     if (SvTYPE(av) != SVt_PVAV)
2960         RETPUSHUNDEF;
2961     svp = av_fetch(av, elem, lval && !defer);
2962     if (lval) {
2963 #ifdef PERL_MALLOC_WRAP
2964          if (SvUOK(elemsv)) {
2965               const UV uv = SvUV(elemsv);
2966               elem = uv > IV_MAX ? IV_MAX : uv;
2967          }
2968          else if (SvNOK(elemsv))
2969               elem = (IV)SvNV(elemsv);
2970          if (elem > 0) {
2971               static const char oom_array_extend[] =
2972                 "Out of memory during array extend"; /* Duplicated in av.c */
2973               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2974          }
2975 #endif
2976         if (!svp || *svp == &PL_sv_undef) {
2977             SV* lv;
2978             if (!defer)
2979                 DIE(aTHX_ PL_no_aelem, elem);
2980             lv = sv_newmortal();
2981             sv_upgrade(lv, SVt_PVLV);
2982             LvTYPE(lv) = 'y';
2983             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2984             LvTARG(lv) = SvREFCNT_inc_simple(av);
2985             LvTARGOFF(lv) = elem;
2986             LvTARGLEN(lv) = 1;
2987             PUSHs(lv);
2988             RETURN;
2989         }
2990         if (PL_op->op_private & OPpLVAL_INTRO)
2991             save_aelem(av, elem, svp);
2992         else if (PL_op->op_private & OPpDEREF)
2993             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2994     }
2995     sv = (svp ? *svp : &PL_sv_undef);
2996     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2997         sv = sv_mortalcopy(sv);
2998     PUSHs(sv);
2999     RETURN;
3000 }
3001
3002 void
3003 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3004 {
3005     SvGETMAGIC(sv);
3006     if (!SvOK(sv)) {
3007         if (SvREADONLY(sv))
3008             Perl_croak(aTHX_ PL_no_modify);
3009         if (SvTYPE(sv) < SVt_RV)
3010             sv_upgrade(sv, SVt_RV);
3011         else if (SvTYPE(sv) >= SVt_PV) {
3012             SvPV_free(sv);
3013             SvLEN_set(sv, 0);
3014             SvCUR_set(sv, 0);
3015         }
3016         switch (to_what) {
3017         case OPpDEREF_SV:
3018             SvRV_set(sv, newSV(0));
3019             break;
3020         case OPpDEREF_AV:
3021             SvRV_set(sv, (SV*)newAV());
3022             break;
3023         case OPpDEREF_HV:
3024             SvRV_set(sv, (SV*)newHV());
3025             break;
3026         }
3027         SvROK_on(sv);
3028         SvSETMAGIC(sv);
3029     }
3030 }
3031
3032 PP(pp_method)
3033 {
3034     dVAR; dSP;
3035     SV* const sv = TOPs;
3036
3037     if (SvROK(sv)) {
3038         SV* const rsv = SvRV(sv);
3039         if (SvTYPE(rsv) == SVt_PVCV) {
3040             SETs(rsv);
3041             RETURN;
3042         }
3043     }
3044
3045     SETs(method_common(sv, NULL));
3046     RETURN;
3047 }
3048
3049 PP(pp_method_named)
3050 {
3051     dVAR; dSP;
3052     SV* const sv = cSVOP_sv;
3053     U32 hash = SvSHARED_HASH(sv);
3054
3055     XPUSHs(method_common(sv, &hash));
3056     RETURN;
3057 }
3058
3059 STATIC SV *
3060 S_method_common(pTHX_ SV* meth, U32* hashp)
3061 {
3062     dVAR;
3063     SV* ob;
3064     GV* gv;
3065     HV* stash;
3066     STRLEN namelen;
3067     const char* packname = NULL;
3068     SV *packsv = NULL;
3069     STRLEN packlen;
3070     const char * const name = SvPV_const(meth, namelen);
3071     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3072
3073     if (!sv)
3074         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3075
3076     SvGETMAGIC(sv);
3077     if (SvROK(sv))
3078         ob = (SV*)SvRV(sv);
3079     else {
3080         GV* iogv;
3081
3082         /* this isn't a reference */
3083         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3084           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3085           if (he) {
3086             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3087             goto fetch;
3088           }
3089         }
3090
3091         if (!SvOK(sv) ||
3092             !(packname) ||
3093             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3094             !(ob=(SV*)GvIO(iogv)))
3095         {
3096             /* this isn't the name of a filehandle either */
3097             if (!packname ||
3098                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3099                     ? !isIDFIRST_utf8((U8*)packname)
3100                     : !isIDFIRST(*packname)
3101                 ))
3102             {
3103                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3104                            SvOK(sv) ? "without a package or object reference"
3105                                     : "on an undefined value");
3106             }
3107             /* assume it's a package name */
3108             stash = gv_stashpvn(packname, packlen, FALSE);
3109             if (!stash)
3110                 packsv = sv;
3111             else {
3112                 SV* const ref = newSViv(PTR2IV(stash));
3113                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3114             }
3115             goto fetch;
3116         }
3117         /* it _is_ a filehandle name -- replace with a reference */
3118         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3119     }
3120
3121     /* if we got here, ob should be a reference or a glob */
3122     if (!ob || !(SvOBJECT(ob)
3123                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3124                      && SvOBJECT(ob))))
3125     {
3126         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3127                    name);
3128     }
3129
3130     stash = SvSTASH(ob);
3131
3132   fetch:
3133     /* NOTE: stash may be null, hope hv_fetch_ent and
3134        gv_fetchmethod can cope (it seems they can) */
3135
3136     /* shortcut for simple names */
3137     if (hashp) {
3138         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3139         if (he) {
3140             gv = (GV*)HeVAL(he);
3141             if (isGV(gv) && GvCV(gv) &&
3142                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3143                 return (SV*)GvCV(gv);
3144         }
3145     }
3146
3147     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3148
3149     if (!gv) {
3150         /* This code tries to figure out just what went wrong with
3151            gv_fetchmethod.  It therefore needs to duplicate a lot of
3152            the internals of that function.  We can't move it inside
3153            Perl_gv_fetchmethod_autoload(), however, since that would
3154            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3155            don't want that.
3156         */
3157         const char* leaf = name;
3158         const char* sep = NULL;
3159         const char* p;
3160
3161         for (p = name; *p; p++) {
3162             if (*p == '\'')
3163                 sep = p, leaf = p + 1;
3164             else if (*p == ':' && *(p + 1) == ':')
3165                 sep = p, leaf = p + 2;
3166         }
3167         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3168             /* the method name is unqualified or starts with SUPER:: */
3169             bool need_strlen = 1;
3170             if (sep) {
3171                 packname = CopSTASHPV(PL_curcop);
3172             }
3173             else if (stash) {
3174                 HEK * const packhek = HvNAME_HEK(stash);
3175                 if (packhek) {
3176                     packname = HEK_KEY(packhek);
3177                     packlen = HEK_LEN(packhek);
3178                     need_strlen = 0;
3179                 } else {
3180                     goto croak;
3181                 }
3182             }
3183
3184             if (!packname) {
3185             croak:
3186                 Perl_croak(aTHX_
3187                            "Can't use anonymous symbol table for method lookup");
3188             }
3189             else if (need_strlen)
3190                 packlen = strlen(packname);
3191
3192         }
3193         else {
3194             /* the method name is qualified */
3195             packname = name;
3196             packlen = sep - name;
3197         }
3198
3199         /* we're relying on gv_fetchmethod not autovivifying the stash */
3200         if (gv_stashpvn(packname, packlen, FALSE)) {
3201             Perl_croak(aTHX_
3202                        "Can't locate object method \"%s\" via package \"%.*s\"",
3203                        leaf, (int)packlen, packname);
3204         }
3205         else {
3206             Perl_croak(aTHX_
3207                        "Can't locate object method \"%s\" via package \"%.*s\""
3208                        " (perhaps you forgot to load \"%.*s\"?)",
3209                        leaf, (int)packlen, packname, (int)packlen, packname);
3210         }
3211     }
3212     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3213 }
3214
3215 /*
3216  * Local variables:
3217  * c-indentation-style: bsd
3218  * c-basic-offset: 4
3219  * indent-tabs-mode: t
3220  * End:
3221  *
3222  * ex: set ts=8 sts=4 sw=4 noet:
3223  */