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