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