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