pp_hot.c

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