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