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