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