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             sv_unref(sv);
1645         else if (isGV_with_GP(sv)) {
1646             SvPV_force_nolen(sv);
1647         }
1648         SvUPGRADE(sv, SVt_PV);
1649         tmplen = SvLEN(sv);     /* remember if already alloced */
1650         if (!tmplen && !SvREADONLY(sv))
1651             Sv_Grow(sv, 80);    /* try short-buffering it */
1652         offset = 0;
1653         if (type == OP_RCATLINE && SvOK(sv)) {
1654             if (!SvPOK(sv)) {
1655                 SvPV_force_nolen(sv);
1656             }
1657             offset = SvCUR(sv);
1658         }
1659     }
1660     else {
1661         sv = sv_2mortal(newSV(80));
1662         offset = 0;
1663     }
1664
1665     /* This should not be marked tainted if the fp is marked clean */
1666 #define MAYBE_TAINT_LINE(io, sv) \
1667     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1668         TAINT;                          \
1669         SvTAINTED_on(sv);               \
1670     }
1671
1672 /* delay EOF state for a snarfed empty file */
1673 #define SNARF_EOF(gimme,rs,io,sv) \
1674     (gimme != G_SCALAR || SvCUR(sv)                                     \
1675      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1676
1677     for (;;) {
1678         PUTBACK;
1679         if (!sv_gets(sv, fp, offset)
1680             && (type == OP_GLOB
1681                 || SNARF_EOF(gimme, PL_rs, io, sv)
1682                 || PerlIO_error(fp)))
1683         {
1684             PerlIO_clearerr(fp);
1685             if (IoFLAGS(io) & IOf_ARGV) {
1686                 fp = nextargv(PL_last_in_gv);
1687                 if (fp)
1688                     continue;
1689                 (void)do_close(PL_last_in_gv, FALSE);
1690             }
1691             else if (type == OP_GLOB) {
1692                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1693                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1694                            "glob failed (child exited with status %d%s)",
1695                            (int)(STATUS_CURRENT >> 8),
1696                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1697                 }
1698             }
1699             if (gimme == G_SCALAR) {
1700                 if (type != OP_RCATLINE) {
1701                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1702                     SvOK_off(TARG);
1703                 }
1704                 SPAGAIN;
1705                 PUSHTARG;
1706             }
1707             MAYBE_TAINT_LINE(io, sv);
1708             RETURN;
1709         }
1710         MAYBE_TAINT_LINE(io, sv);
1711         IoLINES(io)++;
1712         IoFLAGS(io) |= IOf_NOLINE;
1713         SvSETMAGIC(sv);
1714         SPAGAIN;
1715         XPUSHs(sv);
1716         if (type == OP_GLOB) {
1717             const char *t1;
1718
1719             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1720                 char * const tmps = SvEND(sv) - 1;
1721                 if (*tmps == *SvPVX_const(PL_rs)) {
1722                     *tmps = '\0';
1723                     SvCUR_set(sv, SvCUR(sv) - 1);
1724                 }
1725             }
1726             for (t1 = SvPVX_const(sv); *t1; t1++)
1727                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1728                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1729                         break;
1730             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1731                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1732                 continue;
1733             }
1734         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1735              if (ckWARN(WARN_UTF8)) {
1736                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1737                 const STRLEN len = SvCUR(sv) - offset;
1738                 const U8 *f;
1739
1740                 if (!is_utf8_string_loc(s, len, &f))
1741                     /* Emulate :encoding(utf8) warning in the same case. */
1742                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1743                                 "utf8 \"\\x%02X\" does not map to Unicode",
1744                                 f < (U8*)SvEND(sv) ? *f : 0);
1745              }
1746         }
1747         if (gimme == G_ARRAY) {
1748             if (SvLEN(sv) - SvCUR(sv) > 20) {
1749                 SvPV_shrink_to_cur(sv);
1750             }
1751             sv = sv_2mortal(newSV(80));
1752             continue;
1753         }
1754         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1755             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1756             const STRLEN new_len
1757                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1758             SvPV_renew(sv, new_len);
1759         }
1760         RETURN;
1761     }
1762 }
1763
1764 PP(pp_enter)
1765 {
1766     dVAR; dSP;
1767     register PERL_CONTEXT *cx;
1768     I32 gimme = OP_GIMME(PL_op, -1);
1769
1770     if (gimme == -1) {
1771         if (cxstack_ix >= 0)
1772             gimme = cxstack[cxstack_ix].blk_gimme;
1773         else
1774             gimme = G_SCALAR;
1775     }
1776
1777     ENTER;
1778
1779     SAVETMPS;
1780     PUSHBLOCK(cx, CXt_BLOCK, SP);
1781
1782     RETURN;
1783 }
1784
1785 PP(pp_helem)
1786 {
1787     dVAR; dSP;
1788     HE* he;
1789     SV **svp;
1790     SV * const keysv = POPs;
1791     HV * const hv = (HV*)POPs;
1792     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1793     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1794     SV *sv;
1795     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1796     I32 preeminent = 0;
1797
1798     if (SvTYPE(hv) != SVt_PVHV)
1799         RETPUSHUNDEF;
1800
1801     if (PL_op->op_private & OPpLVAL_INTRO) {
1802         MAGIC *mg;
1803         HV *stash;
1804         /* does the element we're localizing already exist? */
1805         preeminent = /* can we determine whether it exists? */
1806             (    !SvRMAGICAL(hv)
1807                 || mg_find((SV*)hv, PERL_MAGIC_env)
1808                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1809                         /* Try to preserve the existenceness of a tied hash
1810                         * element by using EXISTS and DELETE if possible.
1811                         * Fallback to FETCH and STORE otherwise */
1812                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1813                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1814                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1815                 )
1816             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1817     }
1818     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1819     svp = he ? &HeVAL(he) : NULL;
1820     if (lval) {
1821         if (!svp || *svp == &PL_sv_undef) {
1822             SV* lv;
1823             SV* key2;
1824             if (!defer) {
1825                 DIE(aTHX_ PL_no_helem_sv, keysv);
1826             }
1827             lv = sv_newmortal();
1828             sv_upgrade(lv, SVt_PVLV);
1829             LvTYPE(lv) = 'y';
1830             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1831             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1832             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1833             LvTARGLEN(lv) = 1;
1834             PUSHs(lv);
1835             RETURN;
1836         }
1837         if (PL_op->op_private & OPpLVAL_INTRO) {
1838             if (HvNAME_get(hv) && isGV(*svp))
1839                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1840             else {
1841                 if (!preeminent) {
1842                     STRLEN keylen;
1843                     const char * const key = SvPV_const(keysv, keylen);
1844                     SAVEDELETE(hv, savepvn(key,keylen),
1845                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1846                 } else
1847                     save_helem(hv, keysv, svp);
1848             }
1849         }
1850         else if (PL_op->op_private & OPpDEREF)
1851             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1852     }
1853     sv = (svp ? *svp : &PL_sv_undef);
1854     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1855      * Pushing the magical RHS on to the stack is useless, since
1856      * that magic is soon destined to be misled by the local(),
1857      * and thus the later pp_sassign() will fail to mg_get() the
1858      * old value.  This should also cure problems with delayed
1859      * mg_get()s.  GSAR 98-07-03 */
1860     if (!lval && SvGMAGICAL(sv))
1861         sv = sv_mortalcopy(sv);
1862     PUSHs(sv);
1863     RETURN;
1864 }
1865
1866 PP(pp_leave)
1867 {
1868     dVAR; dSP;
1869     register PERL_CONTEXT *cx;
1870     SV **newsp;
1871     PMOP *newpm;
1872     I32 gimme;
1873
1874     if (PL_op->op_flags & OPf_SPECIAL) {
1875         cx = &cxstack[cxstack_ix];
1876         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1877     }
1878
1879     POPBLOCK(cx,newpm);
1880
1881     gimme = OP_GIMME(PL_op, -1);
1882     if (gimme == -1) {
1883         if (cxstack_ix >= 0)
1884             gimme = cxstack[cxstack_ix].blk_gimme;
1885         else
1886             gimme = G_SCALAR;
1887     }
1888
1889     TAINT_NOT;
1890     if (gimme == G_VOID)
1891         SP = newsp;
1892     else if (gimme == G_SCALAR) {
1893         register SV **mark;
1894         MARK = newsp + 1;
1895         if (MARK <= SP) {
1896             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1897                 *MARK = TOPs;
1898             else
1899                 *MARK = sv_mortalcopy(TOPs);
1900         } else {
1901             MEXTEND(mark,0);
1902             *MARK = &PL_sv_undef;
1903         }
1904         SP = MARK;
1905     }
1906     else if (gimme == G_ARRAY) {
1907         /* in case LEAVE wipes old return values */
1908         register SV **mark;
1909         for (mark = newsp + 1; mark <= SP; mark++) {
1910             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1911                 *mark = sv_mortalcopy(*mark);
1912                 TAINT_NOT;      /* Each item is independent */
1913             }
1914         }
1915     }
1916     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1917
1918     LEAVE;
1919
1920     RETURN;
1921 }
1922
1923 PP(pp_iter)
1924 {
1925     dVAR; dSP;
1926     register PERL_CONTEXT *cx;
1927     SV *sv, *oldsv;
1928     AV* av;
1929     SV **itersvp;
1930
1931     EXTEND(SP, 1);
1932     cx = &cxstack[cxstack_ix];
1933     if (CxTYPE(cx) != CXt_LOOP)
1934         DIE(aTHX_ "panic: pp_iter");
1935
1936     itersvp = CxITERVAR(cx);
1937     av = cx->blk_loop.iterary;
1938     if (SvTYPE(av) != SVt_PVAV) {
1939         /* iterate ($min .. $max) */
1940         if (cx->blk_loop.iterlval) {
1941             /* string increment */
1942             register SV* cur = cx->blk_loop.iterlval;
1943             STRLEN maxlen = 0;
1944             const char *max =
1945               SvOK((SV*)av) ?
1946               SvPV_const((SV*)av, maxlen) : (const char *)"";
1947             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1948                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1949                     /* safe to reuse old SV */
1950                     sv_setsv(*itersvp, cur);
1951                 }
1952                 else
1953                 {
1954                     /* we need a fresh SV every time so that loop body sees a
1955                      * completely new SV for closures/references to work as
1956                      * they used to */
1957                     oldsv = *itersvp;
1958                     *itersvp = newSVsv(cur);
1959                     SvREFCNT_dec(oldsv);
1960                 }
1961                 if (strEQ(SvPVX_const(cur), max))
1962                     sv_setiv(cur, 0); /* terminate next time */
1963                 else
1964                     sv_inc(cur);
1965                 RETPUSHYES;
1966             }
1967             RETPUSHNO;
1968         }
1969         /* integer increment */
1970         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1971             RETPUSHNO;
1972
1973         /* don't risk potential race */
1974         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1975             /* safe to reuse old SV */
1976             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1977         }
1978         else
1979         {
1980             /* we need a fresh SV every time so that loop body sees a
1981              * completely new SV for closures/references to work as they
1982              * used to */
1983             oldsv = *itersvp;
1984             *itersvp = newSViv(cx->blk_loop.iterix++);
1985             SvREFCNT_dec(oldsv);
1986         }
1987         RETPUSHYES;
1988     }
1989
1990     /* iterate array */
1991     if (PL_op->op_private & OPpITER_REVERSED) {
1992         /* In reverse, use itermax as the min :-)  */
1993         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1994             RETPUSHNO;
1995
1996         if (SvMAGICAL(av) || AvREIFY(av)) {
1997             SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1998             sv = svp ? *svp : NULL;
1999         }
2000         else {
2001             sv = AvARRAY(av)[--cx->blk_loop.iterix];
2002         }
2003     }
2004     else {
2005         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
2006                                     AvFILL(av)))
2007             RETPUSHNO;
2008
2009         if (SvMAGICAL(av) || AvREIFY(av)) {
2010             SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
2011             sv = svp ? *svp : NULL;
2012         }
2013         else {
2014             sv = AvARRAY(av)[++cx->blk_loop.iterix];
2015         }
2016     }
2017
2018     if (sv && SvIS_FREED(sv)) {
2019         *itersvp = NULL;
2020         Perl_croak(aTHX_ "Use of freed value in iteration");
2021     }
2022
2023     if (sv)
2024         SvTEMP_off(sv);
2025     else
2026         sv = &PL_sv_undef;
2027     if (av != PL_curstack && sv == &PL_sv_undef) {
2028         SV *lv = cx->blk_loop.iterlval;
2029         if (lv && SvREFCNT(lv) > 1) {
2030             SvREFCNT_dec(lv);
2031             lv = NULL;
2032         }
2033         if (lv)
2034             SvREFCNT_dec(LvTARG(lv));
2035         else {
2036             lv = cx->blk_loop.iterlval = newSV(0);
2037             sv_upgrade(lv, SVt_PVLV);
2038             LvTYPE(lv) = 'y';
2039             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2040         }
2041         LvTARG(lv) = SvREFCNT_inc_simple(av);
2042         LvTARGOFF(lv) = cx->blk_loop.iterix;
2043         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2044         sv = (SV*)lv;
2045     }
2046
2047     oldsv = *itersvp;
2048     *itersvp = SvREFCNT_inc_simple_NN(sv);
2049     SvREFCNT_dec(oldsv);
2050
2051     RETPUSHYES;
2052 }
2053
2054 PP(pp_subst)
2055 {
2056     dVAR; dSP; dTARG;
2057     register PMOP *pm = cPMOP;
2058     PMOP *rpm = pm;
2059     register char *s;
2060     char *strend;
2061     register char *m;
2062     const char *c;
2063     register char *d;
2064     STRLEN clen;
2065     I32 iters = 0;
2066     I32 maxiters;
2067     register I32 i;
2068     bool once;
2069     bool rxtainted;
2070     char *orig;
2071     I32 r_flags;
2072     register REGEXP *rx = PM_GETRE(pm);
2073     STRLEN len;
2074     int force_on_match = 0;
2075     const I32 oldsave = PL_savestack_ix;
2076     STRLEN slen;
2077     bool doutf8 = FALSE;
2078 #ifdef PERL_OLD_COPY_ON_WRITE
2079     bool is_cow;
2080 #endif
2081     SV *nsv = NULL;
2082
2083     /* known replacement string? */
2084     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2085     if (PL_op->op_flags & OPf_STACKED)
2086         TARG = POPs;
2087     else if (PL_op->op_private & OPpTARGET_MY)
2088         GETTARGET;
2089     else {
2090         TARG = DEFSV;
2091         EXTEND(SP,1);
2092     }
2093
2094 #ifdef PERL_OLD_COPY_ON_WRITE
2095     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2096        because they make integers such as 256 "false".  */
2097     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2098 #else
2099     if (SvIsCOW(TARG))
2100         sv_force_normal_flags(TARG,0);
2101 #endif
2102     if (
2103 #ifdef PERL_OLD_COPY_ON_WRITE
2104         !is_cow &&
2105 #endif
2106         (SvREADONLY(TARG)
2107         || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2108              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2109         DIE(aTHX_ PL_no_modify);
2110     PUTBACK;
2111
2112     s = SvPV_mutable(TARG, len);
2113     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2114         force_on_match = 1;
2115     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2116                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2117     if (PL_tainted)
2118         rxtainted |= 2;
2119     TAINT_NOT;
2120
2121     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2122
2123   force_it:
2124     if (!pm || !s)
2125         DIE(aTHX_ "panic: pp_subst");
2126
2127     strend = s + len;
2128     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2129     maxiters = 2 * slen + 10;   /* We can match twice at each
2130                                    position, once with zero-length,
2131                                    second time with non-zero. */
2132
2133     if (!rx->prelen && PL_curpm) {
2134         pm = PL_curpm;
2135         rx = PM_GETRE(pm);
2136     }
2137     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2138             || (pm->op_pmflags & PMf_EVAL))
2139                ? REXEC_COPY_STR : 0;
2140     if (SvSCREAM(TARG))
2141         r_flags |= REXEC_SCREAM;
2142
2143     orig = m = s;
2144     if (rx->reganch & RE_USE_INTUIT) {
2145         PL_bostr = orig;
2146         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2147
2148         if (!s)
2149             goto nope;
2150         /* How to do it in subst? */
2151 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2152              && !PL_sawampersand
2153              && ((rx->reganch & ROPT_NOSCAN)
2154                  || !((rx->reganch & RE_INTUIT_TAIL)
2155                       && (r_flags & REXEC_SCREAM))))
2156             goto yup;
2157 */
2158     }
2159
2160     /* only replace once? */
2161     once = !(rpm->op_pmflags & PMf_GLOBAL);
2162
2163     /* known replacement string? */
2164     if (dstr) {
2165         /* replacement needing upgrading? */
2166         if (DO_UTF8(TARG) && !doutf8) {
2167              nsv = sv_newmortal();
2168              SvSetSV(nsv, dstr);
2169              if (PL_encoding)
2170                   sv_recode_to_utf8(nsv, PL_encoding);
2171              else
2172                   sv_utf8_upgrade(nsv);
2173              c = SvPV_const(nsv, clen);
2174              doutf8 = TRUE;
2175         }
2176         else {
2177             c = SvPV_const(dstr, clen);
2178             doutf8 = DO_UTF8(dstr);
2179         }
2180     }
2181     else {
2182         c = NULL;
2183         doutf8 = FALSE;
2184     }
2185
2186     /* can do inplace substitution? */
2187     if (c
2188 #ifdef PERL_OLD_COPY_ON_WRITE
2189         && !is_cow
2190 #endif
2191         && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2192         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2193         && (!doutf8 || SvUTF8(TARG))) {
2194         if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2195                          r_flags | REXEC_CHECKED))
2196         {
2197             SPAGAIN;
2198             PUSHs(&PL_sv_no);
2199             LEAVE_SCOPE(oldsave);
2200             RETURN;
2201         }
2202 #ifdef PERL_OLD_COPY_ON_WRITE
2203         if (SvIsCOW(TARG)) {
2204             assert (!force_on_match);
2205             goto have_a_cow;
2206         }
2207 #endif
2208         if (force_on_match) {
2209             force_on_match = 0;
2210             s = SvPV_force(TARG, len);
2211             goto force_it;
2212         }
2213         d = s;
2214         PL_curpm = pm;
2215         SvSCREAM_off(TARG);     /* disable possible screamer */
2216         if (once) {
2217             rxtainted |= RX_MATCH_TAINTED(rx);
2218             m = orig + rx->startp[0];
2219             d = orig + rx->endp[0];
2220             s = orig;
2221             if (m - s > strend - d) {  /* faster to shorten from end */
2222                 if (clen) {
2223                     Copy(c, m, clen, char);
2224                     m += clen;
2225                 }
2226                 i = strend - d;
2227                 if (i > 0) {
2228                     Move(d, m, i, char);
2229                     m += i;
2230                 }
2231                 *m = '\0';
2232                 SvCUR_set(TARG, m - s);
2233             }
2234             else if ((i = m - s)) {     /* faster from front */
2235                 d -= clen;
2236                 m = d;
2237                 sv_chop(TARG, d-i);
2238                 s += i;
2239                 while (i--)
2240                     *--d = *--s;
2241                 if (clen)
2242                     Copy(c, m, clen, char);
2243             }
2244             else if (clen) {
2245                 d -= clen;
2246                 sv_chop(TARG, d);
2247                 Copy(c, d, clen, char);
2248             }
2249             else {
2250                 sv_chop(TARG, d);
2251             }
2252             TAINT_IF(rxtainted & 1);
2253             SPAGAIN;
2254             PUSHs(&PL_sv_yes);
2255         }
2256         else {
2257             do {
2258                 if (iters++ > maxiters)
2259                     DIE(aTHX_ "Substitution loop");
2260                 rxtainted |= RX_MATCH_TAINTED(rx);
2261                 m = rx->startp[0] + orig;
2262                 if ((i = m - s)) {
2263                     if (s != d)
2264                         Move(s, d, i, char);
2265                     d += i;
2266                 }
2267                 if (clen) {
2268                     Copy(c, d, clen, char);
2269                     d += clen;
2270                 }
2271                 s = rx->endp[0] + orig;
2272             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2273                                  TARG, NULL,
2274                                  /* don't match same null twice */
2275                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2276             if (s != d) {
2277                 i = strend - s;
2278                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2279                 Move(s, d, i+1, char);          /* include the NUL */
2280             }
2281             TAINT_IF(rxtainted & 1);
2282             SPAGAIN;
2283             PUSHs(sv_2mortal(newSViv((I32)iters)));
2284         }
2285         (void)SvPOK_only_UTF8(TARG);
2286         TAINT_IF(rxtainted);
2287         if (SvSMAGICAL(TARG)) {
2288             PUTBACK;
2289             mg_set(TARG);
2290             SPAGAIN;
2291         }
2292         SvTAINT(TARG);
2293         if (doutf8)
2294             SvUTF8_on(TARG);
2295         LEAVE_SCOPE(oldsave);
2296         RETURN;
2297     }
2298
2299     if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2300                     r_flags | REXEC_CHECKED))
2301     {
2302         if (force_on_match) {
2303             force_on_match = 0;
2304             s = SvPV_force(TARG, len);
2305             goto force_it;
2306         }
2307 #ifdef PERL_OLD_COPY_ON_WRITE
2308       have_a_cow:
2309 #endif
2310         rxtainted |= RX_MATCH_TAINTED(rx);
2311         dstr = newSVpvn(m, s-m);
2312         SAVEFREESV(dstr);
2313         if (DO_UTF8(TARG))
2314             SvUTF8_on(dstr);
2315         PL_curpm = pm;
2316         if (!c) {
2317             register PERL_CONTEXT *cx;
2318             SPAGAIN;
2319             PUSHSUBST(cx);
2320             RETURNOP(cPMOP->op_pmreplroot);
2321         }
2322         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2323         do {
2324             if (iters++ > maxiters)
2325                 DIE(aTHX_ "Substitution loop");
2326             rxtainted |= RX_MATCH_TAINTED(rx);
2327             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2328                 m = s;
2329                 s = orig;
2330                 orig = rx->subbeg;
2331                 s = orig + (m - s);
2332                 strend = s + (strend - m);
2333             }
2334             m = rx->startp[0] + orig;
2335             if (doutf8 && !SvUTF8(dstr))
2336                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2337             else
2338                 sv_catpvn(dstr, s, m-s);
2339             s = rx->endp[0] + orig;
2340             if (clen)
2341                 sv_catpvn(dstr, c, clen);
2342             if (once)
2343                 break;
2344         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2345                              TARG, NULL, r_flags));
2346         if (doutf8 && !DO_UTF8(TARG))
2347             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2348         else
2349             sv_catpvn(dstr, s, strend - s);
2350
2351 #ifdef PERL_OLD_COPY_ON_WRITE
2352         /* The match may make the string COW. If so, brilliant, because that's
2353            just saved us one malloc, copy and free - the regexp has donated
2354            the old buffer, and we malloc an entirely new one, rather than the
2355            regexp malloc()ing a buffer and copying our original, only for
2356            us to throw it away here during the substitution.  */
2357         if (SvIsCOW(TARG)) {
2358             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2359         } else
2360 #endif
2361         {
2362             SvPV_free(TARG);
2363         }
2364         SvPV_set(TARG, SvPVX(dstr));
2365         SvCUR_set(TARG, SvCUR(dstr));
2366         SvLEN_set(TARG, SvLEN(dstr));
2367         doutf8 |= DO_UTF8(dstr);
2368         SvPV_set(dstr, NULL);
2369
2370         TAINT_IF(rxtainted & 1);
2371         SPAGAIN;
2372         PUSHs(sv_2mortal(newSViv((I32)iters)));
2373
2374         (void)SvPOK_only(TARG);
2375         if (doutf8)
2376             SvUTF8_on(TARG);
2377         TAINT_IF(rxtainted);
2378         SvSETMAGIC(TARG);
2379         SvTAINT(TARG);
2380         LEAVE_SCOPE(oldsave);
2381         RETURN;
2382     }
2383     goto ret_no;
2384
2385 nope:
2386 ret_no:
2387     SPAGAIN;
2388     PUSHs(&PL_sv_no);
2389     LEAVE_SCOPE(oldsave);
2390     RETURN;
2391 }
2392
2393 PP(pp_grepwhile)
2394 {
2395     dVAR; dSP;
2396
2397     if (SvTRUEx(POPs))
2398         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2399     ++*PL_markstack_ptr;
2400     LEAVE;                                      /* exit inner scope */
2401
2402     /* All done yet? */
2403     if (PL_stack_base + *PL_markstack_ptr > SP) {
2404         I32 items;
2405         const I32 gimme = GIMME_V;
2406
2407         LEAVE;                                  /* exit outer scope */
2408         (void)POPMARK;                          /* pop src */
2409         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2410         (void)POPMARK;                          /* pop dst */
2411         SP = PL_stack_base + POPMARK;           /* pop original mark */
2412         if (gimme == G_SCALAR) {
2413             if (PL_op->op_private & OPpGREP_LEX) {
2414                 SV* const sv = sv_newmortal();
2415                 sv_setiv(sv, items);
2416                 PUSHs(sv);
2417             }
2418             else {
2419                 dTARGET;
2420                 XPUSHi(items);
2421             }
2422         }
2423         else if (gimme == G_ARRAY)
2424             SP += items;
2425         RETURN;
2426     }
2427     else {
2428         SV *src;
2429
2430         ENTER;                                  /* enter inner scope */
2431         SAVEVPTR(PL_curpm);
2432
2433         src = PL_stack_base[*PL_markstack_ptr];
2434         SvTEMP_off(src);
2435         if (PL_op->op_private & OPpGREP_LEX)
2436             PAD_SVl(PL_op->op_targ) = src;
2437         else
2438             DEFSV = src;
2439
2440         RETURNOP(cLOGOP->op_other);
2441     }
2442 }
2443
2444 PP(pp_leavesub)
2445 {
2446     dVAR; dSP;
2447     SV **mark;
2448     SV **newsp;
2449     PMOP *newpm;
2450     I32 gimme;
2451     register PERL_CONTEXT *cx;
2452     SV *sv;
2453
2454     if (CxMULTICALL(&cxstack[cxstack_ix]))
2455         return 0;
2456
2457     POPBLOCK(cx,newpm);
2458     cxstack_ix++; /* temporarily protect top context */
2459
2460     TAINT_NOT;
2461     if (gimme == G_SCALAR) {
2462         MARK = newsp + 1;
2463         if (MARK <= SP) {
2464             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2465                 if (SvTEMP(TOPs)) {
2466                     *MARK = SvREFCNT_inc(TOPs);
2467                     FREETMPS;
2468                     sv_2mortal(*MARK);
2469                 }
2470                 else {
2471                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2472                     FREETMPS;
2473                     *MARK = sv_mortalcopy(sv);
2474                     SvREFCNT_dec(sv);
2475                 }
2476             }
2477             else
2478                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2479         }
2480         else {
2481             MEXTEND(MARK, 0);
2482             *MARK = &PL_sv_undef;
2483         }
2484         SP = MARK;
2485     }
2486     else if (gimme == G_ARRAY) {
2487         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2488             if (!SvTEMP(*MARK)) {
2489                 *MARK = sv_mortalcopy(*MARK);
2490                 TAINT_NOT;      /* Each item is independent */
2491             }
2492         }
2493     }
2494     PUTBACK;
2495
2496     LEAVE;
2497     cxstack_ix--;
2498     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2499     PL_curpm = newpm;   /* ... and pop $1 et al */
2500
2501     LEAVESUB(sv);
2502     return cx->blk_sub.retop;
2503 }
2504
2505 /* This duplicates the above code because the above code must not
2506  * get any slower by more conditions */
2507 PP(pp_leavesublv)
2508 {
2509     dVAR; dSP;
2510     SV **mark;
2511     SV **newsp;
2512     PMOP *newpm;
2513     I32 gimme;
2514     register PERL_CONTEXT *cx;
2515     SV *sv;
2516
2517     if (CxMULTICALL(&cxstack[cxstack_ix]))
2518         return 0;
2519
2520     POPBLOCK(cx,newpm);
2521     cxstack_ix++; /* temporarily protect top context */
2522
2523     TAINT_NOT;
2524
2525     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2526         /* We are an argument to a function or grep().
2527          * This kind of lvalueness was legal before lvalue
2528          * subroutines too, so be backward compatible:
2529          * cannot report errors.  */
2530
2531         /* Scalar context *is* possible, on the LHS of -> only,
2532          * as in f()->meth().  But this is not an lvalue. */
2533         if (gimme == G_SCALAR)
2534             goto temporise;
2535         if (gimme == G_ARRAY) {
2536             if (!CvLVALUE(cx->blk_sub.cv))
2537                 goto temporise_array;
2538             EXTEND_MORTAL(SP - newsp);
2539             for (mark = newsp + 1; mark <= SP; mark++) {
2540                 if (SvTEMP(*mark))
2541                     NOOP;
2542                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2543                     *mark = sv_mortalcopy(*mark);
2544                 else {
2545                     /* Can be a localized value subject to deletion. */
2546                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2547                     SvREFCNT_inc_void(*mark);
2548                 }
2549             }
2550         }
2551     }
2552     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2553         /* Here we go for robustness, not for speed, so we change all
2554          * the refcounts so the caller gets a live guy. Cannot set
2555          * TEMP, so sv_2mortal is out of question. */
2556         if (!CvLVALUE(cx->blk_sub.cv)) {
2557             LEAVE;
2558             cxstack_ix--;
2559             POPSUB(cx,sv);
2560             PL_curpm = newpm;
2561             LEAVESUB(sv);
2562             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2563         }
2564         if (gimme == G_SCALAR) {
2565             MARK = newsp + 1;
2566             EXTEND_MORTAL(1);
2567             if (MARK == SP) {
2568                 /* Temporaries are bad unless they happen to be elements
2569                  * of a tied hash or array */
2570                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2571                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2572                     LEAVE;
2573                     cxstack_ix--;
2574                     POPSUB(cx,sv);
2575                     PL_curpm = newpm;
2576                     LEAVESUB(sv);
2577                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2578                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2579                         : "a readonly value" : "a temporary");
2580                 }
2581                 else {                  /* Can be a localized value
2582                                          * subject to deletion. */
2583                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2584                     SvREFCNT_inc_void(*mark);
2585                 }
2586             }
2587             else {                      /* Should not happen? */
2588                 LEAVE;
2589                 cxstack_ix--;
2590                 POPSUB(cx,sv);
2591                 PL_curpm = newpm;
2592                 LEAVESUB(sv);
2593                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2594                     (MARK > SP ? "Empty array" : "Array"));
2595             }
2596             SP = MARK;
2597         }
2598         else if (gimme == G_ARRAY) {
2599             EXTEND_MORTAL(SP - newsp);
2600             for (mark = newsp + 1; mark <= SP; mark++) {
2601                 if (*mark != &PL_sv_undef
2602                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2603                     /* Might be flattened array after $#array =  */
2604                     PUTBACK;
2605                     LEAVE;
2606                     cxstack_ix--;
2607                     POPSUB(cx,sv);
2608                     PL_curpm = newpm;
2609                     LEAVESUB(sv);
2610                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2611                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2612                 }
2613                 else {
2614                     /* Can be a localized value subject to deletion. */
2615                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2616                     SvREFCNT_inc_void(*mark);
2617                 }
2618             }
2619         }
2620     }
2621     else {
2622         if (gimme == G_SCALAR) {
2623           temporise:
2624             MARK = newsp + 1;
2625             if (MARK <= SP) {
2626                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2627                     if (SvTEMP(TOPs)) {
2628                         *MARK = SvREFCNT_inc(TOPs);
2629                         FREETMPS;
2630                         sv_2mortal(*MARK);
2631                     }
2632                     else {
2633                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2634                         FREETMPS;
2635                         *MARK = sv_mortalcopy(sv);
2636                         SvREFCNT_dec(sv);
2637                     }
2638                 }
2639                 else
2640                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2641             }
2642             else {
2643                 MEXTEND(MARK, 0);
2644                 *MARK = &PL_sv_undef;
2645             }
2646             SP = MARK;
2647         }
2648         else if (gimme == G_ARRAY) {
2649           temporise_array:
2650             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2651                 if (!SvTEMP(*MARK)) {
2652                     *MARK = sv_mortalcopy(*MARK);
2653                     TAINT_NOT;  /* Each item is independent */
2654                 }
2655             }
2656         }
2657     }
2658     PUTBACK;
2659
2660     LEAVE;
2661     cxstack_ix--;
2662     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2663     PL_curpm = newpm;   /* ... and pop $1 et al */
2664
2665     LEAVESUB(sv);
2666     return cx->blk_sub.retop;
2667 }
2668
2669
2670 STATIC CV *
2671 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2672 {
2673     dVAR;
2674     SV * const dbsv = GvSVn(PL_DBsub);
2675
2676     save_item(dbsv);
2677     if (!PERLDB_SUB_NN) {
2678         GV * const gv = CvGV(cv);
2679
2680         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2681              || strEQ(GvNAME(gv), "END")
2682              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2683                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2684             /* Use GV from the stack as a fallback. */
2685             /* GV is potentially non-unique, or contain different CV. */
2686             SV * const tmp = newRV((SV*)cv);
2687             sv_setsv(dbsv, tmp);
2688             SvREFCNT_dec(tmp);
2689         }
2690         else {
2691             gv_efullname3(dbsv, gv, NULL);
2692         }
2693     }
2694     else {
2695         const int type = SvTYPE(dbsv);
2696         if (type < SVt_PVIV && type != SVt_IV)
2697             sv_upgrade(dbsv, SVt_PVIV);
2698         (void)SvIOK_on(dbsv);
2699         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2700     }
2701
2702     if (CvISXSUB(cv))
2703         PL_curcopdb = PL_curcop;
2704     cv = GvCV(PL_DBsub);
2705     return cv;
2706 }
2707
2708 PP(pp_entersub)
2709 {
2710     dVAR; dSP; dPOPss;
2711     GV *gv;
2712     register CV *cv;
2713     register PERL_CONTEXT *cx;
2714     I32 gimme;
2715     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2716
2717     if (!sv)
2718         DIE(aTHX_ "Not a CODE reference");
2719     switch (SvTYPE(sv)) {
2720         /* This is overwhelming the most common case:  */
2721     case SVt_PVGV:
2722         if (!(cv = GvCVu((GV*)sv))) {
2723             HV *stash;
2724             cv = sv_2cv(sv, &stash, &gv, 0);
2725         }
2726         if (!cv) {
2727             ENTER;
2728             SAVETMPS;
2729             goto try_autoload;
2730         }
2731         break;
2732     default:
2733         if (!SvROK(sv)) {
2734             const char *sym;
2735             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2736                 if (hasargs)
2737                     SP = PL_stack_base + POPMARK;
2738                 RETURN;
2739             }
2740             if (SvGMAGICAL(sv)) {
2741                 mg_get(sv);
2742                 if (SvROK(sv))
2743                     goto got_rv;
2744                 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2745             }
2746             else {
2747                 sym = SvPV_nolen_const(sv);
2748             }
2749             if (!sym)
2750                 DIE(aTHX_ PL_no_usym, "a subroutine");
2751             if (PL_op->op_private & HINT_STRICT_REFS)
2752                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2753             cv = get_cv(sym, TRUE);
2754             break;
2755         }
2756   got_rv:
2757         {
2758             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2759             tryAMAGICunDEREF(to_cv);
2760         }
2761         cv = (CV*)SvRV(sv);
2762         if (SvTYPE(cv) == SVt_PVCV)
2763             break;
2764         /* FALL THROUGH */
2765     case SVt_PVHV:
2766     case SVt_PVAV:
2767         DIE(aTHX_ "Not a CODE reference");
2768         /* This is the second most common case:  */
2769     case SVt_PVCV:
2770         cv = (CV*)sv;
2771         break;
2772     }
2773
2774     ENTER;
2775     SAVETMPS;
2776
2777   retry:
2778     if (!CvROOT(cv) && !CvXSUB(cv)) {
2779         GV* autogv;
2780         SV* sub_name;
2781
2782         /* anonymous or undef'd function leaves us no recourse */
2783         if (CvANON(cv) || !(gv = CvGV(cv)))
2784             DIE(aTHX_ "Undefined subroutine called");
2785
2786         /* autoloaded stub? */
2787         if (cv != GvCV(gv)) {
2788             cv = GvCV(gv);
2789         }
2790         /* should call AUTOLOAD now? */
2791         else {
2792 try_autoload:
2793             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2794                                    FALSE)))
2795             {
2796                 cv = GvCV(autogv);
2797             }
2798             /* sorry */
2799             else {
2800                 sub_name = sv_newmortal();
2801                 gv_efullname3(sub_name, gv, NULL);
2802                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name);
2803             }
2804         }
2805         if (!cv)
2806             DIE(aTHX_ "Not a CODE reference");
2807         goto retry;
2808     }
2809
2810     gimme = GIMME_V;
2811     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2812         if (CvASSERTION(cv) && PL_DBassertion)
2813             sv_setiv(PL_DBassertion, 1);
2814
2815         cv = get_db_sub(&sv, cv);
2816         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2817             DIE(aTHX_ "No DB::sub routine defined");
2818     }
2819
2820     if (!(CvISXSUB(cv))) {
2821         /* This path taken at least 75% of the time   */
2822         dMARK;
2823         register I32 items = SP - MARK;
2824         AV* const padlist = CvPADLIST(cv);
2825         PUSHBLOCK(cx, CXt_SUB, MARK);
2826         PUSHSUB(cx);
2827         cx->blk_sub.retop = PL_op->op_next;
2828         CvDEPTH(cv)++;
2829         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2830          * that eval'' ops within this sub know the correct lexical space.
2831          * Owing the speed considerations, we choose instead to search for
2832          * the cv using find_runcv() when calling doeval().
2833          */
2834         if (CvDEPTH(cv) >= 2) {
2835             PERL_STACK_OVERFLOW_CHECK();
2836             pad_push(padlist, CvDEPTH(cv));
2837         }
2838         SAVECOMPPAD();
2839         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2840         if (hasargs) {
2841             AV* const av = (AV*)PAD_SVl(0);
2842             if (AvREAL(av)) {
2843                 /* @_ is normally not REAL--this should only ever
2844                  * happen when DB::sub() calls things that modify @_ */
2845                 av_clear(av);
2846                 AvREAL_off(av);
2847                 AvREIFY_on(av);
2848             }
2849             cx->blk_sub.savearray = GvAV(PL_defgv);
2850             GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2851             CX_CURPAD_SAVE(cx->blk_sub);
2852             cx->blk_sub.argarray = av;
2853             ++MARK;
2854
2855             if (items > AvMAX(av) + 1) {
2856                 SV **ary = AvALLOC(av);
2857                 if (AvARRAY(av) != ary) {
2858                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2859                     AvARRAY(av) = ary;
2860                 }
2861                 if (items > AvMAX(av) + 1) {
2862                     AvMAX(av) = items - 1;
2863                     Renew(ary,items,SV*);
2864                     AvALLOC(av) = ary;
2865                     AvARRAY(av) = ary;
2866                 }
2867             }
2868             Copy(MARK,AvARRAY(av),items,SV*);
2869             AvFILLp(av) = items - 1;
2870
2871             while (items--) {
2872                 if (*MARK)
2873                     SvTEMP_off(*MARK);
2874                 MARK++;
2875             }
2876         }
2877         /* warning must come *after* we fully set up the context
2878          * stuff so that __WARN__ handlers can safely dounwind()
2879          * if they want to
2880          */
2881         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2882             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2883             sub_crush_depth(cv);
2884 #if 0
2885         DEBUG_S(PerlIO_printf(Perl_debug_log,
2886                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2887 #endif
2888         RETURNOP(CvSTART(cv));
2889     }
2890     else {
2891         I32 markix = TOPMARK;
2892
2893         PUTBACK;
2894
2895         if (!hasargs) {
2896             /* Need to copy @_ to stack. Alternative may be to
2897              * switch stack to @_, and copy return values
2898              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2899             AV * const av = GvAV(PL_defgv);
2900             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2901
2902             if (items) {
2903                 /* Mark is at the end of the stack. */
2904                 EXTEND(SP, items);
2905                 Copy(AvARRAY(av), SP + 1, items, SV*);
2906                 SP += items;
2907                 PUTBACK ;
2908             }
2909         }
2910         /* We assume first XSUB in &DB::sub is the called one. */
2911         if (PL_curcopdb) {
2912             SAVEVPTR(PL_curcop);
2913             PL_curcop = PL_curcopdb;
2914             PL_curcopdb = NULL;
2915         }
2916         /* Do we need to open block here? XXXX */
2917         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2918             (void)(*CvXSUB(cv))(aTHX_ cv);
2919
2920         /* Enforce some sanity in scalar context. */
2921         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2922             if (markix > PL_stack_sp - PL_stack_base)
2923                 *(PL_stack_base + markix) = &PL_sv_undef;
2924             else
2925                 *(PL_stack_base + markix) = *PL_stack_sp;
2926             PL_stack_sp = PL_stack_base + markix;
2927         }
2928         LEAVE;
2929         return NORMAL;
2930     }
2931 }
2932
2933 void
2934 Perl_sub_crush_depth(pTHX_ CV *cv)
2935 {
2936     if (CvANON(cv))
2937         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2938     else {
2939         SV* const tmpstr = sv_newmortal();
2940         gv_efullname3(tmpstr, CvGV(cv), NULL);
2941         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2942                     (void*)tmpstr);
2943     }
2944 }
2945
2946 PP(pp_aelem)
2947 {
2948     dVAR; dSP;
2949     SV** svp;
2950     SV* const elemsv = POPs;
2951     IV elem = SvIV(elemsv);
2952     AV* const av = (AV*)POPs;
2953     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2954     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2955     SV *sv;
2956
2957     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2958         Perl_warner(aTHX_ packWARN(WARN_MISC),
2959                     "Use of reference \"%"SVf"\" as array index",
2960                     (void*)elemsv);
2961     if (elem > 0)
2962         elem -= CopARYBASE_get(PL_curcop);
2963     if (SvTYPE(av) != SVt_PVAV)
2964         RETPUSHUNDEF;
2965     svp = av_fetch(av, elem, lval && !defer);
2966     if (lval) {
2967 #ifdef PERL_MALLOC_WRAP
2968          if (SvUOK(elemsv)) {
2969               const UV uv = SvUV(elemsv);
2970               elem = uv > IV_MAX ? IV_MAX : uv;
2971          }
2972          else if (SvNOK(elemsv))
2973               elem = (IV)SvNV(elemsv);
2974          if (elem > 0) {
2975               static const char oom_array_extend[] =
2976                 "Out of memory during array extend"; /* Duplicated in av.c */
2977               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2978          }
2979 #endif
2980         if (!svp || *svp == &PL_sv_undef) {
2981             SV* lv;
2982             if (!defer)
2983                 DIE(aTHX_ PL_no_aelem, elem);
2984             lv = sv_newmortal();
2985             sv_upgrade(lv, SVt_PVLV);
2986             LvTYPE(lv) = 'y';
2987             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2988             LvTARG(lv) = SvREFCNT_inc_simple(av);
2989             LvTARGOFF(lv) = elem;
2990             LvTARGLEN(lv) = 1;
2991             PUSHs(lv);
2992             RETURN;
2993         }
2994         if (PL_op->op_private & OPpLVAL_INTRO)
2995             save_aelem(av, elem, svp);
2996         else if (PL_op->op_private & OPpDEREF)
2997             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2998     }
2999     sv = (svp ? *svp : &PL_sv_undef);
3000     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
3001         sv = sv_mortalcopy(sv);
3002     PUSHs(sv);
3003     RETURN;
3004 }
3005
3006 void
3007 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3008 {
3009     SvGETMAGIC(sv);
3010     if (!SvOK(sv)) {
3011         if (SvREADONLY(sv))
3012             Perl_croak(aTHX_ PL_no_modify);
3013         if (SvTYPE(sv) < SVt_RV)
3014             sv_upgrade(sv, SVt_RV);
3015         else if (SvTYPE(sv) >= SVt_PV) {
3016             SvPV_free(sv);
3017             SvLEN_set(sv, 0);
3018             SvCUR_set(sv, 0);
3019         }
3020         switch (to_what) {
3021         case OPpDEREF_SV:
3022             SvRV_set(sv, newSV(0));
3023             break;
3024         case OPpDEREF_AV:
3025             SvRV_set(sv, (SV*)newAV());
3026             break;
3027         case OPpDEREF_HV:
3028             SvRV_set(sv, (SV*)newHV());
3029             break;
3030         }
3031         SvROK_on(sv);
3032         SvSETMAGIC(sv);
3033     }
3034 }
3035
3036 PP(pp_method)
3037 {
3038     dVAR; dSP;
3039     SV* const sv = TOPs;
3040
3041     if (SvROK(sv)) {
3042         SV* const rsv = SvRV(sv);
3043         if (SvTYPE(rsv) == SVt_PVCV) {
3044             SETs(rsv);
3045             RETURN;
3046         }
3047     }
3048
3049     SETs(method_common(sv, NULL));
3050     RETURN;
3051 }
3052
3053 PP(pp_method_named)
3054 {
3055     dVAR; dSP;
3056     SV* const sv = cSVOP_sv;
3057     U32 hash = SvSHARED_HASH(sv);
3058
3059     XPUSHs(method_common(sv, &hash));
3060     RETURN;
3061 }
3062
3063 STATIC SV *
3064 S_method_common(pTHX_ SV* meth, U32* hashp)
3065 {
3066     dVAR;
3067     SV* ob;
3068     GV* gv;
3069     HV* stash;
3070     STRLEN namelen;
3071     const char* packname = NULL;
3072     SV *packsv = NULL;
3073     STRLEN packlen;
3074     const char * const name = SvPV_const(meth, namelen);
3075     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3076
3077     if (!sv)
3078         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3079
3080     SvGETMAGIC(sv);
3081     if (SvROK(sv))
3082         ob = (SV*)SvRV(sv);
3083     else {
3084         GV* iogv;
3085
3086         /* this isn't a reference */
3087         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3088           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3089           if (he) {
3090             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3091             goto fetch;
3092           }
3093         }
3094
3095         if (!SvOK(sv) ||
3096             !(packname) ||
3097             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3098             !(ob=(SV*)GvIO(iogv)))
3099         {
3100             /* this isn't the name of a filehandle either */
3101             if (!packname ||
3102                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3103                     ? !isIDFIRST_utf8((U8*)packname)
3104                     : !isIDFIRST(*packname)
3105                 ))
3106             {
3107                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3108                            SvOK(sv) ? "without a package or object reference"
3109                                     : "on an undefined value");
3110             }
3111             /* assume it's a package name */
3112             stash = gv_stashpvn(packname, packlen, FALSE);
3113             if (!stash)
3114                 packsv = sv;
3115             else {
3116                 SV* const ref = newSViv(PTR2IV(stash));
3117                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3118             }
3119             goto fetch;
3120         }
3121         /* it _is_ a filehandle name -- replace with a reference */
3122         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3123     }
3124
3125     /* if we got here, ob should be a reference or a glob */
3126     if (!ob || !(SvOBJECT(ob)
3127                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3128                      && SvOBJECT(ob))))
3129     {
3130         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3131                    name);
3132     }
3133
3134     stash = SvSTASH(ob);
3135
3136   fetch:
3137     /* NOTE: stash may be null, hope hv_fetch_ent and
3138        gv_fetchmethod can cope (it seems they can) */
3139
3140     /* shortcut for simple names */
3141     if (hashp) {
3142         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3143         if (he) {
3144             gv = (GV*)HeVAL(he);
3145             if (isGV(gv) && GvCV(gv) &&
3146                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3147                 return (SV*)GvCV(gv);
3148         }
3149     }
3150
3151     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3152
3153     if (!gv) {
3154         /* This code tries to figure out just what went wrong with
3155            gv_fetchmethod.  It therefore needs to duplicate a lot of
3156            the internals of that function.  We can't move it inside
3157            Perl_gv_fetchmethod_autoload(), however, since that would
3158            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3159            don't want that.
3160         */
3161         const char* leaf = name;
3162         const char* sep = NULL;
3163         const char* p;
3164
3165         for (p = name; *p; p++) {
3166             if (*p == '\'')
3167                 sep = p, leaf = p + 1;
3168             else if (*p == ':' && *(p + 1) == ':')
3169                 sep = p, leaf = p + 2;
3170         }
3171         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3172             /* the method name is unqualified or starts with SUPER:: */
3173             bool need_strlen = 1;
3174             if (sep) {
3175                 packname = CopSTASHPV(PL_curcop);
3176             }
3177             else if (stash) {
3178                 HEK * const packhek = HvNAME_HEK(stash);
3179                 if (packhek) {
3180                     packname = HEK_KEY(packhek);
3181                     packlen = HEK_LEN(packhek);
3182                     need_strlen = 0;
3183                 } else {
3184                     goto croak;
3185                 }
3186             }
3187
3188             if (!packname) {
3189             croak:
3190                 Perl_croak(aTHX_
3191                            "Can't use anonymous symbol table for method lookup");
3192             }
3193             else if (need_strlen)
3194                 packlen = strlen(packname);
3195
3196         }
3197         else {
3198             /* the method name is qualified */
3199             packname = name;
3200             packlen = sep - name;
3201         }
3202
3203         /* we're relying on gv_fetchmethod not autovivifying the stash */
3204         if (gv_stashpvn(packname, packlen, FALSE)) {
3205             Perl_croak(aTHX_
3206                        "Can't locate object method \"%s\" via package \"%.*s\"",
3207                        leaf, (int)packlen, packname);
3208         }
3209         else {
3210             Perl_croak(aTHX_
3211                        "Can't locate object method \"%s\" via package \"%.*s\""
3212                        " (perhaps you forgot to load \"%.*s\"?)",
3213                        leaf, (int)packlen, packname, (int)packlen, packname);
3214         }
3215     }
3216     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3217 }
3218
3219 /*
3220  * Local variables:
3221  * c-indentation-style: bsd
3222  * c-basic-offset: 4
3223  * indent-tabs-mode: t
3224  * End:
3225  *
3226  * ex: set ts=8 sts=4 sw=4 noet:
3227  */