pp_hot.c

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