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