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