pp_hot.c

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