pp_hot.c

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