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