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