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