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