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