pp_hot.c

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