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