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