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) && !SvIsCOW(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 *oldsv;
1901     SV **itersvp;
1902
1903     EXTEND(SP, 1);
1904     cx = &cxstack[cxstack_ix];
1905     itersvp = CxITERVAR(cx);
1906
1907     switch (CxTYPE(cx)) {
1908     case CXt_LOOP_LAZYSV:
1909         {
1910             /* string increment */
1911             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1912             SV *end = cx->blk_loop.state_u.lazysv.end;
1913             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1914                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1915             STRLEN maxlen = 0;
1916             const char *max = SvPV_const(end, maxlen);
1917             if (SvNIOK(cur) || SvCUR(cur) > maxlen)
1918                 RETPUSHNO;
1919
1920             oldsv = *itersvp;
1921             if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1922                 /* safe to reuse old SV */
1923                 sv_setsv(oldsv, cur);
1924             }
1925             else
1926             {
1927                 /* we need a fresh SV every time so that loop body sees a
1928                  * completely new SV for closures/references to work as
1929                  * they used to */
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             break;
1938         }
1939
1940     case CXt_LOOP_LAZYIV: /* integer increment */
1941     {
1942         IV cur = cx->blk_loop.state_u.lazyiv.cur;
1943         if (cur > cx->blk_loop.state_u.lazyiv.end)
1944             RETPUSHNO;
1945
1946         oldsv = *itersvp;
1947         /* don't risk potential race */
1948         if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1949             /* safe to reuse old SV */
1950             sv_setiv(oldsv, cur);
1951         }
1952         else
1953         {
1954             /* we need a fresh SV every time so that loop body sees a
1955              * completely new SV for closures/references to work as they
1956              * used to */
1957             *itersvp = newSViv(cur);
1958             SvREFCNT_dec(oldsv);
1959         }
1960
1961         if (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         break;
1967     }
1968
1969     case CXt_LOOP_FOR:
1970     {
1971
1972         /* iterate array */
1973         AV *av = cx->blk_loop.state_u.ary.ary;
1974         SV *sv;
1975         bool av_is_stack = FALSE;
1976         IV ix;
1977
1978         if (!av) {
1979             av_is_stack = TRUE;
1980             av = PL_curstack;
1981         }
1982         if (PL_op->op_private & OPpITER_REVERSED) {
1983             ix = --cx->blk_loop.state_u.ary.ix;
1984             if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
1985                 RETPUSHNO;
1986         }
1987         else {
1988             ix = ++cx->blk_loop.state_u.ary.ix;
1989             if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
1990                 RETPUSHNO;
1991         }
1992
1993         if (SvMAGICAL(av) || AvREIFY(av)) {
1994             SV * const * const svp = av_fetch(av, ix, FALSE);
1995             sv = svp ? *svp : NULL;
1996         }
1997         else {
1998             sv = AvARRAY(av)[ix];
1999         }
2000
2001         if (sv) {
2002             if (SvIS_FREED(sv)) {
2003                 *itersvp = NULL;
2004                 Perl_croak(aTHX_ "Use of freed value in iteration");
2005             }
2006             SvTEMP_off(sv);
2007             SvREFCNT_inc_simple_void_NN(sv);
2008         }
2009         else
2010             sv = &PL_sv_undef;
2011
2012         if (!av_is_stack && sv == &PL_sv_undef) {
2013             SV *lv = newSV_type(SVt_PVLV);
2014             LvTYPE(lv) = 'y';
2015             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2016             LvTARG(lv) = SvREFCNT_inc_simple(av);
2017             LvTARGOFF(lv) = ix;
2018             LvTARGLEN(lv) = (STRLEN)UV_MAX;
2019             sv = lv;
2020         }
2021
2022         oldsv = *itersvp;
2023         *itersvp = sv;
2024         SvREFCNT_dec(oldsv);
2025         break;
2026     }
2027
2028     default:
2029         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2030     }
2031         RETPUSHYES;
2032 }
2033
2034 /*
2035 A description of how taint works in pattern matching and substitution.
2036
2037 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2038 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2039
2040 While the pattern is being assembled/concatenated and then compiled,
2041 PL_tainted will get set (via TAINT_set) if any component of the pattern
2042 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
2043 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2044 TAINT_get).
2045
2046 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2047 the pattern is marked as tainted. This means that subsequent usage, such
2048 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2049 on the new pattern too.
2050
2051 During execution of a pattern, locale-variant ops such as ALNUML set the
2052 local flag RF_tainted. At the end of execution, the engine sets the
2053 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2054 otherwise.
2055
2056 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2057 of $1 et al to indicate whether the returned value should be tainted.
2058 It is the responsibility of the caller of the pattern (i.e. pp_match,
2059 pp_subst etc) to set this flag for any other circumstances where $1 needs
2060 to be tainted.
2061
2062 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2063
2064 There are three possible sources of taint
2065     * the source string
2066     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2067     * the replacement string (or expression under /e)
2068
2069 There are four destinations of taint and they are affected by the sources
2070 according to the rules below:
2071
2072     * the return value (not including /r):
2073         tainted by the source string and pattern, but only for the
2074         number-of-iterations case; boolean returns aren't tainted;
2075     * the modified string (or modified copy under /r):
2076         tainted by the source string, pattern, and replacement strings;
2077     * $1 et al:
2078         tainted by the pattern, and under 'use re "taint"', by the source
2079         string too;
2080     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2081         should always be unset before executing subsequent code.
2082
2083 The overall action of pp_subst is:
2084
2085     * at the start, set bits in rxtainted indicating the taint status of
2086         the various sources.
2087
2088     * After each pattern execution, update the SUBST_TAINT_PAT bit in
2089         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2090         pattern has subsequently become tainted via locale ops.
2091
2092     * If control is being passed to pp_substcont to execute a /e block,
2093         save rxtainted in the CXt_SUBST block, for future use by
2094         pp_substcont.
2095
2096     * Whenever control is being returned to perl code (either by falling
2097         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2098         use the flag bits in rxtainted to make all the appropriate types of
2099         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2100         et al will appear tainted.
2101
2102 pp_match is just a simpler version of the above.
2103
2104 */
2105
2106 PP(pp_subst)
2107 {
2108     dVAR; dSP; dTARG;
2109     PMOP *pm = cPMOP;
2110     PMOP *rpm = pm;
2111     char *s;
2112     char *strend;
2113     char *m;
2114     const char *c;
2115     char *d;
2116     STRLEN clen;
2117     I32 iters = 0;
2118     I32 maxiters;
2119     I32 i;
2120     bool once;
2121     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2122                         See "how taint works" above */
2123     char *orig;
2124     U8 r_flags;
2125     REGEXP *rx = PM_GETRE(pm);
2126     STRLEN len;
2127     int force_on_match = 0;
2128     const I32 oldsave = PL_savestack_ix;
2129     STRLEN slen;
2130     bool doutf8 = FALSE; /* whether replacement is in utf8 */
2131 #ifdef PERL_OLD_COPY_ON_WRITE
2132     bool is_cow;
2133 #endif
2134     SV *nsv = NULL;
2135     /* known replacement string? */
2136     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2137
2138     PERL_ASYNC_CHECK();
2139
2140     if (PL_op->op_flags & OPf_STACKED)
2141         TARG = POPs;
2142     else if (PL_op->op_private & OPpTARGET_MY)
2143         GETTARGET;
2144     else {
2145         TARG = DEFSV;
2146         EXTEND(SP,1);
2147     }
2148
2149     SvGETMAGIC(TARG); /* must come before cow check */
2150 #ifdef PERL_OLD_COPY_ON_WRITE
2151     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2152        because they make integers such as 256 "false".  */
2153     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2154 #else
2155     if (SvIsCOW(TARG))
2156         sv_force_normal_flags(TARG,0);
2157 #endif
2158     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2159 #ifdef PERL_OLD_COPY_ON_WRITE
2160         && !is_cow
2161 #endif
2162         && (SvREADONLY(TARG)
2163             || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2164                   || SvTYPE(TARG) > SVt_PVLV)
2165                  && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2166         Perl_croak_no_modify();
2167     PUTBACK;
2168
2169     s = SvPV_nomg(TARG, len);
2170     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2171         force_on_match = 1;
2172
2173     /* only replace once? */
2174     once = !(rpm->op_pmflags & PMf_GLOBAL);
2175
2176     /* See "how taint works" above */
2177     if (TAINTING_get) {
2178         rxtainted  = (
2179             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2180           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2181           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2182           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2183                 ? SUBST_TAINT_BOOLRET : 0));
2184         TAINT_NOT;
2185     }
2186
2187     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2188
2189   force_it:
2190     if (!pm || !s)
2191         DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2192
2193     strend = s + len;
2194     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2195     maxiters = 2 * slen + 10;   /* We can match twice at each
2196                                    position, once with zero-length,
2197                                    second time with non-zero. */
2198
2199     if (!RX_PRELEN(rx) && PL_curpm
2200      && !ReANY(rx)->mother_re) {
2201         pm = PL_curpm;
2202         rx = PM_GETRE(pm);
2203     }
2204
2205     r_flags = (    RX_NPARENS(rx)
2206                 || PL_sawampersand
2207                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2208               )
2209           ? REXEC_COPY_STR
2210           : 0;
2211
2212     orig = m = s;
2213     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2214         PL_bostr = orig;
2215         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2216
2217         if (!s)
2218             goto ret_no;
2219         /* How to do it in subst? */
2220 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2221              && !PL_sawampersand
2222              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
2223             goto yup;
2224 */
2225     }
2226
2227     if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2228                          r_flags | REXEC_CHECKED))
2229     {
2230       ret_no:
2231         SPAGAIN;
2232         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2233         LEAVE_SCOPE(oldsave);
2234         RETURN;
2235     }
2236
2237     PL_curpm = pm;
2238
2239     /* known replacement string? */
2240     if (dstr) {
2241         /* replacement needing upgrading? */
2242         if (DO_UTF8(TARG) && !doutf8) {
2243              nsv = sv_newmortal();
2244              SvSetSV(nsv, dstr);
2245              if (PL_encoding)
2246                   sv_recode_to_utf8(nsv, PL_encoding);
2247              else
2248                   sv_utf8_upgrade(nsv);
2249              c = SvPV_const(nsv, clen);
2250              doutf8 = TRUE;
2251         }
2252         else {
2253             c = SvPV_const(dstr, clen);
2254             doutf8 = DO_UTF8(dstr);
2255         }
2256
2257         if (SvTAINTED(dstr))
2258             rxtainted |= SUBST_TAINT_REPL;
2259     }
2260     else {
2261         c = NULL;
2262         doutf8 = FALSE;
2263     }
2264
2265     /* can do inplace substitution? */
2266     if (c
2267 #ifdef PERL_OLD_COPY_ON_WRITE
2268         && !is_cow
2269 #endif
2270         && (I32)clen <= RX_MINLENRET(rx)
2271         && (once || !(r_flags & REXEC_COPY_STR))
2272         && !(RX_EXTFLAGS(rx) & (RXf_LOOKBEHIND_SEEN|RXf_MODIFIES_VARS))
2273         && (!doutf8 || SvUTF8(TARG))
2274         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2275     {
2276
2277 #ifdef PERL_OLD_COPY_ON_WRITE
2278         if (SvIsCOW(TARG)) {
2279             assert (!force_on_match);
2280             goto have_a_cow;
2281         }
2282 #endif
2283         if (force_on_match) {
2284             force_on_match = 0;
2285             s = SvPV_force_nomg(TARG, len);
2286             goto force_it;
2287         }
2288         d = s;
2289         if (once) {
2290             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2291                 rxtainted |= SUBST_TAINT_PAT;
2292             m = orig + RX_OFFS(rx)[0].start;
2293             d = orig + RX_OFFS(rx)[0].end;
2294             s = orig;
2295             if (m - s > strend - d) {  /* faster to shorten from end */
2296                 if (clen) {
2297                     Copy(c, m, clen, char);
2298                     m += clen;
2299                 }
2300                 i = strend - d;
2301                 if (i > 0) {
2302                     Move(d, m, i, char);
2303                     m += i;
2304                 }
2305                 *m = '\0';
2306                 SvCUR_set(TARG, m - s);
2307             }
2308             else if ((i = m - s)) {     /* faster from front */
2309                 d -= clen;
2310                 m = d;
2311                 Move(s, d - i, i, char);
2312                 sv_chop(TARG, d-i);
2313                 if (clen)
2314                     Copy(c, m, clen, char);
2315             }
2316             else if (clen) {
2317                 d -= clen;
2318                 sv_chop(TARG, d);
2319                 Copy(c, d, clen, char);
2320             }
2321             else {
2322                 sv_chop(TARG, d);
2323             }
2324             SPAGAIN;
2325             PUSHs(&PL_sv_yes);
2326         }
2327         else {
2328             do {
2329                 if (iters++ > maxiters)
2330                     DIE(aTHX_ "Substitution loop");
2331                 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2332                     rxtainted |= SUBST_TAINT_PAT;
2333                 m = RX_OFFS(rx)[0].start + orig;
2334                 if ((i = m - s)) {
2335                     if (s != d)
2336                         Move(s, d, i, char);
2337                     d += i;
2338                 }
2339                 if (clen) {
2340                     Copy(c, d, clen, char);
2341                     d += clen;
2342                 }
2343                 s = RX_OFFS(rx)[0].end + orig;
2344             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2345                                  TARG, NULL,
2346                                  /* don't match same null twice */
2347                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2348             if (s != d) {
2349                 i = strend - s;
2350                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2351                 Move(s, d, i+1, char);          /* include the NUL */
2352             }
2353             SPAGAIN;
2354             mPUSHi((I32)iters);
2355         }
2356     }
2357     else {
2358         bool first;
2359         SV *repl;
2360         if (force_on_match) {
2361             force_on_match = 0;
2362             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2363                 /* I feel that it should be possible to avoid this mortal copy
2364                    given that the code below copies into a new destination.
2365                    However, I suspect it isn't worth the complexity of
2366                    unravelling the C<goto force_it> for the small number of
2367                    cases where it would be viable to drop into the copy code. */
2368                 TARG = sv_2mortal(newSVsv(TARG));
2369             }
2370             s = SvPV_force_nomg(TARG, len);
2371             goto force_it;
2372         }
2373 #ifdef PERL_OLD_COPY_ON_WRITE
2374       have_a_cow:
2375 #endif
2376         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2377             rxtainted |= SUBST_TAINT_PAT;
2378         repl = dstr;
2379         dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2380         if (!c) {
2381             PERL_CONTEXT *cx;
2382             SPAGAIN;
2383             /* note that a whole bunch of local vars are saved here for
2384              * use by pp_substcont: here's a list of them in case you're
2385              * searching for places in this sub that uses a particular var:
2386              * iters maxiters r_flags oldsave rxtainted orig dstr targ
2387              * s m strend rx once */
2388             PUSHSUBST(cx);
2389             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2390         }
2391         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2392         first = TRUE;
2393         do {
2394             if (iters++ > maxiters)
2395                 DIE(aTHX_ "Substitution loop");
2396             if (RX_MATCH_TAINTED(rx))
2397                 rxtainted |= SUBST_TAINT_PAT;
2398             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2399                 m = s;
2400                 s = orig;
2401                 assert(RX_SUBOFFSET(rx) == 0);
2402                 orig = RX_SUBBEG(rx);
2403                 s = orig + (m - s);
2404                 strend = s + (strend - m);
2405             }
2406             m = RX_OFFS(rx)[0].start + orig;
2407             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2408             s = RX_OFFS(rx)[0].end + orig;
2409             if (first) {
2410                 /* replacement already stringified */
2411               if (clen)
2412                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2413               first = FALSE;
2414             }
2415             else {
2416                 if (PL_encoding) {
2417                     if (!nsv) nsv = sv_newmortal();
2418                     sv_copypv(nsv, repl);
2419                     if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2420                     sv_catsv(dstr, nsv);
2421                 }
2422                 else sv_catsv(dstr, repl);
2423                 if (SvTAINTED(repl))
2424                     rxtainted |= SUBST_TAINT_REPL;
2425             }
2426             if (once)
2427                 break;
2428         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2429                              TARG, NULL, r_flags));
2430         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2431
2432         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2433             /* From here on down we're using the copy, and leaving the original
2434                untouched.  */
2435             TARG = dstr;
2436             SPAGAIN;
2437             PUSHs(dstr);
2438         } else {
2439 #ifdef PERL_OLD_COPY_ON_WRITE
2440             /* The match may make the string COW. If so, brilliant, because
2441                that's just saved us one malloc, copy and free - the regexp has
2442                donated the old buffer, and we malloc an entirely new one, rather
2443                than the regexp malloc()ing a buffer and copying our original,
2444                only for us to throw it away here during the substitution.  */
2445             if (SvIsCOW(TARG)) {
2446                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2447             } else
2448 #endif
2449             {
2450                 SvPV_free(TARG);
2451             }
2452             SvPV_set(TARG, SvPVX(dstr));
2453             SvCUR_set(TARG, SvCUR(dstr));
2454             SvLEN_set(TARG, SvLEN(dstr));
2455             SvFLAGS(TARG) |= SvUTF8(dstr);
2456             SvPV_set(dstr, NULL);
2457
2458             SPAGAIN;
2459             mPUSHi((I32)iters);
2460         }
2461     }
2462
2463     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2464         (void)SvPOK_only_UTF8(TARG);
2465     }
2466
2467     /* See "how taint works" above */
2468     if (TAINTING_get) {
2469         if ((rxtainted & SUBST_TAINT_PAT) ||
2470             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2471                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2472         )
2473             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2474
2475         if (!(rxtainted & SUBST_TAINT_BOOLRET)
2476             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2477         )
2478             SvTAINTED_on(TOPs);  /* taint return value */
2479         else
2480             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
2481
2482         /* needed for mg_set below */
2483         TAINT_set(
2484           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2485         );
2486         SvTAINT(TARG);
2487     }
2488     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2489     TAINT_NOT;
2490     LEAVE_SCOPE(oldsave);
2491     RETURN;
2492 }
2493
2494 PP(pp_grepwhile)
2495 {
2496     dVAR; dSP;
2497
2498     if (SvTRUEx(POPs))
2499         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2500     ++*PL_markstack_ptr;
2501     FREETMPS;
2502     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2503
2504     /* All done yet? */
2505     if (PL_stack_base + *PL_markstack_ptr > SP) {
2506         I32 items;
2507         const I32 gimme = GIMME_V;
2508
2509         LEAVE_with_name("grep");                                        /* exit outer scope */
2510         (void)POPMARK;                          /* pop src */
2511         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2512         (void)POPMARK;                          /* pop dst */
2513         SP = PL_stack_base + POPMARK;           /* pop original mark */
2514         if (gimme == G_SCALAR) {
2515             if (PL_op->op_private & OPpGREP_LEX) {
2516                 SV* const sv = sv_newmortal();
2517                 sv_setiv(sv, items);
2518                 PUSHs(sv);
2519             }
2520             else {
2521                 dTARGET;
2522                 XPUSHi(items);
2523             }
2524         }
2525         else if (gimme == G_ARRAY)
2526             SP += items;
2527         RETURN;
2528     }
2529     else {
2530         SV *src;
2531
2532         ENTER_with_name("grep_item");                                   /* enter inner scope */
2533         SAVEVPTR(PL_curpm);
2534
2535         src = PL_stack_base[*PL_markstack_ptr];
2536         SvTEMP_off(src);
2537         if (PL_op->op_private & OPpGREP_LEX)
2538             PAD_SVl(PL_op->op_targ) = src;
2539         else
2540             DEFSV_set(src);
2541
2542         RETURNOP(cLOGOP->op_other);
2543     }
2544 }
2545
2546 PP(pp_leavesub)
2547 {
2548     dVAR; dSP;
2549     SV **mark;
2550     SV **newsp;
2551     PMOP *newpm;
2552     I32 gimme;
2553     PERL_CONTEXT *cx;
2554     SV *sv;
2555
2556     if (CxMULTICALL(&cxstack[cxstack_ix]))
2557         return 0;
2558
2559     POPBLOCK(cx,newpm);
2560     cxstack_ix++; /* temporarily protect top context */
2561
2562     TAINT_NOT;
2563     if (gimme == G_SCALAR) {
2564         MARK = newsp + 1;
2565         if (MARK <= SP) {
2566             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2567                 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2568                      && !SvMAGICAL(TOPs)) {
2569                     *MARK = SvREFCNT_inc(TOPs);
2570                     FREETMPS;
2571                     sv_2mortal(*MARK);
2572                 }
2573                 else {
2574                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2575                     FREETMPS;
2576                     *MARK = sv_mortalcopy(sv);
2577                     SvREFCNT_dec(sv);
2578                 }
2579             }
2580             else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2581                      && !SvMAGICAL(TOPs)) {
2582                 *MARK = TOPs;
2583             }
2584             else
2585                 *MARK = sv_mortalcopy(TOPs);
2586         }
2587         else {
2588             MEXTEND(MARK, 0);
2589             *MARK = &PL_sv_undef;
2590         }
2591         SP = MARK;
2592     }
2593     else if (gimme == G_ARRAY) {
2594         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2595             if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2596                  || SvMAGICAL(*MARK)) {
2597                 *MARK = sv_mortalcopy(*MARK);
2598                 TAINT_NOT;      /* Each item is independent */
2599             }
2600         }
2601     }
2602     PUTBACK;
2603
2604     LEAVE;
2605     cxstack_ix--;
2606     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2607     PL_curpm = newpm;   /* ... and pop $1 et al */
2608
2609     LEAVESUB(sv);
2610     return cx->blk_sub.retop;
2611 }
2612
2613 PP(pp_entersub)
2614 {
2615     dVAR; dSP; dPOPss;
2616     GV *gv;
2617     CV *cv;
2618     PERL_CONTEXT *cx;
2619     I32 gimme;
2620     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2621
2622     if (!sv)
2623         DIE(aTHX_ "Not a CODE reference");
2624     switch (SvTYPE(sv)) {
2625         /* This is overwhelming the most common case:  */
2626     case SVt_PVGV:
2627       we_have_a_glob:
2628         if (!(cv = GvCVu((const GV *)sv))) {
2629             HV *stash;
2630             cv = sv_2cv(sv, &stash, &gv, 0);
2631         }
2632         if (!cv) {
2633             ENTER;
2634             SAVETMPS;
2635             goto try_autoload;
2636         }
2637         break;
2638     case SVt_PVLV:
2639         if(isGV_with_GP(sv)) goto we_have_a_glob;
2640         /*FALLTHROUGH*/
2641     default:
2642         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2643             if (hasargs)
2644                 SP = PL_stack_base + POPMARK;
2645             else
2646                 (void)POPMARK;
2647             RETURN;
2648         }
2649         SvGETMAGIC(sv);
2650         if (SvROK(sv)) {
2651             if (SvAMAGIC(sv)) {
2652                 sv = amagic_deref_call(sv, to_cv_amg);
2653                 /* Don't SPAGAIN here.  */
2654             }
2655         }
2656         else {
2657             const char *sym;
2658             STRLEN len;
2659             if (!SvOK(sv))
2660                 DIE(aTHX_ PL_no_usym, "a subroutine");
2661             sym = SvPV_nomg_const(sv, len);
2662             if (PL_op->op_private & HINT_STRICT_REFS)
2663                 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2664             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2665             break;
2666         }
2667         cv = MUTABLE_CV(SvRV(sv));
2668         if (SvTYPE(cv) == SVt_PVCV)
2669             break;
2670         /* FALL THROUGH */
2671     case SVt_PVHV:
2672     case SVt_PVAV:
2673         DIE(aTHX_ "Not a CODE reference");
2674         /* This is the second most common case:  */
2675     case SVt_PVCV:
2676         cv = MUTABLE_CV(sv);
2677         break;
2678     }
2679
2680     ENTER;
2681     SAVETMPS;
2682
2683   retry:
2684     if (CvCLONE(cv) && ! CvCLONED(cv))
2685         DIE(aTHX_ "Closure prototype called");
2686     if (!CvROOT(cv) && !CvXSUB(cv)) {
2687         GV* autogv;
2688         SV* sub_name;
2689
2690         /* anonymous or undef'd function leaves us no recourse */
2691         if (CvANON(cv) || !(gv = CvGV(cv))) {
2692             if (CvNAMED(cv))
2693                 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2694                            HEKfARG(CvNAME_HEK(cv)));
2695             DIE(aTHX_ "Undefined subroutine called");
2696         }
2697
2698         /* autoloaded stub? */
2699         if (cv != GvCV(gv)) {
2700             cv = GvCV(gv);
2701         }
2702         /* should call AUTOLOAD now? */
2703         else {
2704 try_autoload:
2705             if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2706                                    GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2707             {
2708                 cv = GvCV(autogv);
2709             }
2710             else {
2711                sorry:
2712                 sub_name = sv_newmortal();
2713                 gv_efullname3(sub_name, gv, NULL);
2714                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2715             }
2716         }
2717         if (!cv)
2718             goto sorry;
2719         goto retry;
2720     }
2721
2722     gimme = GIMME_V;
2723     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2724          Perl_get_db_sub(aTHX_ &sv, cv);
2725          if (CvISXSUB(cv))
2726              PL_curcopdb = PL_curcop;
2727          if (CvLVALUE(cv)) {
2728              /* check for lsub that handles lvalue subroutines */
2729              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2730              /* if lsub not found then fall back to DB::sub */
2731              if (!cv) cv = GvCV(PL_DBsub);
2732          } else {
2733              cv = GvCV(PL_DBsub);
2734          }
2735
2736         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2737             DIE(aTHX_ "No DB::sub routine defined");
2738     }
2739
2740     if (!(CvISXSUB(cv))) {
2741         /* This path taken at least 75% of the time   */
2742         dMARK;
2743         I32 items = SP - MARK;
2744         PADLIST * const padlist = CvPADLIST(cv);
2745         PUSHBLOCK(cx, CXt_SUB, MARK);
2746         PUSHSUB(cx);
2747         cx->blk_sub.retop = PL_op->op_next;
2748         CvDEPTH(cv)++;
2749         if (CvDEPTH(cv) >= 2) {
2750             PERL_STACK_OVERFLOW_CHECK();
2751             pad_push(padlist, CvDEPTH(cv));
2752         }
2753         SAVECOMPPAD();
2754         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2755         if (hasargs) {
2756             AV *const av = MUTABLE_AV(PAD_SVl(0));
2757             if (AvREAL(av)) {
2758                 /* @_ is normally not REAL--this should only ever
2759                  * happen when DB::sub() calls things that modify @_ */
2760                 av_clear(av);
2761                 AvREAL_off(av);
2762                 AvREIFY_on(av);
2763             }
2764             cx->blk_sub.savearray = GvAV(PL_defgv);
2765             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2766             CX_CURPAD_SAVE(cx->blk_sub);
2767             cx->blk_sub.argarray = av;
2768             ++MARK;
2769
2770             if (items > AvMAX(av) + 1) {
2771                 SV **ary = AvALLOC(av);
2772                 if (AvARRAY(av) != ary) {
2773                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2774                     AvARRAY(av) = ary;
2775                 }
2776                 if (items > AvMAX(av) + 1) {
2777                     AvMAX(av) = items - 1;
2778                     Renew(ary,items,SV*);
2779                     AvALLOC(av) = ary;
2780                     AvARRAY(av) = ary;
2781                 }
2782             }
2783             Copy(MARK,AvARRAY(av),items,SV*);
2784             AvFILLp(av) = items - 1;
2785
2786             while (items--) {
2787                 if (*MARK)
2788                     SvTEMP_off(*MARK);
2789                 MARK++;
2790             }
2791         }
2792         if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2793             !CvLVALUE(cv))
2794             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2795         /* warning must come *after* we fully set up the context
2796          * stuff so that __WARN__ handlers can safely dounwind()
2797          * if they want to
2798          */
2799         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2800             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2801             sub_crush_depth(cv);
2802         RETURNOP(CvSTART(cv));
2803     }
2804     else {
2805         I32 markix = TOPMARK;
2806
2807         PUTBACK;
2808
2809         if (!hasargs) {
2810             /* Need to copy @_ to stack. Alternative may be to
2811              * switch stack to @_, and copy return values
2812              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2813             AV * const av = GvAV(PL_defgv);
2814             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2815
2816             if (items) {
2817                 /* Mark is at the end of the stack. */
2818                 EXTEND(SP, items);
2819                 Copy(AvARRAY(av), SP + 1, items, SV*);
2820                 SP += items;
2821                 PUTBACK ;
2822             }
2823         }
2824         /* We assume first XSUB in &DB::sub is the called one. */
2825         if (PL_curcopdb) {
2826             SAVEVPTR(PL_curcop);
2827             PL_curcop = PL_curcopdb;
2828             PL_curcopdb = NULL;
2829         }
2830         /* Do we need to open block here? XXXX */
2831
2832         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2833         assert(CvXSUB(cv));
2834         CvXSUB(cv)(aTHX_ cv);
2835
2836         /* Enforce some sanity in scalar context. */
2837         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2838             if (markix > PL_stack_sp - PL_stack_base)
2839                 *(PL_stack_base + markix) = &PL_sv_undef;
2840             else
2841                 *(PL_stack_base + markix) = *PL_stack_sp;
2842             PL_stack_sp = PL_stack_base + markix;
2843         }
2844         LEAVE;
2845         return NORMAL;
2846     }
2847 }
2848
2849 void
2850 Perl_sub_crush_depth(pTHX_ CV *cv)
2851 {
2852     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2853
2854     if (CvANON(cv))
2855         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2856     else {
2857         SV* const tmpstr = sv_newmortal();
2858         gv_efullname3(tmpstr, CvGV(cv), NULL);
2859         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2860                     SVfARG(tmpstr));
2861     }
2862 }
2863
2864 PP(pp_aelem)
2865 {
2866     dVAR; dSP;
2867     SV** svp;
2868     SV* const elemsv = POPs;
2869     IV elem = SvIV(elemsv);
2870     AV *const av = MUTABLE_AV(POPs);
2871     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2872     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2873     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2874     bool preeminent = TRUE;
2875     SV *sv;
2876
2877     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2878         Perl_warner(aTHX_ packWARN(WARN_MISC),
2879                     "Use of reference \"%"SVf"\" as array index",
2880                     SVfARG(elemsv));
2881     if (SvTYPE(av) != SVt_PVAV)
2882         RETPUSHUNDEF;
2883
2884     if (localizing) {
2885         MAGIC *mg;
2886         HV *stash;
2887
2888         /* If we can determine whether the element exist,
2889          * Try to preserve the existenceness of a tied array
2890          * element by using EXISTS and DELETE if possible.
2891          * Fallback to FETCH and STORE otherwise. */
2892         if (SvCANEXISTDELETE(av))
2893             preeminent = av_exists(av, elem);
2894     }
2895
2896     svp = av_fetch(av, elem, lval && !defer);
2897     if (lval) {
2898 #ifdef PERL_MALLOC_WRAP
2899          if (SvUOK(elemsv)) {
2900               const UV uv = SvUV(elemsv);
2901               elem = uv > IV_MAX ? IV_MAX : uv;
2902          }
2903          else if (SvNOK(elemsv))
2904               elem = (IV)SvNV(elemsv);
2905          if (elem > 0) {
2906               static const char oom_array_extend[] =
2907                 "Out of memory during array extend"; /* Duplicated in av.c */
2908               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2909          }
2910 #endif
2911         if (!svp || *svp == &PL_sv_undef) {
2912             SV* lv;
2913             if (!defer)
2914                 DIE(aTHX_ PL_no_aelem, elem);
2915             lv = sv_newmortal();
2916             sv_upgrade(lv, SVt_PVLV);
2917             LvTYPE(lv) = 'y';
2918             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2919             LvTARG(lv) = SvREFCNT_inc_simple(av);
2920             LvTARGOFF(lv) = elem;
2921             LvTARGLEN(lv) = 1;
2922             PUSHs(lv);
2923             RETURN;
2924         }
2925         if (localizing) {
2926             if (preeminent)
2927                 save_aelem(av, elem, svp);
2928             else
2929                 SAVEADELETE(av, elem);
2930         }
2931         else if (PL_op->op_private & OPpDEREF) {
2932             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2933             RETURN;
2934         }
2935     }
2936     sv = (svp ? *svp : &PL_sv_undef);
2937     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2938         mg_get(sv);
2939     PUSHs(sv);
2940     RETURN;
2941 }
2942
2943 SV*
2944 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2945 {
2946     PERL_ARGS_ASSERT_VIVIFY_REF;
2947
2948     SvGETMAGIC(sv);
2949     if (!SvOK(sv)) {
2950         if (SvREADONLY(sv))
2951             Perl_croak_no_modify();
2952         prepare_SV_for_RV(sv);
2953         switch (to_what) {
2954         case OPpDEREF_SV:
2955             SvRV_set(sv, newSV(0));
2956             break;
2957         case OPpDEREF_AV:
2958             SvRV_set(sv, MUTABLE_SV(newAV()));
2959             break;
2960         case OPpDEREF_HV:
2961             SvRV_set(sv, MUTABLE_SV(newHV()));
2962             break;
2963         }
2964         SvROK_on(sv);
2965         SvSETMAGIC(sv);
2966         SvGETMAGIC(sv);
2967     }
2968     if (SvGMAGICAL(sv)) {
2969         /* copy the sv without magic to prevent magic from being
2970            executed twice */
2971         SV* msv = sv_newmortal();
2972         sv_setsv_nomg(msv, sv);
2973         return msv;
2974     }
2975     return sv;
2976 }
2977
2978 PP(pp_method)
2979 {
2980     dVAR; dSP;
2981     SV* const sv = TOPs;
2982
2983     if (SvROK(sv)) {
2984         SV* const rsv = SvRV(sv);
2985         if (SvTYPE(rsv) == SVt_PVCV) {
2986             SETs(rsv);
2987             RETURN;
2988         }
2989     }
2990
2991     SETs(method_common(sv, NULL));
2992     RETURN;
2993 }
2994
2995 PP(pp_method_named)
2996 {
2997     dVAR; dSP;
2998     SV* const sv = cSVOP_sv;
2999     U32 hash = SvSHARED_HASH(sv);
3000
3001     XPUSHs(method_common(sv, &hash));
3002     RETURN;
3003 }
3004
3005 STATIC SV *
3006 S_method_common(pTHX_ SV* meth, U32* hashp)
3007 {
3008     dVAR;
3009     SV* ob;
3010     GV* gv;
3011     HV* stash;
3012     SV *packsv = NULL;
3013     SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
3014         ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3015                             "package or object reference", SVfARG(meth)),
3016            (SV *)NULL)
3017         : *(PL_stack_base + TOPMARK + 1);
3018
3019     PERL_ARGS_ASSERT_METHOD_COMMON;
3020
3021     if (!sv)
3022        undefined:
3023         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3024                    SVfARG(meth));
3025
3026     SvGETMAGIC(sv);
3027     if (SvROK(sv))
3028         ob = MUTABLE_SV(SvRV(sv));
3029     else if (!SvOK(sv)) goto undefined;
3030     else {
3031         /* this isn't a reference */
3032         GV* iogv;
3033         STRLEN packlen;
3034         const char * const packname = SvPV_nomg_const(sv, packlen);
3035         const bool packname_is_utf8 = !!SvUTF8(sv);
3036         const HE* const he =
3037             (const HE *)hv_common(
3038                 PL_stashcache, NULL, packname, packlen,
3039                 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
3040             );
3041
3042         if (he) {
3043             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3044             DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
3045                              stash, sv));
3046             goto fetch;
3047         }
3048
3049         if (!(iogv = gv_fetchpvn_flags(
3050                 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
3051              )) ||
3052             !(ob=MUTABLE_SV(GvIO(iogv))))
3053         {
3054             /* this isn't the name of a filehandle either */
3055             if (!packlen)
3056             {
3057                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3058                                  "without a package or object reference",
3059                                   SVfARG(meth));
3060             }
3061             /* assume it's a package name */
3062             stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3063             if (!stash)
3064                 packsv = sv;
3065             else {
3066                 SV* const ref = newSViv(PTR2IV(stash));
3067                 (void)hv_store(PL_stashcache, packname,
3068                                 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3069                 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3070                                  stash, sv));
3071             }
3072             goto fetch;
3073         }
3074         /* it _is_ a filehandle name -- replace with a reference */
3075         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3076     }
3077
3078     /* if we got here, ob should be a reference or a glob */
3079     if (!ob || !(SvOBJECT(ob)
3080                  || (SvTYPE(ob) == SVt_PVGV
3081                      && isGV_with_GP(ob)
3082                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3083                      && SvOBJECT(ob))))
3084     {
3085         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3086                    SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3087                                         ? newSVpvs_flags("DOES", SVs_TEMP)
3088                                         : meth));
3089     }
3090
3091     stash = SvSTASH(ob);
3092
3093   fetch:
3094     /* NOTE: stash may be null, hope hv_fetch_ent and
3095        gv_fetchmethod can cope (it seems they can) */
3096
3097     /* shortcut for simple names */
3098     if (hashp) {
3099         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3100         if (he) {
3101             gv = MUTABLE_GV(HeVAL(he));
3102             if (isGV(gv) && GvCV(gv) &&
3103                 (!GvCVGEN(gv) || GvCVGEN(gv)
3104                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3105                 return MUTABLE_SV(GvCV(gv));
3106         }
3107     }
3108
3109     gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3110                                      meth, GV_AUTOLOAD | GV_CROAK);
3111
3112     assert(gv);
3113
3114     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3115 }
3116
3117 /*
3118  * Local variables:
3119  * c-indentation-style: bsd
3120  * c-basic-offset: 4
3121  * indent-tabs-mode: nil
3122  * End:
3123  *
3124  * ex: set ts=8 sts=4 sw=4 et:
3125  */