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