pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  13  * shaking the air.
  14  *
  15  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  16  *                     Fire, Foes!  Awake!
  17  */
  18
  19 /* This file contains 'hot' pp ("push/pop") functions that
  20  * execute the opcodes that make up a perl program. A typical pp function
  21  * expects to find its arguments on the stack, and usually pushes its
  22  * results onto the stack, hence the 'pp' terminology. Each OP structure
  23  * contains a pointer to the relevant pp_foo() function.
  24  *
  25  * By 'hot', we mean common ops whose execution speed is critical.
  26  * By gathering them together into a single file, we encourage
  27  * CPU cache hits on hot code. Also it could be taken as a warning not to
  28  * change any code in this file unless you're sure it won't affect
  29  * performance.
  30  */
  31
  32 #include "EXTERN.h"
  33 #define PERL_IN_PP_HOT_C
  34 #include "perl.h"
  35
  36 /* Hot code. */
  37
  38 PP(pp_const)
  39 {
  40     dVAR;
  41     dSP;
  42     if ( PL_op->op_flags & OPf_SPECIAL )
  43         /* This is a const op added to hold the hints hash for
  44            pp_entereval. The hash can be modified by the code
  45            being eval'ed, so we return a copy instead. */
  46         mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
  47     else
  48         /* Normal const. */
  49         XPUSHs(cSVOP_sv);
  50     RETURN;
  51 }
  52
  53 PP(pp_nextstate)
  54 {
  55     dVAR;
  56     PL_curcop = (COP*)PL_op;
  57     TAINT_NOT;          /* Each statement is presumed innocent */
  58     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  59     FREETMPS;
  60     return NORMAL;
  61 }
  62
  63 PP(pp_gvsv)
  64 {
  65     dVAR;
  66     dSP;
  67     EXTEND(SP,1);
  68     if (PL_op->op_private & OPpLVAL_INTRO)
  69         PUSHs(save_scalar(cGVOP_gv));
  70     else
  71         PUSHs(GvSVn(cGVOP_gv));
  72     RETURN;
  73 }
  74
  75 PP(pp_null)
  76 {
  77     dVAR;
  78     return NORMAL;
  79 }
  80
  81 PP(pp_setstate)
  82 {
  83     dVAR;
  84     PL_curcop = (COP*)PL_op;
  85     return NORMAL;
  86 }
  87
  88 PP(pp_pushmark)
  89 {
  90     dVAR;
  91     PUSHMARK(PL_stack_sp);
  92     return NORMAL;
  93 }
  94
  95 PP(pp_stringify)
  96 {
  97     dVAR; dSP; dTARGET;
  98     sv_copypv(TARG,TOPs);
  99     SETTARG;
 100     RETURN;
 101 }
 102
 103 PP(pp_gv)
 104 {
 105     dVAR; dSP;
 106     XPUSHs((SV*)cGVOP_gv);
 107     RETURN;
 108 }
 109
 110 PP(pp_and)
 111 {
 112     dVAR; dSP;
 113     if (!SvTRUE(TOPs))
 114         RETURN;
 115     else {
 116         if (PL_op->op_type == OP_AND)
 117             --SP;
 118         RETURNOP(cLOGOP->op_other);
 119     }
 120 }
 121
 122 PP(pp_sassign)
 123 {
 124     dVAR; dSP; dPOPTOPssrl;
 125
 126     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
 127         SV * const temp = left;
 128         left = right; right = temp;
 129     }
 130     if (PL_tainting && PL_tainted && !SvTAINTED(left))
 131         TAINT_NOT;
 132     if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
 133         SV * const cv = SvRV(left);
 134         const U32 cv_type = SvTYPE(cv);
 135         const U32 gv_type = SvTYPE(right);
 136         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 137
 138         if (!got_coderef) {
 139             assert(SvROK(cv));
 140         }
 141
 142         /* Can do the optimisation if right (LVALUE) is not a typeglob,
 143            left (RVALUE) is a reference to something, and we're in void
 144            context. */
 145         if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
 146             /* Is the target symbol table currently empty?  */
 147             GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
 148             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 149                 /* Good. Create a new proxy constant subroutine in the target.
 150                    The gv becomes a(nother) reference to the constant.  */
 151                 SV *const value = SvRV(cv);
 152
 153                 SvUPGRADE((SV *)gv, SVt_IV);
 154                 SvPCS_IMPORTED_on(gv);
 155                 SvRV_set(gv, value);
 156                 SvREFCNT_inc_simple_void(value);
 157                 SETs(right);
 158                 RETURN;
 159             }
 160         }
 161
 162         /* Need to fix things up.  */
 163         if (gv_type != SVt_PVGV) {
 164             /* Need to fix GV.  */
 165             right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
 166         }
 167
 168         if (!got_coderef) {
 169             /* We've been returned a constant rather than a full subroutine,
 170                but they expect a subroutine reference to apply.  */
 171             if (SvROK(cv)) {
 172                 ENTER;
 173                 SvREFCNT_inc_void(SvRV(cv));
 174                 /* newCONSTSUB takes a reference count on the passed in SV
 175                    from us.  We set the name to NULL, otherwise we get into
 176                    all sorts of fun as the reference to our new sub is
 177                    donated to the GV that we're about to assign to.
 178                 */
 179                 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
 180                                                  SvRV(cv)));
 181                 SvREFCNT_dec(cv);
 182                 LEAVE;
 183             } else {
 184                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
 185                    is that
 186                    First:   ops for \&{"BONK"}; return us the constant in the
 187                             symbol table
 188                    Second:  ops for *{"BONK"} cause that symbol table entry
 189                             (and our reference to it) to be upgraded from RV
 190                             to typeblob)
 191                    Thirdly: We get here. cv is actually PVGV now, and its
 192                             GvCV() is actually the subroutine we're looking for
 193
 194                    So change the reference so that it points to the subroutine
 195                    of that typeglob, as that's what they were after all along.
 196                 */
 197                 GV *const upgraded = (GV *) cv;
 198                 CV *const source = GvCV(upgraded);
 199
 200                 assert(source);
 201                 assert(CvFLAGS(source) & CVf_CONST);
 202
 203                 SvREFCNT_inc_void(source);
 204                 SvREFCNT_dec(upgraded);
 205                 SvRV_set(left, (SV *)source);
 206             }
 207         }
 208
 209     }
 210     SvSetMagicSV(right, left);
 211     SETs(right);
 212     RETURN;
 213 }
 214
 215 PP(pp_cond_expr)
 216 {
 217     dVAR; dSP;
 218     if (SvTRUEx(POPs))
 219         RETURNOP(cLOGOP->op_other);
 220     else
 221         RETURNOP(cLOGOP->op_next);
 222 }
 223
 224 PP(pp_unstack)
 225 {
 226     dVAR;
 227     I32 oldsave;
 228     TAINT_NOT;          /* Each statement is presumed innocent */
 229     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 230     FREETMPS;
 231     oldsave = PL_scopestack[PL_scopestack_ix - 1];
 232     LEAVE_SCOPE(oldsave);
 233     return NORMAL;
 234 }
 235
 236 PP(pp_concat)
 237 {
 238   dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 239   {
 240     dPOPTOPssrl;
 241     bool lbyte;
 242     STRLEN rlen;
 243     const char *rpv = NULL;
 244     bool rbyte = FALSE;
 245     bool rcopied = FALSE;
 246
 247     if (TARG == right && right != left) {
 248         /* mg_get(right) may happen here ... */
 249         rpv = SvPV_const(right, rlen);
 250         rbyte = !DO_UTF8(right);
 251         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 252         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 253         rcopied = TRUE;
 254     }
 255
 256     if (TARG != left) {
 257         STRLEN llen;
 258         const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
 259         lbyte = !DO_UTF8(left);
 260         sv_setpvn(TARG, lpv, llen);
 261         if (!lbyte)
 262             SvUTF8_on(TARG);
 263         else
 264             SvUTF8_off(TARG);
 265     }
 266     else { /* TARG == left */
 267         STRLEN llen;
 268         SvGETMAGIC(left);               /* or mg_get(left) may happen here */
 269         if (!SvOK(TARG)) {
 270             if (left == right && ckWARN(WARN_UNINITIALIZED))
 271                 report_uninit(right);
 272             sv_setpvn(left, "", 0);
 273         }
 274         (void)SvPV_nomg_const(left, llen);    /* Needed to set UTF8 flag */
 275         lbyte = !DO_UTF8(left);
 276         if (IN_BYTES)
 277             SvUTF8_off(TARG);
 278     }
 279
 280     /* or mg_get(right) may happen here */
 281     if (!rcopied) {
 282         rpv = SvPV_const(right, rlen);
 283         rbyte = !DO_UTF8(right);
 284     }
 285     if (lbyte != rbyte) {
 286         if (lbyte)
 287             sv_utf8_upgrade_nomg(TARG);
 288         else {
 289             if (!rcopied)
 290                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 291             sv_utf8_upgrade_nomg(right);
 292             rpv = SvPV_const(right, rlen);
 293         }
 294     }
 295     sv_catpvn_nomg(TARG, rpv, rlen);
 296
 297     SETTARG;
 298     RETURN;
 299   }
 300 }
 301
 302 PP(pp_padsv)
 303 {
 304     dVAR; dSP; dTARGET;
 305     XPUSHs(TARG);
 306     if (PL_op->op_flags & OPf_MOD) {
 307         if (PL_op->op_private & OPpLVAL_INTRO)
 308             if (!(PL_op->op_private & OPpPAD_STATE))
 309                 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 310         if (PL_op->op_private & OPpDEREF) {
 311             PUTBACK;
 312             vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
 313             SPAGAIN;
 314         }
 315     }
 316     RETURN;
 317 }
 318
 319 PP(pp_readline)
 320 {
 321     dVAR;
 322     tryAMAGICunTARGET(iter, 0);
 323     PL_last_in_gv = (GV*)(*PL_stack_sp--);
 324     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
 325         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
 326             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
 327         else {
 328             dSP;
 329             XPUSHs((SV*)PL_last_in_gv);
 330             PUTBACK;
 331             pp_rv2gv();
 332             PL_last_in_gv = (GV*)(*PL_stack_sp--);
 333         }
 334     }
 335     return do_readline();
 336 }
 337
 338 PP(pp_eq)
 339 {
 340     dVAR; dSP; tryAMAGICbinSET(eq,0);
 341 #ifndef NV_PRESERVES_UV
 342     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
 343         SP--;
 344         SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 345         RETURN;
 346     }
 347 #endif
 348 #ifdef PERL_PRESERVE_IVUV
 349     SvIV_please(TOPs);
 350     if (SvIOK(TOPs)) {
 351         /* Unless the left argument is integer in range we are going
 352            to have to use NV maths. Hence only attempt to coerce the
 353            right argument if we know the left is integer.  */
 354       SvIV_please(TOPm1s);
 355         if (SvIOK(TOPm1s)) {
 356             const bool auvok = SvUOK(TOPm1s);
 357             const bool buvok = SvUOK(TOPs);
 358
 359             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
 360                 /* Casting IV to UV before comparison isn't going to matter
 361                    on 2s complement. On 1s complement or sign&magnitude
 362                    (if we have any of them) it could to make negative zero
 363                    differ from normal zero. As I understand it. (Need to
 364                    check - is negative zero implementation defined behaviour
 365                    anyway?). NWC  */
 366                 const UV buv = SvUVX(POPs);
 367                 const UV auv = SvUVX(TOPs);
 368
 369                 SETs(boolSV(auv == buv));
 370                 RETURN;
 371             }
 372             {                   /* ## Mixed IV,UV ## */
 373                 SV *ivp, *uvp;
 374                 IV iv;
 375
 376                 /* == is commutative so doesn't matter which is left or right */
 377                 if (auvok) {
 378                     /* top of stack (b) is the iv */
 379                     ivp = *SP;
 380                     uvp = *--SP;
 381                 } else {
 382                     uvp = *SP;
 383                     ivp = *--SP;
 384                 }
 385                 iv = SvIVX(ivp);
 386                 if (iv < 0)
 387                     /* As uv is a UV, it's >0, so it cannot be == */
 388                     SETs(&PL_sv_no);
 389                 else
 390                     /* we know iv is >= 0 */
 391                     SETs(boolSV((UV)iv == SvUVX(uvp)));
 392                 RETURN;
 393             }
 394         }
 395     }
 396 #endif
 397     {
 398 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
 399       dPOPTOPnnrl;
 400       if (Perl_isnan(left) || Perl_isnan(right))
 401           RETSETNO;
 402       SETs(boolSV(left == right));
 403 #else
 404       dPOPnv;
 405       SETs(boolSV(TOPn == value));
 406 #endif
 407       RETURN;
 408     }
 409 }
 410
 411 PP(pp_preinc)
 412 {
 413     dVAR; dSP;
 414     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 415         DIE(aTHX_ PL_no_modify);
 416     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 417         && SvIVX(TOPs) != IV_MAX)
 418     {
 419         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 420         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 421     }
 422     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 423         sv_inc(TOPs);
 424     SvSETMAGIC(TOPs);
 425     return NORMAL;
 426 }
 427
 428 PP(pp_or)
 429 {
 430     dVAR; dSP;
 431     if (SvTRUE(TOPs))
 432         RETURN;
 433     else {
 434         if (PL_op->op_type == OP_OR)
 435             --SP;
 436         RETURNOP(cLOGOP->op_other);
 437     }
 438 }
 439
 440 PP(pp_defined)
 441 {
 442     dVAR; dSP;
 443     register SV* sv;
 444     bool defined;
 445     const int op_type = PL_op->op_type;
 446     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 447
 448     if (is_dor) {
 449         sv = TOPs;
 450         if (!sv || !SvANY(sv)) {
 451             if (op_type == OP_DOR)
 452                 --SP;
 453             RETURNOP(cLOGOP->op_other);
 454         }
 455     }
 456     else {
 457         /* OP_DEFINED */
 458         sv = POPs;
 459         if (!sv || !SvANY(sv))
 460             RETPUSHNO;
 461     }
 462
 463     defined = FALSE;
 464     switch (SvTYPE(sv)) {
 465     case SVt_PVAV:
 466         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 467             defined = TRUE;
 468         break;
 469     case SVt_PVHV:
 470         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 471             defined = TRUE;
 472         break;
 473     case SVt_PVCV:
 474         if (CvROOT(sv) || CvXSUB(sv))
 475             defined = TRUE;
 476         break;
 477     default:
 478         SvGETMAGIC(sv);
 479         if (SvOK(sv))
 480             defined = TRUE;
 481         break;
 482     }
 483
 484     if (is_dor) {
 485         if(defined)
 486             RETURN;
 487         if(op_type == OP_DOR)
 488             --SP;
 489         RETURNOP(cLOGOP->op_other);
 490     }
 491     /* assuming OP_DEFINED */
 492     if(defined)
 493         RETPUSHYES;
 494     RETPUSHNO;
 495 }
 496
 497 PP(pp_add)
 498 {
 499     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
 500     tryAMAGICbin(add,opASSIGN);
 501     svl = sv_2num(TOPm1s);
 502     svr = sv_2num(TOPs);
 503     useleft = USE_LEFT(svl);
 504 #ifdef PERL_PRESERVE_IVUV
 505     /* We must see if we can perform the addition with integers if possible,
 506        as the integer code detects overflow while the NV code doesn't.
 507        If either argument hasn't had a numeric conversion yet attempt to get
 508        the IV. It's important to do this now, rather than just assuming that
 509        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 510        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 511        integer in case the second argument is IV=9223372036854775806
 512        We can (now) rely on sv_2iv to do the right thing, only setting the
 513        public IOK flag if the value in the NV (or PV) slot is truly integer.
 514
 515        A side effect is that this also aggressively prefers integer maths over
 516        fp maths for integer values.
 517
 518        How to detect overflow?
 519
 520        C 99 section 6.2.6.1 says
 521
 522        The range of nonnegative values of a signed integer type is a subrange
 523        of the corresponding unsigned integer type, and the representation of
 524        the same value in each type is the same. A computation involving
 525        unsigned operands can never overflow, because a result that cannot be
 526        represented by the resulting unsigned integer type is reduced modulo
 527        the number that is one greater than the largest value that can be
 528        represented by the resulting type.
 529
 530        (the 9th paragraph)
 531
 532        which I read as "unsigned ints wrap."
 533
 534        signed integer overflow seems to be classed as "exception condition"
 535
 536        If an exceptional condition occurs during the evaluation of an
 537        expression (that is, if the result is not mathematically defined or not
 538        in the range of representable values for its type), the behavior is
 539        undefined.
 540
 541        (6.5, the 5th paragraph)
 542
 543        I had assumed that on 2s complement machines signed arithmetic would
 544        wrap, hence coded pp_add and pp_subtract on the assumption that
 545        everything perl builds on would be happy.  After much wailing and
 546        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 547        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 548        unsigned code below is actually shorter than the old code. :-)
 549     */
 550
 551     SvIV_please(svr);
 552     if (SvIOK(svr)) {
 553         /* Unless the left argument is integer in range we are going to have to
 554            use NV maths. Hence only attempt to coerce the right argument if
 555            we know the left is integer.  */
 556         register UV auv = 0;
 557         bool auvok = FALSE;
 558         bool a_valid = 0;
 559
 560         if (!useleft) {
 561             auv = 0;
 562             a_valid = auvok = 1;
 563             /* left operand is undef, treat as zero. + 0 is identity,
 564                Could SETi or SETu right now, but space optimise by not adding
 565                lots of code to speed up what is probably a rarish case.  */
 566         } else {
 567             /* Left operand is defined, so is it IV? */
 568             SvIV_please(svl);
 569             if (SvIOK(svl)) {
 570                 if ((auvok = SvUOK(svl)))
 571                     auv = SvUVX(svl);
 572                 else {
 573                     register const IV aiv = SvIVX(svl);
 574                     if (aiv >= 0) {
 575                         auv = aiv;
 576                         auvok = 1;      /* Now acting as a sign flag.  */
 577                     } else { /* 2s complement assumption for IV_MIN */
 578                         auv = (UV)-aiv;
 579                     }
 580                 }
 581                 a_valid = 1;
 582             }
 583         }
 584         if (a_valid) {
 585             bool result_good = 0;
 586             UV result;
 587             register UV buv;
 588             bool buvok = SvUOK(svr);
 589
 590             if (buvok)
 591                 buv = SvUVX(svr);
 592             else {
 593                 register const IV biv = SvIVX(svr);
 594                 if (biv >= 0) {
 595                     buv = biv;
 596                     buvok = 1;
 597                 } else
 598                     buv = (UV)-biv;
 599             }
 600             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 601                else "IV" now, independent of how it came in.
 602                if a, b represents positive, A, B negative, a maps to -A etc
 603                a + b =>  (a + b)
 604                A + b => -(a - b)
 605                a + B =>  (a - b)
 606                A + B => -(a + b)
 607                all UV maths. negate result if A negative.
 608                add if signs same, subtract if signs differ. */
 609
 610             if (auvok ^ buvok) {
 611                 /* Signs differ.  */
 612                 if (auv >= buv) {
 613                     result = auv - buv;
 614                     /* Must get smaller */
 615                     if (result <= auv)
 616                         result_good = 1;
 617                 } else {
 618                     result = buv - auv;
 619                     if (result <= buv) {
 620                         /* result really should be -(auv-buv). as its negation
 621                            of true value, need to swap our result flag  */
 622                         auvok = !auvok;
 623                         result_good = 1;
 624                     }
 625                 }
 626             } else {
 627                 /* Signs same */
 628                 result = auv + buv;
 629                 if (result >= auv)
 630                     result_good = 1;
 631             }
 632             if (result_good) {
 633                 SP--;
 634                 if (auvok)
 635                     SETu( result );
 636                 else {
 637                     /* Negate result */
 638                     if (result <= (UV)IV_MIN)
 639                         SETi( -(IV)result );
 640                     else {
 641                         /* result valid, but out of range for IV.  */
 642                         SETn( -(NV)result );
 643                     }
 644                 }
 645                 RETURN;
 646             } /* Overflow, drop through to NVs.  */
 647         }
 648     }
 649 #endif
 650     {
 651         NV value = SvNV(svr);
 652         (void)POPs;
 653         if (!useleft) {
 654             /* left operand is undef, treat as zero. + 0.0 is identity. */
 655             SETn(value);
 656             RETURN;
 657         }
 658         SETn( value + SvNV(svl) );
 659         RETURN;
 660     }
 661 }
 662
 663 PP(pp_aelemfast)
 664 {
 665     dVAR; dSP;
 666     AV * const av = PL_op->op_flags & OPf_SPECIAL ?
 667                 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
 668     const U32 lval = PL_op->op_flags & OPf_MOD;
 669     SV** const svp = av_fetch(av, PL_op->op_private, lval);
 670     SV *sv = (svp ? *svp : &PL_sv_undef);
 671     EXTEND(SP, 1);
 672     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
 673         sv = sv_mortalcopy(sv);
 674     PUSHs(sv);
 675     RETURN;
 676 }
 677
 678 PP(pp_join)
 679 {
 680     dVAR; dSP; dMARK; dTARGET;
 681     MARK++;
 682     do_join(TARG, *MARK, MARK, SP);
 683     SP = MARK;
 684     SETs(TARG);
 685     RETURN;
 686 }
 687
 688 PP(pp_pushre)
 689 {
 690     dVAR; dSP;
 691 #ifdef DEBUGGING
 692     /*
 693      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 694      * will be enough to hold an OP*.
 695      */
 696     SV* const sv = sv_newmortal();
 697     sv_upgrade(sv, SVt_PVLV);
 698     LvTYPE(sv) = '/';
 699     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 700     XPUSHs(sv);
 701 #else
 702     XPUSHs((SV*)PL_op);
 703 #endif
 704     RETURN;
 705 }
 706
 707 /* Oversized hot code. */
 708
 709 PP(pp_print)
 710 {
 711     dVAR; dSP; dMARK; dORIGMARK;
 712     IO *io;
 713     register PerlIO *fp;
 714     MAGIC *mg;
 715     GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
 716
 717     if (gv && (io = GvIO(gv))
 718         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 719     {
 720       had_magic:
 721         if (MARK == ORIGMARK) {
 722             /* If using default handle then we need to make space to
 723              * pass object as 1st arg, so move other args up ...
 724              */
 725             MEXTEND(SP, 1);
 726             ++MARK;
 727             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 728             ++SP;
 729         }
 730         PUSHMARK(MARK - 1);
 731         *MARK = SvTIED_obj((SV*)io, mg);
 732         PUTBACK;
 733         ENTER;
 734         call_method("PRINT", G_SCALAR);
 735         LEAVE;
 736         SPAGAIN;
 737         MARK = ORIGMARK + 1;
 738         *MARK = *SP;
 739         SP = MARK;
 740         RETURN;
 741     }
 742     if (!(io = GvIO(gv))) {
 743         if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
 744             && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 745             goto had_magic;
 746         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 747             report_evil_fh(gv, io, PL_op->op_type);
 748         SETERRNO(EBADF,RMS_IFI);
 749         goto just_say_no;
 750     }
 751     else if (!(fp = IoOFP(io))) {
 752         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
 753             if (IoIFP(io))
 754                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
 755             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 756                 report_evil_fh(gv, io, PL_op->op_type);
 757         }
 758         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 759         goto just_say_no;
 760     }
 761     else {
 762         MARK++;
 763         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
 764             while (MARK <= SP) {
 765                 if (!do_print(*MARK, fp))
 766                     break;
 767                 MARK++;
 768                 if (MARK <= SP) {
 769                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
 770                         MARK--;
 771                         break;
 772                     }
 773                 }
 774             }
 775         }
 776         else {
 777             while (MARK <= SP) {
 778                 if (!do_print(*MARK, fp))
 779                     break;
 780                 MARK++;
 781             }
 782         }
 783         if (MARK <= SP)
 784             goto just_say_no;
 785         else {
 786             if (PL_op->op_type == OP_SAY) {
 787                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
 788                     goto just_say_no;
 789             }
 790             else if (PL_ors_sv && SvOK(PL_ors_sv))
 791                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 792                     goto just_say_no;
 793
 794             if (IoFLAGS(io) & IOf_FLUSH)
 795                 if (PerlIO_flush(fp) == EOF)
 796                     goto just_say_no;
 797         }
 798     }
 799     SP = ORIGMARK;
 800     XPUSHs(&PL_sv_yes);
 801     RETURN;
 802
 803   just_say_no:
 804     SP = ORIGMARK;
 805     XPUSHs(&PL_sv_undef);
 806     RETURN;
 807 }
 808
 809 PP(pp_rv2av)
 810 {
 811     dVAR; dSP; dTOPss;
 812     const I32 gimme = GIMME_V;
 813     static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
 814     static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
 815     static const char an_array[] = "an ARRAY";
 816     static const char a_hash[] = "a HASH";
 817     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
 818     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 819
 820     if (SvROK(sv)) {
 821       wasref:
 822         tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
 823
 824         sv = SvRV(sv);
 825         if (SvTYPE(sv) != type)
 826             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
 827         if (PL_op->op_flags & OPf_REF) {
 828             SETs(sv);
 829             RETURN;
 830         }
 831         else if (LVRET) {
 832             if (gimme != G_ARRAY)
 833                 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
 834                            : return_hash_to_lvalue_scalar);
 835             SETs(sv);
 836             RETURN;
 837         }
 838         else if (PL_op->op_flags & OPf_MOD
 839                 && PL_op->op_private & OPpLVAL_INTRO)
 840             Perl_croak(aTHX_ PL_no_localize_ref);
 841     }
 842     else {
 843         if (SvTYPE(sv) == type) {
 844             if (PL_op->op_flags & OPf_REF) {
 845                 SETs(sv);
 846                 RETURN;
 847             }
 848             else if (LVRET) {
 849                 if (gimme != G_ARRAY)
 850                     Perl_croak(aTHX_
 851                                is_pp_rv2av ? return_array_to_lvalue_scalar
 852                                : return_hash_to_lvalue_scalar);
 853                 SETs(sv);
 854                 RETURN;
 855             }
 856         }
 857         else {
 858             GV *gv;
 859
 860             if (SvTYPE(sv) != SVt_PVGV) {
 861                 if (SvGMAGICAL(sv)) {
 862                     mg_get(sv);
 863                     if (SvROK(sv))
 864                         goto wasref;
 865                 }
 866                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 867                                      type, &sp);
 868                 if (!gv)
 869                     RETURN;
 870             }
 871             else {
 872                 gv = (GV*)sv;
 873             }
 874             sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
 875             if (PL_op->op_private & OPpLVAL_INTRO)
 876                 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
 877             if (PL_op->op_flags & OPf_REF) {
 878                 SETs(sv);
 879                 RETURN;
 880             }
 881             else if (LVRET) {
 882                 if (gimme != G_ARRAY)
 883                     Perl_croak(aTHX_
 884                                is_pp_rv2av ? return_array_to_lvalue_scalar
 885                                : return_hash_to_lvalue_scalar);
 886                 SETs(sv);
 887                 RETURN;
 888             }
 889         }
 890     }
 891
 892     if (is_pp_rv2av) {
 893         AV *const av = (AV*)sv;
 894         /* The guts of pp_rv2av, with no intenting change to preserve history
 895            (until such time as we get tools that can do blame annotation across
 896            whitespace changes.  */
 897     if (gimme == G_ARRAY) {
 898         const I32 maxarg = AvFILL(av) + 1;
 899         (void)POPs;                     /* XXXX May be optimized away? */
 900         EXTEND(SP, maxarg);
 901         if (SvRMAGICAL(av)) {
 902             U32 i;
 903             for (i=0; i < (U32)maxarg; i++) {
 904                 SV ** const svp = av_fetch(av, i, FALSE);
 905                 /* See note in pp_helem, and bug id #27839 */
 906                 SP[i+1] = svp
 907                     ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
 908                     : &PL_sv_undef;
 909             }
 910         }
 911         else {
 912             Copy(AvARRAY(av), SP+1, maxarg, SV*);
 913         }
 914         SP += maxarg;
 915     }
 916     else if (gimme == G_SCALAR) {
 917         dTARGET;
 918         const I32 maxarg = AvFILL(av) + 1;
 919         SETi(maxarg);
 920     }
 921     } else {
 922         /* The guts of pp_rv2hv  */
 923     if (gimme == G_ARRAY) { /* array wanted */
 924         *PL_stack_sp = sv;
 925         return do_kv();
 926     }
 927     else if (gimme == G_SCALAR) {
 928         dTARGET;
 929     TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
 930         SPAGAIN;
 931         SETTARG;
 932     }
 933     }
 934     RETURN;
 935 }
 936
 937 STATIC void
 938 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 939 {
 940     dVAR;
 941     if (*relem) {
 942         SV *tmpstr;
 943         const HE *didstore;
 944
 945         if (ckWARN(WARN_MISC)) {
 946             const char *err;
 947             if (relem == firstrelem &&
 948                 SvROK(*relem) &&
 949                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 950                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 951             {
 952                 err = "Reference found where even-sized list expected";
 953             }
 954             else
 955                 err = "Odd number of elements in hash assignment";
 956             Perl_warner(aTHX_ packWARN(WARN_MISC), err);
 957         }
 958
 959         tmpstr = newSV(0);
 960         didstore = hv_store_ent(hash,*relem,tmpstr,0);
 961         if (SvMAGICAL(hash)) {
 962             if (SvSMAGICAL(tmpstr))
 963                 mg_set(tmpstr);
 964             if (!didstore)
 965                 sv_2mortal(tmpstr);
 966         }
 967         TAINT_NOT;
 968     }
 969 }
 970
 971 PP(pp_aassign)
 972 {
 973     dVAR; dSP;
 974     SV **lastlelem = PL_stack_sp;
 975     SV **lastrelem = PL_stack_base + POPMARK;
 976     SV **firstrelem = PL_stack_base + POPMARK + 1;
 977     SV **firstlelem = lastrelem + 1;
 978
 979     register SV **relem;
 980     register SV **lelem;
 981
 982     register SV *sv;
 983     register AV *ary;
 984
 985     I32 gimme;
 986     HV *hash;
 987     I32 i;
 988     int magic;
 989     int duplicates = 0;
 990     SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet  */
 991
 992     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
 993     gimme = GIMME_V;
 994
 995     /* If there's a common identifier on both sides we have to take
 996      * special care that assigning the identifier on the left doesn't
 997      * clobber a value on the right that's used later in the list.
 998      */
 999     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1000         EXTEND_MORTAL(lastrelem - firstrelem + 1);
1001         for (relem = firstrelem; relem <= lastrelem; relem++) {
1002             if ((sv = *relem)) {
1003                 TAINT_NOT;      /* Each item is independent */
1004                 *relem = sv_mortalcopy(sv);
1005             }
1006         }
1007     }
1008
1009     relem = firstrelem;
1010     lelem = firstlelem;
1011     ary = NULL;
1012     hash = NULL;
1013
1014     while (lelem <= lastlelem) {
1015         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1016         sv = *lelem++;
1017         switch (SvTYPE(sv)) {
1018         case SVt_PVAV:
1019             ary = (AV*)sv;
1020             magic = SvMAGICAL(ary) != 0;
1021             av_clear(ary);
1022             av_extend(ary, lastrelem - relem);
1023             i = 0;
1024             while (relem <= lastrelem) {        /* gobble up all the rest */
1025                 SV **didstore;
1026                 assert(*relem);
1027                 sv = newSVsv(*relem);
1028                 *(relem++) = sv;
1029                 didstore = av_store(ary,i++,sv);
1030                 if (magic) {
1031                     if (SvSMAGICAL(sv))
1032                         mg_set(sv);
1033                     if (!didstore)
1034                         sv_2mortal(sv);
1035                 }
1036                 TAINT_NOT;
1037             }
1038             if (PL_delaymagic & DM_ARRAY)
1039                 SvSETMAGIC((SV*)ary);
1040             break;
1041         case SVt_PVHV: {                                /* normal hash */
1042                 SV *tmpstr;
1043
1044                 hash = (HV*)sv;
1045                 magic = SvMAGICAL(hash) != 0;
1046                 hv_clear(hash);
1047                 firsthashrelem = relem;
1048
1049                 while (relem < lastrelem) {     /* gobble up all the rest */
1050                     HE *didstore;
1051                     sv = *relem ? *relem : &PL_sv_no;
1052                     relem++;
1053                     tmpstr = newSV(0);
1054                     if (*relem)
1055                         sv_setsv(tmpstr,*relem);        /* value */
1056                     *(relem++) = tmpstr;
1057                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1058                         /* key overwrites an existing entry */
1059                         duplicates += 2;
1060                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1061                     if (magic) {
1062                         if (SvSMAGICAL(tmpstr))
1063                             mg_set(tmpstr);
1064                         if (!didstore)
1065                             sv_2mortal(tmpstr);
1066                     }
1067                     TAINT_NOT;
1068                 }
1069                 if (relem == lastrelem) {
1070                     do_oddball(hash, relem, firstrelem);
1071                     relem++;
1072                 }
1073             }
1074             break;
1075         default:
1076             if (SvIMMORTAL(sv)) {
1077                 if (relem <= lastrelem)
1078                     relem++;
1079                 break;
1080             }
1081             if (relem <= lastrelem) {
1082                 sv_setsv(sv, *relem);
1083                 *(relem++) = sv;
1084             }
1085             else
1086                 sv_setsv(sv, &PL_sv_undef);
1087             SvSETMAGIC(sv);
1088             break;
1089         }
1090     }
1091     if (PL_delaymagic & ~DM_DELAY) {
1092         if (PL_delaymagic & DM_UID) {
1093 #ifdef HAS_SETRESUID
1094             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1095                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1096                             (Uid_t)-1);
1097 #else
1098 #  ifdef HAS_SETREUID
1099             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1100                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1101 #  else
1102 #    ifdef HAS_SETRUID
1103             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1104                 (void)setruid(PL_uid);
1105                 PL_delaymagic &= ~DM_RUID;
1106             }
1107 #    endif /* HAS_SETRUID */
1108 #    ifdef HAS_SETEUID
1109             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1110                 (void)seteuid(PL_euid);
1111                 PL_delaymagic &= ~DM_EUID;
1112             }
1113 #    endif /* HAS_SETEUID */
1114             if (PL_delaymagic & DM_UID) {
1115                 if (PL_uid != PL_euid)
1116                     DIE(aTHX_ "No setreuid available");
1117                 (void)PerlProc_setuid(PL_uid);
1118             }
1119 #  endif /* HAS_SETREUID */
1120 #endif /* HAS_SETRESUID */
1121             PL_uid = PerlProc_getuid();
1122             PL_euid = PerlProc_geteuid();
1123         }
1124         if (PL_delaymagic & DM_GID) {
1125 #ifdef HAS_SETRESGID
1126             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1127                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1128                             (Gid_t)-1);
1129 #else
1130 #  ifdef HAS_SETREGID
1131             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1132                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1133 #  else
1134 #    ifdef HAS_SETRGID
1135             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1136                 (void)setrgid(PL_gid);
1137                 PL_delaymagic &= ~DM_RGID;
1138             }
1139 #    endif /* HAS_SETRGID */
1140 #    ifdef HAS_SETEGID
1141             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1142                 (void)setegid(PL_egid);
1143                 PL_delaymagic &= ~DM_EGID;
1144             }
1145 #    endif /* HAS_SETEGID */
1146             if (PL_delaymagic & DM_GID) {
1147                 if (PL_gid != PL_egid)
1148                     DIE(aTHX_ "No setregid available");
1149                 (void)PerlProc_setgid(PL_gid);
1150             }
1151 #  endif /* HAS_SETREGID */
1152 #endif /* HAS_SETRESGID */
1153             PL_gid = PerlProc_getgid();
1154             PL_egid = PerlProc_getegid();
1155         }
1156         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1157     }
1158     PL_delaymagic = 0;
1159
1160     if (gimme == G_VOID)
1161         SP = firstrelem - 1;
1162     else if (gimme == G_SCALAR) {
1163         dTARGET;
1164         SP = firstrelem;
1165         SETi(lastrelem - firstrelem + 1 - duplicates);
1166     }
1167     else {
1168         if (ary)
1169             SP = lastrelem;
1170         else if (hash) {
1171             if (duplicates) {
1172                 /* Removes from the stack the entries which ended up as
1173                  * duplicated keys in the hash (fix for [perl #24380]) */
1174                 Move(firsthashrelem + duplicates,
1175                         firsthashrelem, duplicates, SV**);
1176                 lastrelem -= duplicates;
1177             }
1178             SP = lastrelem;
1179         }
1180         else
1181             SP = firstrelem + (lastlelem - firstlelem);
1182         lelem = firstlelem + (relem - firstrelem);
1183         while (relem <= SP)
1184             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1185     }
1186
1187     RETURN;
1188 }
1189
1190 PP(pp_qr)
1191 {
1192     dVAR; dSP;
1193     register PMOP * const pm = cPMOP;
1194     REGEXP * rx = PM_GETRE(pm);
1195     SV * const pkg = CALLREG_PACKAGE(rx);
1196     SV * const rv = sv_newmortal();
1197
1198     SvUPGRADE(rv, SVt_IV);
1199     /* This RV is about to own a reference to the regexp. (In addition to the
1200        reference already owned by the PMOP.  */
1201     ReREFCNT_inc(rx);
1202     SvRV_set(rv, rx);
1203     SvROK_on(rv);
1204
1205     if (pkg) {
1206         HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1207         (void)sv_bless(rv, stash);
1208     }
1209
1210     if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1211         SvTAINTED_on(rv);
1212     XPUSHs(rv);
1213     RETURN;
1214 }
1215
1216 PP(pp_match)
1217 {
1218     dVAR; dSP; dTARG;
1219     register PMOP *pm = cPMOP;
1220     PMOP *dynpm = pm;
1221     register const char *t;
1222     register const char *s;
1223     const char *strend;
1224     I32 global;
1225     I32 r_flags = REXEC_CHECKED;
1226     const char *truebase;                       /* Start of string  */
1227     register REGEXP *rx = PM_GETRE(pm);
1228     bool rxtainted;
1229     const I32 gimme = GIMME;
1230     STRLEN len;
1231     I32 minmatch = 0;
1232     const I32 oldsave = PL_savestack_ix;
1233     I32 update_minmatch = 1;
1234     I32 had_zerolen = 0;
1235     U32 gpos = 0;
1236
1237     if (PL_op->op_flags & OPf_STACKED)
1238         TARG = POPs;
1239     else if (PL_op->op_private & OPpTARGET_MY)
1240         GETTARGET;
1241     else {
1242         TARG = DEFSV;
1243         EXTEND(SP,1);
1244     }
1245
1246     PUTBACK;                            /* EVAL blocks need stack_sp. */
1247     s = SvPV_const(TARG, len);
1248     if (!s)
1249         DIE(aTHX_ "panic: pp_match");
1250     strend = s + len;
1251     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1252                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1253     TAINT_NOT;
1254
1255     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1256
1257     /* PMdf_USED is set after a ?? matches once */
1258     if (
1259 #ifdef USE_ITHREADS
1260         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1261 #else
1262         pm->op_pmflags & PMf_USED
1263 #endif
1264     ) {
1265       failure:
1266         if (gimme == G_ARRAY)
1267             RETURN;
1268         RETPUSHNO;
1269     }
1270
1271
1272
1273     /* empty pattern special-cased to use last successful pattern if possible */
1274     if (!RX_PRELEN(rx) && PL_curpm) {
1275         pm = PL_curpm;
1276         rx = PM_GETRE(pm);
1277     }
1278
1279     if (RX_MINLEN(rx) > (I32)len)
1280         goto failure;
1281
1282     truebase = t = s;
1283
1284     /* XXXX What part of this is needed with true \G-support? */
1285     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1286         RX_OFFS(rx)[0].start = -1;
1287         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1288             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1289             if (mg && mg->mg_len >= 0) {
1290                 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1291                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1292                 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1293                     r_flags |= REXEC_IGNOREPOS;
1294                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1295                 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1296                     gpos = mg->mg_len;
1297                 else
1298                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1299                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1300                 update_minmatch = 0;
1301             }
1302         }
1303     }
1304     /* XXX: comment out !global get safe $1 vars after a
1305        match, BUT be aware that this leads to dramatic slowdowns on
1306        /g matches against large strings.  So far a solution to this problem
1307        appears to be quite tricky.
1308        Test for the unsafe vars are TODO for now. */
1309     if ((  !global && RX_NPARENS(rx))
1310             || SvTEMP(TARG) || PL_sawampersand ||
1311             (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1312         r_flags |= REXEC_COPY_STR;
1313     if (SvSCREAM(TARG))
1314         r_flags |= REXEC_SCREAM;
1315
1316 play_it_again:
1317     if (global && RX_OFFS(rx)[0].start != -1) {
1318         t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1319         if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1320             goto nope;
1321         if (update_minmatch++)
1322             minmatch = had_zerolen;
1323     }
1324     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1325         DO_UTF8(TARG) == ((RX_EXTFLAGS(rx) & RXf_UTF8) != 0)) {
1326         /* FIXME - can PL_bostr be made const char *?  */
1327         PL_bostr = (char *)truebase;
1328         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1329
1330         if (!s)
1331             goto nope;
1332         if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1333              && !PL_sawampersand
1334              && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1335              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1336                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1337                       && (r_flags & REXEC_SCREAM)))
1338              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1339             goto yup;
1340     }
1341     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1342                     minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1343     {
1344         PL_curpm = pm;
1345         if (dynpm->op_pmflags & PMf_ONCE) {
1346 #ifdef USE_ITHREADS
1347             SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1348 #else
1349             dynpm->op_pmflags |= PMf_USED;
1350 #endif
1351         }
1352         goto gotcha;
1353     }
1354     else
1355         goto ret_no;
1356     /*NOTREACHED*/
1357
1358   gotcha:
1359     if (rxtainted)
1360         RX_MATCH_TAINTED_on(rx);
1361     TAINT_IF(RX_MATCH_TAINTED(rx));
1362     if (gimme == G_ARRAY) {
1363         const I32 nparens = RX_NPARENS(rx);
1364         I32 i = (global && !nparens) ? 1 : 0;
1365
1366         SPAGAIN;                        /* EVAL blocks could move the stack. */
1367         EXTEND(SP, nparens + i);
1368         EXTEND_MORTAL(nparens + i);
1369         for (i = !i; i <= nparens; i++) {
1370             PUSHs(sv_newmortal());
1371             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1372                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1373                 s = RX_OFFS(rx)[i].start + truebase;
1374                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1375                     len < 0 || len > strend - s)
1376                     DIE(aTHX_ "panic: pp_match start/end pointers");
1377                 sv_setpvn(*SP, s, len);
1378                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1379                     SvUTF8_on(*SP);
1380             }
1381         }
1382         if (global) {
1383             if (dynpm->op_pmflags & PMf_CONTINUE) {
1384                 MAGIC* mg = NULL;
1385                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1386                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1387                 if (!mg) {
1388 #ifdef PERL_OLD_COPY_ON_WRITE
1389                     if (SvIsCOW(TARG))
1390                         sv_force_normal_flags(TARG, 0);
1391 #endif
1392                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1393                                      &PL_vtbl_mglob, NULL, 0);
1394                 }
1395                 if (RX_OFFS(rx)[0].start != -1) {
1396                     mg->mg_len = RX_OFFS(rx)[0].end;
1397                     if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1398                         mg->mg_flags |= MGf_MINMATCH;
1399                     else
1400                         mg->mg_flags &= ~MGf_MINMATCH;
1401                 }
1402             }
1403             had_zerolen = (RX_OFFS(rx)[0].start != -1
1404                            && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1405                                == (UV)RX_OFFS(rx)[0].end));
1406             PUTBACK;                    /* EVAL blocks may use stack */
1407             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1408             goto play_it_again;
1409         }
1410         else if (!nparens)
1411             XPUSHs(&PL_sv_yes);
1412         LEAVE_SCOPE(oldsave);
1413         RETURN;
1414     }
1415     else {
1416         if (global) {
1417             MAGIC* mg;
1418             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1419                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1420             else
1421                 mg = NULL;
1422             if (!mg) {
1423 #ifdef PERL_OLD_COPY_ON_WRITE
1424                 if (SvIsCOW(TARG))
1425                     sv_force_normal_flags(TARG, 0);
1426 #endif
1427                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1428                                  &PL_vtbl_mglob, NULL, 0);
1429             }
1430             if (RX_OFFS(rx)[0].start != -1) {
1431                 mg->mg_len = RX_OFFS(rx)[0].end;
1432                 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1433                     mg->mg_flags |= MGf_MINMATCH;
1434                 else
1435                     mg->mg_flags &= ~MGf_MINMATCH;
1436             }
1437         }
1438         LEAVE_SCOPE(oldsave);
1439         RETPUSHYES;
1440     }
1441
1442 yup:                                    /* Confirmed by INTUIT */
1443     if (rxtainted)
1444         RX_MATCH_TAINTED_on(rx);
1445     TAINT_IF(RX_MATCH_TAINTED(rx));
1446     PL_curpm = pm;
1447     if (dynpm->op_pmflags & PMf_ONCE) {
1448 #ifdef USE_ITHREADS
1449         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1450 #else
1451         dynpm->op_pmflags |= PMf_USED;
1452 #endif
1453     }
1454     if (RX_MATCH_COPIED(rx))
1455         Safefree(RX_SUBBEG(rx));
1456     RX_MATCH_COPIED_off(rx);
1457     RX_SUBBEG(rx) = NULL;
1458     if (global) {
1459         /* FIXME - should rx->subbeg be const char *?  */
1460         RX_SUBBEG(rx) = (char *) truebase;
1461         RX_OFFS(rx)[0].start = s - truebase;
1462         if (RX_MATCH_UTF8(rx)) {
1463             char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1464             RX_OFFS(rx)[0].end = t - truebase;
1465         }
1466         else {
1467             RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1468         }
1469         RX_SUBLEN(rx) = strend - truebase;
1470         goto gotcha;
1471     }
1472     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1473         I32 off;
1474 #ifdef PERL_OLD_COPY_ON_WRITE
1475         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1476             if (DEBUG_C_TEST) {
1477                 PerlIO_printf(Perl_debug_log,
1478                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1479                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1480                               (int)(t-truebase));
1481             }
1482             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1483             RX_SUBBEG(rx) = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1484             assert (SvPOKp(rx->saved_copy));
1485         } else
1486 #endif
1487         {
1488
1489             RX_SUBBEG(rx) = savepvn(t, strend - t);
1490 #ifdef PERL_OLD_COPY_ON_WRITE
1491             rx->saved_copy = NULL;
1492 #endif
1493         }
1494         RX_SUBLEN(rx) = strend - t;
1495         RX_MATCH_COPIED_on(rx);
1496         off = RX_OFFS(rx)[0].start = s - t;
1497         RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1498     }
1499     else {                      /* startp/endp are used by @- @+. */
1500         RX_OFFS(rx)[0].start = s - truebase;
1501         RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1502     }
1503     /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1504        -dmq */
1505     RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;      /* used by @-, @+, and $^N */
1506     LEAVE_SCOPE(oldsave);
1507     RETPUSHYES;
1508
1509 nope:
1510 ret_no:
1511     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1512         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1513             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1514             if (mg)
1515                 mg->mg_len = -1;
1516         }
1517     }
1518     LEAVE_SCOPE(oldsave);
1519     if (gimme == G_ARRAY)
1520         RETURN;
1521     RETPUSHNO;
1522 }
1523
1524 OP *
1525 Perl_do_readline(pTHX)
1526 {
1527     dVAR; dSP; dTARGETSTACKED;
1528     register SV *sv;
1529     STRLEN tmplen = 0;
1530     STRLEN offset;
1531     PerlIO *fp;
1532     register IO * const io = GvIO(PL_last_in_gv);
1533     register const I32 type = PL_op->op_type;
1534     const I32 gimme = GIMME_V;
1535
1536     if (io) {
1537         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1538         if (mg) {
1539             PUSHMARK(SP);
1540             XPUSHs(SvTIED_obj((SV*)io, mg));
1541             PUTBACK;
1542             ENTER;
1543             call_method("READLINE", gimme);
1544             LEAVE;
1545             SPAGAIN;
1546             if (gimme == G_SCALAR) {
1547                 SV* const result = POPs;
1548                 SvSetSV_nosteal(TARG, result);
1549                 PUSHTARG;
1550             }
1551             RETURN;
1552         }
1553     }
1554     fp = NULL;
1555     if (io) {
1556         fp = IoIFP(io);
1557         if (!fp) {
1558             if (IoFLAGS(io) & IOf_ARGV) {
1559                 if (IoFLAGS(io) & IOf_START) {
1560                     IoLINES(io) = 0;
1561                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1562                         IoFLAGS(io) &= ~IOf_START;
1563                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1564                         sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1565                         SvSETMAGIC(GvSV(PL_last_in_gv));
1566                         fp = IoIFP(io);
1567                         goto have_fp;
1568                     }
1569                 }
1570                 fp = nextargv(PL_last_in_gv);
1571                 if (!fp) { /* Note: fp != IoIFP(io) */
1572                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1573                 }
1574             }
1575             else if (type == OP_GLOB)
1576                 fp = Perl_start_glob(aTHX_ POPs, io);
1577         }
1578         else if (type == OP_GLOB)
1579             SP--;
1580         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1581             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1582         }
1583     }
1584     if (!fp) {
1585         if ((!io || !(IoFLAGS(io) & IOf_START))
1586             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1587         {
1588             if (type == OP_GLOB)
1589                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1590                             "glob failed (can't start child: %s)",
1591                             Strerror(errno));
1592             else
1593                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1594         }
1595         if (gimme == G_SCALAR) {
1596             /* undef TARG, and push that undefined value */
1597             if (type != OP_RCATLINE) {
1598                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1599                 SvOK_off(TARG);
1600             }
1601             PUSHTARG;
1602         }
1603         RETURN;
1604     }
1605   have_fp:
1606     if (gimme == G_SCALAR) {
1607         sv = TARG;
1608         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1609             mg_get(sv);
1610         if (SvROK(sv)) {
1611             if (type == OP_RCATLINE)
1612                 SvPV_force_nolen(sv);
1613             else
1614                 sv_unref(sv);
1615         }
1616         else if (isGV_with_GP(sv)) {
1617             SvPV_force_nolen(sv);
1618         }
1619         SvUPGRADE(sv, SVt_PV);
1620         tmplen = SvLEN(sv);     /* remember if already alloced */
1621         if (!tmplen && !SvREADONLY(sv))
1622             Sv_Grow(sv, 80);    /* try short-buffering it */
1623         offset = 0;
1624         if (type == OP_RCATLINE && SvOK(sv)) {
1625             if (!SvPOK(sv)) {
1626                 SvPV_force_nolen(sv);
1627             }
1628             offset = SvCUR(sv);
1629         }
1630     }
1631     else {
1632         sv = sv_2mortal(newSV(80));
1633         offset = 0;
1634     }
1635
1636     /* This should not be marked tainted if the fp is marked clean */
1637 #define MAYBE_TAINT_LINE(io, sv) \
1638     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1639         TAINT;                          \
1640         SvTAINTED_on(sv);               \
1641     }
1642
1643 /* delay EOF state for a snarfed empty file */
1644 #define SNARF_EOF(gimme,rs,io,sv) \
1645     (gimme != G_SCALAR || SvCUR(sv)                                     \
1646      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1647
1648     for (;;) {
1649         PUTBACK;
1650         if (!sv_gets(sv, fp, offset)
1651             && (type == OP_GLOB
1652                 || SNARF_EOF(gimme, PL_rs, io, sv)
1653                 || PerlIO_error(fp)))
1654         {
1655             PerlIO_clearerr(fp);
1656             if (IoFLAGS(io) & IOf_ARGV) {
1657                 fp = nextargv(PL_last_in_gv);
1658                 if (fp)
1659                     continue;
1660                 (void)do_close(PL_last_in_gv, FALSE);
1661             }
1662             else if (type == OP_GLOB) {
1663                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1664                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1665                            "glob failed (child exited with status %d%s)",
1666                            (int)(STATUS_CURRENT >> 8),
1667                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1668                 }
1669             }
1670             if (gimme == G_SCALAR) {
1671                 if (type != OP_RCATLINE) {
1672                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1673                     SvOK_off(TARG);
1674                 }
1675                 SPAGAIN;
1676                 PUSHTARG;
1677             }
1678             MAYBE_TAINT_LINE(io, sv);
1679             RETURN;
1680         }
1681         MAYBE_TAINT_LINE(io, sv);
1682         IoLINES(io)++;
1683         IoFLAGS(io) |= IOf_NOLINE;
1684         SvSETMAGIC(sv);
1685         SPAGAIN;
1686         XPUSHs(sv);
1687         if (type == OP_GLOB) {
1688             const char *t1;
1689
1690             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1691                 char * const tmps = SvEND(sv) - 1;
1692                 if (*tmps == *SvPVX_const(PL_rs)) {
1693                     *tmps = '\0';
1694                     SvCUR_set(sv, SvCUR(sv) - 1);
1695                 }
1696             }
1697             for (t1 = SvPVX_const(sv); *t1; t1++)
1698                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1699                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1700                         break;
1701             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1702                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1703                 continue;
1704             }
1705         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1706              if (ckWARN(WARN_UTF8)) {
1707                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1708                 const STRLEN len = SvCUR(sv) - offset;
1709                 const U8 *f;
1710
1711                 if (!is_utf8_string_loc(s, len, &f))
1712                     /* Emulate :encoding(utf8) warning in the same case. */
1713                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1714                                 "utf8 \"\\x%02X\" does not map to Unicode",
1715                                 f < (U8*)SvEND(sv) ? *f : 0);
1716              }
1717         }
1718         if (gimme == G_ARRAY) {
1719             if (SvLEN(sv) - SvCUR(sv) > 20) {
1720                 SvPV_shrink_to_cur(sv);
1721             }
1722             sv = sv_2mortal(newSV(80));
1723             continue;
1724         }
1725         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1726             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1727             const STRLEN new_len
1728                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1729             SvPV_renew(sv, new_len);
1730         }
1731         RETURN;
1732     }
1733 }
1734
1735 PP(pp_enter)
1736 {
1737     dVAR; dSP;
1738     register PERL_CONTEXT *cx;
1739     I32 gimme = OP_GIMME(PL_op, -1);
1740
1741     if (gimme == -1) {
1742         if (cxstack_ix >= 0)
1743             gimme = cxstack[cxstack_ix].blk_gimme;
1744         else
1745             gimme = G_SCALAR;
1746     }
1747
1748     ENTER;
1749
1750     SAVETMPS;
1751     PUSHBLOCK(cx, CXt_BLOCK, SP);
1752
1753     RETURN;
1754 }
1755
1756 PP(pp_helem)
1757 {
1758     dVAR; dSP;
1759     HE* he;
1760     SV **svp;
1761     SV * const keysv = POPs;
1762     HV * const hv = (HV*)POPs;
1763     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1764     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1765     SV *sv;
1766     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1767     I32 preeminent = 0;
1768
1769     if (SvTYPE(hv) != SVt_PVHV)
1770         RETPUSHUNDEF;
1771
1772     if (PL_op->op_private & OPpLVAL_INTRO) {
1773         MAGIC *mg;
1774         HV *stash;
1775         /* does the element we're localizing already exist? */
1776         preeminent = /* can we determine whether it exists? */
1777             (    !SvRMAGICAL(hv)
1778                 || mg_find((SV*)hv, PERL_MAGIC_env)
1779                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1780                         /* Try to preserve the existenceness of a tied hash
1781                         * element by using EXISTS and DELETE if possible.
1782                         * Fallback to FETCH and STORE otherwise */
1783                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1784                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1785                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1786                 )
1787             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1788     }
1789     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1790     svp = he ? &HeVAL(he) : NULL;
1791     if (lval) {
1792         if (!svp || *svp == &PL_sv_undef) {
1793             SV* lv;
1794             SV* key2;
1795             if (!defer) {
1796                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1797             }
1798             lv = sv_newmortal();
1799             sv_upgrade(lv, SVt_PVLV);
1800             LvTYPE(lv) = 'y';
1801             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1802             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1803             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1804             LvTARGLEN(lv) = 1;
1805             PUSHs(lv);
1806             RETURN;
1807         }
1808         if (PL_op->op_private & OPpLVAL_INTRO) {
1809             if (HvNAME_get(hv) && isGV(*svp))
1810                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1811             else {
1812                 if (!preeminent) {
1813                     STRLEN keylen;
1814                     const char * const key = SvPV_const(keysv, keylen);
1815                     SAVEDELETE(hv, savepvn(key,keylen),
1816                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1817                 } else
1818                     save_helem(hv, keysv, svp);
1819             }
1820         }
1821         else if (PL_op->op_private & OPpDEREF)
1822             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1823     }
1824     sv = (svp ? *svp : &PL_sv_undef);
1825     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1826      * Pushing the magical RHS on to the stack is useless, since
1827      * that magic is soon destined to be misled by the local(),
1828      * and thus the later pp_sassign() will fail to mg_get() the
1829      * old value.  This should also cure problems with delayed
1830      * mg_get()s.  GSAR 98-07-03 */
1831     if (!lval && SvGMAGICAL(sv))
1832         sv = sv_mortalcopy(sv);
1833     PUSHs(sv);
1834     RETURN;
1835 }
1836
1837 PP(pp_leave)
1838 {
1839     dVAR; dSP;
1840     register PERL_CONTEXT *cx;
1841     SV **newsp;
1842     PMOP *newpm;
1843     I32 gimme;
1844
1845     if (PL_op->op_flags & OPf_SPECIAL) {
1846         cx = &cxstack[cxstack_ix];
1847         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1848     }
1849
1850     POPBLOCK(cx,newpm);
1851
1852     gimme = OP_GIMME(PL_op, -1);
1853     if (gimme == -1) {
1854         if (cxstack_ix >= 0)
1855             gimme = cxstack[cxstack_ix].blk_gimme;
1856         else
1857             gimme = G_SCALAR;
1858     }
1859
1860     TAINT_NOT;
1861     if (gimme == G_VOID)
1862         SP = newsp;
1863     else if (gimme == G_SCALAR) {
1864         register SV **mark;
1865         MARK = newsp + 1;
1866         if (MARK <= SP) {
1867             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1868                 *MARK = TOPs;
1869             else
1870                 *MARK = sv_mortalcopy(TOPs);
1871         } else {
1872             MEXTEND(mark,0);
1873             *MARK = &PL_sv_undef;
1874         }
1875         SP = MARK;
1876     }
1877     else if (gimme == G_ARRAY) {
1878         /* in case LEAVE wipes old return values */
1879         register SV **mark;
1880         for (mark = newsp + 1; mark <= SP; mark++) {
1881             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1882                 *mark = sv_mortalcopy(*mark);
1883                 TAINT_NOT;      /* Each item is independent */
1884             }
1885         }
1886     }
1887     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1888
1889     LEAVE;
1890
1891     RETURN;
1892 }
1893
1894 PP(pp_iter)
1895 {
1896     dVAR; dSP;
1897     register PERL_CONTEXT *cx;
1898     SV *sv, *oldsv;
1899     AV* av;
1900     SV **itersvp;
1901
1902     EXTEND(SP, 1);
1903     cx = &cxstack[cxstack_ix];
1904     if (CxTYPE(cx) != CXt_LOOP)
1905         DIE(aTHX_ "panic: pp_iter");
1906
1907     itersvp = CxITERVAR(cx);
1908     av = cx->blk_loop.iterary;
1909     if (SvTYPE(av) != SVt_PVAV) {
1910         /* iterate ($min .. $max) */
1911         if (cx->blk_loop.iterlval) {
1912             /* string increment */
1913             register SV* cur = cx->blk_loop.iterlval;
1914             STRLEN maxlen = 0;
1915             const char *max =
1916               SvOK((SV*)av) ?
1917               SvPV_const((SV*)av, maxlen) : (const char *)"";
1918             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1919                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1920                     /* safe to reuse old SV */
1921                     sv_setsv(*itersvp, cur);
1922                 }
1923                 else
1924                 {
1925                     /* we need a fresh SV every time so that loop body sees a
1926                      * completely new SV for closures/references to work as
1927                      * they used to */
1928                     oldsv = *itersvp;
1929                     *itersvp = newSVsv(cur);
1930                     SvREFCNT_dec(oldsv);
1931                 }
1932                 if (strEQ(SvPVX_const(cur), max))
1933                     sv_setiv(cur, 0); /* terminate next time */
1934                 else
1935                     sv_inc(cur);
1936                 RETPUSHYES;
1937             }
1938             RETPUSHNO;
1939         }
1940         /* integer increment */
1941         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1942             RETPUSHNO;
1943
1944         /* don't risk potential race */
1945         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1946             /* safe to reuse old SV */
1947             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1948         }
1949         else
1950         {
1951             /* we need a fresh SV every time so that loop body sees a
1952              * completely new SV for closures/references to work as they
1953              * used to */
1954             oldsv = *itersvp;
1955             *itersvp = newSViv(cx->blk_loop.iterix++);
1956             SvREFCNT_dec(oldsv);
1957         }
1958         RETPUSHYES;
1959     }
1960
1961     /* iterate array */
1962     if (PL_op->op_private & OPpITER_REVERSED) {
1963         /* In reverse, use itermax as the min :-)  */
1964         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1965             RETPUSHNO;
1966
1967         if (SvMAGICAL(av) || AvREIFY(av)) {
1968             SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1969             sv = svp ? *svp : NULL;
1970         }
1971         else {
1972             sv = AvARRAY(av)[--cx->blk_loop.iterix];
1973         }
1974     }
1975     else {
1976         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1977                                     AvFILL(av)))
1978             RETPUSHNO;
1979
1980         if (SvMAGICAL(av) || AvREIFY(av)) {
1981             SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1982             sv = svp ? *svp : NULL;
1983         }
1984         else {
1985             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1986         }
1987     }
1988
1989     if (sv && SvIS_FREED(sv)) {
1990         *itersvp = NULL;
1991         Perl_croak(aTHX_ "Use of freed value in iteration");
1992     }
1993
1994     if (sv)
1995         SvTEMP_off(sv);
1996     else
1997         sv = &PL_sv_undef;
1998     if (av != PL_curstack && sv == &PL_sv_undef) {
1999         SV *lv = cx->blk_loop.iterlval;
2000         if (lv && SvREFCNT(lv) > 1) {
2001             SvREFCNT_dec(lv);
2002             lv = NULL;
2003         }
2004         if (lv)
2005             SvREFCNT_dec(LvTARG(lv));
2006         else {
2007             lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
2008             LvTYPE(lv) = 'y';
2009             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2010         }
2011         LvTARG(lv) = SvREFCNT_inc_simple(av);
2012         LvTARGOFF(lv) = cx->blk_loop.iterix;
2013         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2014         sv = (SV*)lv;
2015     }
2016
2017     oldsv = *itersvp;
2018     *itersvp = SvREFCNT_inc_simple_NN(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     bool rxtainted;
2040     char *orig;
2041     I32 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 (cx->blk_sub.lval & 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 (cx->blk_sub.lval) {     /* 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) == 100 && ckWARN(WARN_RECURSION)
2819             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2820             sub_crush_depth(cv);
2821 #if 0
2822         DEBUG_S(PerlIO_printf(Perl_debug_log,
2823                               "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2824 #endif
2825         RETURNOP(CvSTART(cv));
2826     }
2827     else {
2828         I32 markix = TOPMARK;
2829
2830         PUTBACK;
2831
2832         if (!hasargs) {
2833             /* Need to copy @_ to stack. Alternative may be to
2834              * switch stack to @_, and copy return values
2835              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2836             AV * const av = GvAV(PL_defgv);
2837             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2838
2839             if (items) {
2840                 /* Mark is at the end of the stack. */
2841                 EXTEND(SP, items);
2842                 Copy(AvARRAY(av), SP + 1, items, SV*);
2843                 SP += items;
2844                 PUTBACK ;
2845             }
2846         }
2847         /* We assume first XSUB in &DB::sub is the called one. */
2848         if (PL_curcopdb) {
2849             SAVEVPTR(PL_curcop);
2850             PL_curcop = PL_curcopdb;
2851             PL_curcopdb = NULL;
2852         }
2853         /* Do we need to open block here? XXXX */
2854         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2855             (void)(*CvXSUB(cv))(aTHX_ cv);
2856
2857         /* Enforce some sanity in scalar context. */
2858         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2859             if (markix > PL_stack_sp - PL_stack_base)
2860                 *(PL_stack_base + markix) = &PL_sv_undef;
2861             else
2862                 *(PL_stack_base + markix) = *PL_stack_sp;
2863             PL_stack_sp = PL_stack_base + markix;
2864         }
2865         LEAVE;
2866         return NORMAL;
2867     }
2868 }
2869
2870 void
2871 Perl_sub_crush_depth(pTHX_ CV *cv)
2872 {
2873     if (CvANON(cv))
2874         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2875     else {
2876         SV* const tmpstr = sv_newmortal();
2877         gv_efullname3(tmpstr, CvGV(cv), NULL);
2878         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2879                     SVfARG(tmpstr));
2880     }
2881 }
2882
2883 PP(pp_aelem)
2884 {
2885     dVAR; dSP;
2886     SV** svp;
2887     SV* const elemsv = POPs;
2888     IV elem = SvIV(elemsv);
2889     AV* const av = (AV*)POPs;
2890     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2891     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2892     SV *sv;
2893
2894     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2895         Perl_warner(aTHX_ packWARN(WARN_MISC),
2896                     "Use of reference \"%"SVf"\" as array index",
2897                     SVfARG(elemsv));
2898     if (elem > 0)
2899         elem -= CopARYBASE_get(PL_curcop);
2900     if (SvTYPE(av) != SVt_PVAV)
2901         RETPUSHUNDEF;
2902     svp = av_fetch(av, elem, lval && !defer);
2903     if (lval) {
2904 #ifdef PERL_MALLOC_WRAP
2905          if (SvUOK(elemsv)) {
2906               const UV uv = SvUV(elemsv);
2907               elem = uv > IV_MAX ? IV_MAX : uv;
2908          }
2909          else if (SvNOK(elemsv))
2910               elem = (IV)SvNV(elemsv);
2911          if (elem > 0) {
2912               static const char oom_array_extend[] =
2913                 "Out of memory during array extend"; /* Duplicated in av.c */
2914               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2915          }
2916 #endif
2917         if (!svp || *svp == &PL_sv_undef) {
2918             SV* lv;
2919             if (!defer)
2920                 DIE(aTHX_ PL_no_aelem, elem);
2921             lv = sv_newmortal();
2922             sv_upgrade(lv, SVt_PVLV);
2923             LvTYPE(lv) = 'y';
2924             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2925             LvTARG(lv) = SvREFCNT_inc_simple(av);
2926             LvTARGOFF(lv) = elem;
2927             LvTARGLEN(lv) = 1;
2928             PUSHs(lv);
2929             RETURN;
2930         }
2931         if (PL_op->op_private & OPpLVAL_INTRO)
2932             save_aelem(av, elem, svp);
2933         else if (PL_op->op_private & OPpDEREF)
2934             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2935     }
2936     sv = (svp ? *svp : &PL_sv_undef);
2937     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2938         sv = sv_mortalcopy(sv);
2939     PUSHs(sv);
2940     RETURN;
2941 }
2942
2943 void
2944 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
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     if (!sv)
3009         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3010
3011     SvGETMAGIC(sv);
3012     if (SvROK(sv))
3013         ob = (SV*)SvRV(sv);
3014     else {
3015         GV* iogv;
3016
3017         /* this isn't a reference */
3018         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3019           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3020           if (he) {
3021             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3022             goto fetch;
3023           }
3024         }
3025
3026         if (!SvOK(sv) ||
3027             !(packname) ||
3028             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3029             !(ob=(SV*)GvIO(iogv)))
3030         {
3031             /* this isn't the name of a filehandle either */
3032             if (!packname ||
3033                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3034                     ? !isIDFIRST_utf8((U8*)packname)
3035                     : !isIDFIRST(*packname)
3036                 ))
3037             {
3038                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3039                            SvOK(sv) ? "without a package or object reference"
3040                                     : "on an undefined value");
3041             }
3042             /* assume it's a package name */
3043             stash = gv_stashpvn(packname, packlen, 0);
3044             if (!stash)
3045                 packsv = sv;
3046             else {
3047                 SV* const ref = newSViv(PTR2IV(stash));
3048                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3049             }
3050             goto fetch;
3051         }
3052         /* it _is_ a filehandle name -- replace with a reference */
3053         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3054     }
3055
3056     /* if we got here, ob should be a reference or a glob */
3057     if (!ob || !(SvOBJECT(ob)
3058                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3059                      && SvOBJECT(ob))))
3060     {
3061         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3062                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3063                    name);
3064     }
3065
3066     stash = SvSTASH(ob);
3067
3068   fetch:
3069     /* NOTE: stash may be null, hope hv_fetch_ent and
3070        gv_fetchmethod can cope (it seems they can) */
3071
3072     /* shortcut for simple names */
3073     if (hashp) {
3074         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3075         if (he) {
3076             gv = (GV*)HeVAL(he);
3077             if (isGV(gv) && GvCV(gv) &&
3078                 (!GvCVGEN(gv) || GvCVGEN(gv)
3079                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3080                 return (SV*)GvCV(gv);
3081         }
3082     }
3083
3084     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3085
3086     if (!gv) {
3087         /* This code tries to figure out just what went wrong with
3088            gv_fetchmethod.  It therefore needs to duplicate a lot of
3089            the internals of that function.  We can't move it inside
3090            Perl_gv_fetchmethod_autoload(), however, since that would
3091            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3092            don't want that.
3093         */
3094         const char* leaf = name;
3095         const char* sep = NULL;
3096         const char* p;
3097
3098         for (p = name; *p; p++) {
3099             if (*p == '\'')
3100                 sep = p, leaf = p + 1;
3101             else if (*p == ':' && *(p + 1) == ':')
3102                 sep = p, leaf = p + 2;
3103         }
3104         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3105             /* the method name is unqualified or starts with SUPER:: */
3106 #ifndef USE_ITHREADS
3107             if (sep)
3108                 stash = CopSTASH(PL_curcop);
3109 #else
3110             bool need_strlen = 1;
3111             if (sep) {
3112                 packname = CopSTASHPV(PL_curcop);
3113             }
3114             else
3115 #endif
3116             if (stash) {
3117                 HEK * const packhek = HvNAME_HEK(stash);
3118                 if (packhek) {
3119                     packname = HEK_KEY(packhek);
3120                     packlen = HEK_LEN(packhek);
3121 #ifdef USE_ITHREADS
3122                     need_strlen = 0;
3123 #endif
3124                 } else {
3125                     goto croak;
3126                 }
3127             }
3128
3129             if (!packname) {
3130             croak:
3131                 Perl_croak(aTHX_
3132                            "Can't use anonymous symbol table for method lookup");
3133             }
3134 #ifdef USE_ITHREADS
3135             if (need_strlen)
3136                 packlen = strlen(packname);
3137 #endif
3138
3139         }
3140         else {
3141             /* the method name is qualified */
3142             packname = name;
3143             packlen = sep - name;
3144         }
3145
3146         /* we're relying on gv_fetchmethod not autovivifying the stash */
3147         if (gv_stashpvn(packname, packlen, 0)) {
3148             Perl_croak(aTHX_
3149                        "Can't locate object method \"%s\" via package \"%.*s\"",
3150                        leaf, (int)packlen, packname);
3151         }
3152         else {
3153             Perl_croak(aTHX_
3154                        "Can't locate object method \"%s\" via package \"%.*s\""
3155                        " (perhaps you forgot to load \"%.*s\"?)",
3156                        leaf, (int)packlen, packname, (int)packlen, packname);
3157         }
3158     }
3159     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3160 }
3161
3162 /*
3163  * Local variables:
3164  * c-indentation-style: bsd
3165  * c-basic-offset: 4
3166  * indent-tabs-mode: t
3167  * End:
3168  *
3169  * ex: set ts=8 sts=4 sw=4 noet:
3170  */