pp_hot.c

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