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     TAINT_NOT;          /* Each statement is presumed innocent */
  51     PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
  52     FREETMPS;
  53     PERL_ASYNC_CHECK();
  54     return NORMAL;
  55 }
  56
  57 PP(pp_gvsv)
  58 {
  59     dSP;
  60     EXTEND(SP,1);
  61     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
  62         PUSHs(save_scalar(cGVOP_gv));
  63     else
  64         PUSHs(GvSVn(cGVOP_gv));
  65     RETURN;
  66 }
  67
  68
  69 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
  70
  71 PP(pp_null)
  72 {
  73     return NORMAL;
  74 }
  75
  76 /* This is sometimes called directly by pp_coreargs, pp_grepstart and
  77    amagic_call. */
  78 PP(pp_pushmark)
  79 {
  80     PUSHMARK(PL_stack_sp);
  81     return NORMAL;
  82 }
  83
  84 PP(pp_stringify)
  85 {
  86     dSP; dTARGET;
  87     SV * const sv = TOPs;
  88     SETs(TARG);
  89     sv_copypv(TARG, sv);
  90     SvSETMAGIC(TARG);
  91     /* no PUTBACK, SETs doesn't inc/dec SP */
  92     return NORMAL;
  93 }
  94
  95 PP(pp_gv)
  96 {
  97     dSP;
  98     XPUSHs(MUTABLE_SV(cGVOP_gv));
  99     RETURN;
 100 }
 101
 102
 103 /* also used for: pp_andassign() */
 104
 105 PP(pp_and)
 106 {
 107     PERL_ASYNC_CHECK();
 108     {
 109         /* SP is not used to remove a variable that is saved across the
 110           sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
 111           register or load/store vs direct mem ops macro is introduced, this
 112           should be a define block between direct PL_stack_sp and dSP operations,
 113           presently, using PL_stack_sp is bias towards CISC cpus */
 114         SV * const sv = *PL_stack_sp;
 115         if (!SvTRUE_NN(sv))
 116             return NORMAL;
 117         else {
 118             if (PL_op->op_type == OP_AND)
 119                 --PL_stack_sp;
 120             return cLOGOP->op_other;
 121         }
 122     }
 123 }
 124
 125 PP(pp_sassign)
 126 {
 127     dSP;
 128     /* sassign keeps its args in the optree traditionally backwards.
 129        So we pop them differently.
 130     */
 131     SV *left = POPs; SV *right = TOPs;
 132
 133     if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
 134         SV * const temp = left;
 135         left = right; right = temp;
 136     }
 137     assert(TAINTING_get || !TAINT_get);
 138     if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
 139         TAINT_NOT;
 140     if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
 141         /* *foo =\&bar */
 142         SV * const cv = SvRV(right);
 143         const U32 cv_type = SvTYPE(cv);
 144         const bool is_gv = isGV_with_GP(left);
 145         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 146
 147         if (!got_coderef) {
 148             assert(SvROK(cv));
 149         }
 150
 151         /* Can do the optimisation if left (LVALUE) is not a typeglob,
 152            right (RVALUE) is a reference to something, and we're in void
 153            context. */
 154         if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
 155             /* Is the target symbol table currently empty?  */
 156             GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
 157             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 158                 /* Good. Create a new proxy constant subroutine in the target.
 159                    The gv becomes a(nother) reference to the constant.  */
 160                 SV *const value = SvRV(cv);
 161
 162                 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
 163                 SvPCS_IMPORTED_on(gv);
 164                 SvRV_set(gv, value);
 165                 SvREFCNT_inc_simple_void(value);
 166                 SETs(left);
 167                 RETURN;
 168             }
 169         }
 170
 171         /* Need to fix things up.  */
 172         if (!is_gv) {
 173             /* Need to fix GV.  */
 174             left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
 175         }
 176
 177         if (!got_coderef) {
 178             /* We've been returned a constant rather than a full subroutine,
 179                but they expect a subroutine reference to apply.  */
 180             if (SvROK(cv)) {
 181                 ENTER_with_name("sassign_coderef");
 182                 SvREFCNT_inc_void(SvRV(cv));
 183                 /* newCONSTSUB takes a reference count on the passed in SV
 184                    from us.  We set the name to NULL, otherwise we get into
 185                    all sorts of fun as the reference to our new sub is
 186                    donated to the GV that we're about to assign to.
 187                 */
 188                 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
 189                                                       SvRV(cv))));
 190                 SvREFCNT_dec_NN(cv);
 191                 LEAVE_with_name("sassign_coderef");
 192             } else {
 193                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
 194                    is that
 195                    First:   ops for \&{"BONK"}; return us the constant in the
 196                             symbol table
 197                    Second:  ops for *{"BONK"} cause that symbol table entry
 198                             (and our reference to it) to be upgraded from RV
 199                             to typeblob)
 200                    Thirdly: We get here. cv is actually PVGV now, and its
 201                             GvCV() is actually the subroutine we're looking for
 202
 203                    So change the reference so that it points to the subroutine
 204                    of that typeglob, as that's what they were after all along.
 205                 */
 206                 GV *const upgraded = MUTABLE_GV(cv);
 207                 CV *const source = GvCV(upgraded);
 208
 209                 assert(source);
 210                 assert(CvFLAGS(source) & CVf_CONST);
 211
 212                 SvREFCNT_inc_simple_void_NN(source);
 213                 SvREFCNT_dec_NN(upgraded);
 214                 SvRV_set(right, MUTABLE_SV(source));
 215             }
 216         }
 217
 218     }
 219     if (
 220       UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
 221       (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
 222     )
 223         Perl_warner(aTHX_
 224             packWARN(WARN_MISC), "Useless assignment to a temporary"
 225         );
 226     SvSetMagicSV(left, right);
 227     SETs(left);
 228     RETURN;
 229 }
 230
 231 PP(pp_cond_expr)
 232 {
 233     dSP;
 234     PERL_ASYNC_CHECK();
 235     if (SvTRUEx(POPs))
 236         RETURNOP(cLOGOP->op_other);
 237     else
 238         RETURNOP(cLOGOP->op_next);
 239 }
 240
 241 PP(pp_unstack)
 242 {
 243     PERL_CONTEXT *cx;
 244     PERL_ASYNC_CHECK();
 245     TAINT_NOT;          /* Each statement is presumed innocent */
 246     cx  = CX_CUR();
 247     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
 248     FREETMPS;
 249     if (!(PL_op->op_flags & OPf_SPECIAL)) {
 250         assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
 251         CX_LEAVE_SCOPE(cx);
 252     }
 253     return NORMAL;
 254 }
 255
 256 PP(pp_concat)
 257 {
 258   dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
 259   {
 260     dPOPTOPssrl;
 261     bool lbyte;
 262     STRLEN rlen;
 263     const char *rpv = NULL;
 264     bool rbyte = FALSE;
 265     bool rcopied = FALSE;
 266
 267     if (TARG == right && right != left) { /* $r = $l.$r */
 268         rpv = SvPV_nomg_const(right, rlen);
 269         rbyte = !DO_UTF8(right);
 270         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 271         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 272         rcopied = TRUE;
 273     }
 274
 275     if (TARG != left) { /* not $l .= $r */
 276         STRLEN llen;
 277         const char* const lpv = SvPV_nomg_const(left, llen);
 278         lbyte = !DO_UTF8(left);
 279         sv_setpvn(TARG, lpv, llen);
 280         if (!lbyte)
 281             SvUTF8_on(TARG);
 282         else
 283             SvUTF8_off(TARG);
 284     }
 285     else { /* $l .= $r   and   left == TARG */
 286         if (!SvOK(left)) {
 287             if ((left == right                          /* $l .= $l */
 288                  || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
 289                 && ckWARN(WARN_UNINITIALIZED)
 290                 )
 291                 report_uninit(left);
 292             SvPVCLEAR(left);
 293         }
 294         else {
 295             SvPV_force_nomg_nolen(left);
 296         }
 297         lbyte = !DO_UTF8(left);
 298         if (IN_BYTES)
 299             SvUTF8_off(left);
 300     }
 301
 302     if (!rcopied) {
 303         rpv = SvPV_nomg_const(right, rlen);
 304         rbyte = !DO_UTF8(right);
 305     }
 306     if (lbyte != rbyte) {
 307         if (lbyte)
 308             sv_utf8_upgrade_nomg(TARG);
 309         else {
 310             if (!rcopied)
 311                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 312             sv_utf8_upgrade_nomg(right);
 313             rpv = SvPV_nomg_const(right, rlen);
 314         }
 315     }
 316     sv_catpvn_nomg(TARG, rpv, rlen);
 317
 318     SETTARG;
 319     RETURN;
 320   }
 321 }
 322
 323 /* push the elements of av onto the stack.
 324  * XXX Note that padav has similar code but without the mg_get().
 325  * I suspect that the mg_get is no longer needed, but while padav
 326  * differs, it can't share this function */
 327
 328 STATIC void
 329 S_pushav(pTHX_ AV* const av)
 330 {
 331     dSP;
 332     const SSize_t maxarg = AvFILL(av) + 1;
 333     EXTEND(SP, maxarg);
 334     if (UNLIKELY(SvRMAGICAL(av))) {
 335         PADOFFSET i;
 336         for (i=0; i < (PADOFFSET)maxarg; i++) {
 337             SV ** const svp = av_fetch(av, i, FALSE);
 338             /* See note in pp_helem, and bug id #27839 */
 339             SP[i+1] = svp
 340                 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
 341                 : &PL_sv_undef;
 342         }
 343     }
 344     else {
 345         PADOFFSET i;
 346         for (i=0; i < (PADOFFSET)maxarg; i++) {
 347             SV * const sv = AvARRAY(av)[i];
 348             SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
 349         }
 350     }
 351     SP += maxarg;
 352     PUTBACK;
 353 }
 354
 355
 356 /* ($lex1,@lex2,...)   or my ($lex1,@lex2,...)  */
 357
 358 PP(pp_padrange)
 359 {
 360     dSP;
 361     PADOFFSET base = PL_op->op_targ;
 362     int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
 363     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         int i;
 373
 374         EXTEND(SP, count);
 375         PUSHMARK(SP);
 376         for (i = 0; i <count; i++)
 377             *++SP = PAD_SV(base+i);
 378     }
 379     if (PL_op->op_private & OPpLVAL_INTRO) {
 380         SV **svp = &(PAD_SVl(base));
 381         const UV payload = (UV)(
 382                       (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
 383                     | (count << SAVE_TIGHT_SHIFT)
 384                     | SAVEt_CLEARPADRANGE);
 385         int i;
 386
 387         STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
 388         assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
 389                 == (Size_t)base);
 390         {
 391             dSS_ADD;
 392             SS_ADD_UV(payload);
 393             SS_ADD_END(1);
 394         }
 395
 396         for (i = 0; i <count; i++)
 397             SvPADSTALE_off(*svp++); /* mark lexical as active */
 398     }
 399     RETURN;
 400 }
 401
 402
 403 PP(pp_padsv)
 404 {
 405     dSP;
 406     EXTEND(SP, 1);
 407     {
 408         OP * const op = PL_op;
 409         /* access PL_curpad once */
 410         SV ** const padentry = &(PAD_SVl(op->op_targ));
 411         {
 412             dTARG;
 413             TARG = *padentry;
 414             PUSHs(TARG);
 415             PUTBACK; /* no pop/push after this, TOPs ok */
 416         }
 417         if (op->op_flags & OPf_MOD) {
 418             if (op->op_private & OPpLVAL_INTRO)
 419                 if (!(op->op_private & OPpPAD_STATE))
 420                     save_clearsv(padentry);
 421             if (op->op_private & OPpDEREF) {
 422                 /* TOPs is equivalent to TARG here.  Using TOPs (SP) rather
 423                    than TARG reduces the scope of TARG, so it does not
 424                    span the call to save_clearsv, resulting in smaller
 425                    machine code. */
 426                 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
 427             }
 428         }
 429         return op->op_next;
 430     }
 431 }
 432
 433 PP(pp_readline)
 434 {
 435     dSP;
 436     if (TOPs) {
 437         SvGETMAGIC(TOPs);
 438         tryAMAGICunTARGETlist(iter_amg, 0);
 439         PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
 440     }
 441     else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
 442     if (!isGV_with_GP(PL_last_in_gv)) {
 443         if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
 444             PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
 445         else {
 446             dSP;
 447             XPUSHs(MUTABLE_SV(PL_last_in_gv));
 448             PUTBACK;
 449             Perl_pp_rv2gv(aTHX);
 450             PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
 451             if (PL_last_in_gv == (GV *)&PL_sv_undef)
 452                 PL_last_in_gv = NULL;
 453             else
 454                 assert(isGV_with_GP(PL_last_in_gv));
 455         }
 456     }
 457     return do_readline();
 458 }
 459
 460 PP(pp_eq)
 461 {
 462     dSP;
 463     SV *left, *right;
 464
 465     tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
 466     right = POPs;
 467     left  = TOPs;
 468     SETs(boolSV(
 469         (SvIOK_notUV(left) && SvIOK_notUV(right))
 470         ? (SvIVX(left) == SvIVX(right))
 471         : ( do_ncmp(left, right) == 0)
 472     ));
 473     RETURN;
 474 }
 475
 476
 477 /* also used for: pp_i_preinc() */
 478
 479 PP(pp_preinc)
 480 {
 481     SV *sv = *PL_stack_sp;
 482
 483     if (LIKELY(((sv->sv_flags &
 484                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
 485                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
 486                 == SVf_IOK))
 487         && SvIVX(sv) != IV_MAX)
 488     {
 489         SvIV_set(sv, SvIVX(sv) + 1);
 490     }
 491     else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
 492         sv_inc(sv);
 493     SvSETMAGIC(sv);
 494     return NORMAL;
 495 }
 496
 497
 498 /* also used for: pp_i_predec() */
 499
 500 PP(pp_predec)
 501 {
 502     SV *sv = *PL_stack_sp;
 503
 504     if (LIKELY(((sv->sv_flags &
 505                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
 506                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
 507                 == SVf_IOK))
 508         && SvIVX(sv) != IV_MIN)
 509     {
 510         SvIV_set(sv, SvIVX(sv) - 1);
 511     }
 512     else /* Do all the PERL_PRESERVE_IVUV and hard cases  in sv_dec */
 513         sv_dec(sv);
 514     SvSETMAGIC(sv);
 515     return NORMAL;
 516 }
 517
 518
 519 /* also used for: pp_orassign() */
 520
 521 PP(pp_or)
 522 {
 523     dSP;
 524     PERL_ASYNC_CHECK();
 525     if (SvTRUE(TOPs))
 526         RETURN;
 527     else {
 528         if (PL_op->op_type == OP_OR)
 529             --SP;
 530         RETURNOP(cLOGOP->op_other);
 531     }
 532 }
 533
 534
 535 /* also used for: pp_dor() pp_dorassign() */
 536
 537 PP(pp_defined)
 538 {
 539     dSP;
 540     SV* sv;
 541     bool defined;
 542     const int op_type = PL_op->op_type;
 543     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 544
 545     if (is_dor) {
 546         PERL_ASYNC_CHECK();
 547         sv = TOPs;
 548         if (UNLIKELY(!sv || !SvANY(sv))) {
 549             if (op_type == OP_DOR)
 550                 --SP;
 551             RETURNOP(cLOGOP->op_other);
 552         }
 553     }
 554     else {
 555         /* OP_DEFINED */
 556         sv = POPs;
 557         if (UNLIKELY(!sv || !SvANY(sv)))
 558             RETPUSHNO;
 559     }
 560
 561     defined = FALSE;
 562     switch (SvTYPE(sv)) {
 563     case SVt_PVAV:
 564         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 565             defined = TRUE;
 566         break;
 567     case SVt_PVHV:
 568         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 569             defined = TRUE;
 570         break;
 571     case SVt_PVCV:
 572         if (CvROOT(sv) || CvXSUB(sv))
 573             defined = TRUE;
 574         break;
 575     default:
 576         SvGETMAGIC(sv);
 577         if (SvOK(sv))
 578             defined = TRUE;
 579         break;
 580     }
 581
 582     if (is_dor) {
 583         if(defined)
 584             RETURN;
 585         if(op_type == OP_DOR)
 586             --SP;
 587         RETURNOP(cLOGOP->op_other);
 588     }
 589     /* assuming OP_DEFINED */
 590     if(defined)
 591         RETPUSHYES;
 592     RETPUSHNO;
 593 }
 594
 595
 596
 597 PP(pp_add)
 598 {
 599     dSP; dATARGET; bool useleft; SV *svl, *svr;
 600
 601     tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
 602     svr = TOPs;
 603     svl = TOPm1s;
 604
 605 #ifdef PERL_PRESERVE_IVUV
 606
 607     /* special-case some simple common cases */
 608     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
 609         IV il, ir;
 610         U32 flags = (svl->sv_flags & svr->sv_flags);
 611         if (flags & SVf_IOK) {
 612             /* both args are simple IVs */
 613             UV topl, topr;
 614             il = SvIVX(svl);
 615             ir = SvIVX(svr);
 616           do_iv:
 617             topl = ((UV)il) >> (UVSIZE * 8 - 2);
 618             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
 619
 620             /* if both are in a range that can't under/overflow, do a
 621              * simple integer add: if the top of both numbers
 622              * are 00  or 11, then it's safe */
 623             if (!( ((topl+1) | (topr+1)) & 2)) {
 624                 SP--;
 625                 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
 626                 SETs(TARG);
 627                 RETURN;
 628             }
 629             goto generic;
 630         }
 631         else if (flags & SVf_NOK) {
 632             /* both args are NVs */
 633             NV nl = SvNVX(svl);
 634             NV nr = SvNVX(svr);
 635
 636             if (
 637 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
 638                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
 639                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
 640 #else
 641                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
 642 #endif
 643                 )
 644                 /* nothing was lost by converting to IVs */
 645                 goto do_iv;
 646             SP--;
 647             TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
 648             SETs(TARG);
 649             RETURN;
 650         }
 651     }
 652
 653   generic:
 654
 655     useleft = USE_LEFT(svl);
 656     /* We must see if we can perform the addition with integers if possible,
 657        as the integer code detects overflow while the NV code doesn't.
 658        If either argument hasn't had a numeric conversion yet attempt to get
 659        the IV. It's important to do this now, rather than just assuming that
 660        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 661        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 662        integer in case the second argument is IV=9223372036854775806
 663        We can (now) rely on sv_2iv to do the right thing, only setting the
 664        public IOK flag if the value in the NV (or PV) slot is truly integer.
 665
 666        A side effect is that this also aggressively prefers integer maths over
 667        fp maths for integer values.
 668
 669        How to detect overflow?
 670
 671        C 99 section 6.2.6.1 says
 672
 673        The range of nonnegative values of a signed integer type is a subrange
 674        of the corresponding unsigned integer type, and the representation of
 675        the same value in each type is the same. A computation involving
 676        unsigned operands can never overflow, because a result that cannot be
 677        represented by the resulting unsigned integer type is reduced modulo
 678        the number that is one greater than the largest value that can be
 679        represented by the resulting type.
 680
 681        (the 9th paragraph)
 682
 683        which I read as "unsigned ints wrap."
 684
 685        signed integer overflow seems to be classed as "exception condition"
 686
 687        If an exceptional condition occurs during the evaluation of an
 688        expression (that is, if the result is not mathematically defined or not
 689        in the range of representable values for its type), the behavior is
 690        undefined.
 691
 692        (6.5, the 5th paragraph)
 693
 694        I had assumed that on 2s complement machines signed arithmetic would
 695        wrap, hence coded pp_add and pp_subtract on the assumption that
 696        everything perl builds on would be happy.  After much wailing and
 697        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 698        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 699        unsigned code below is actually shorter than the old code. :-)
 700     */
 701
 702     if (SvIV_please_nomg(svr)) {
 703         /* Unless the left argument is integer in range we are going to have to
 704            use NV maths. Hence only attempt to coerce the right argument if
 705            we know the left is integer.  */
 706         UV auv = 0;
 707         bool auvok = FALSE;
 708         bool a_valid = 0;
 709
 710         if (!useleft) {
 711             auv = 0;
 712             a_valid = auvok = 1;
 713             /* left operand is undef, treat as zero. + 0 is identity,
 714                Could SETi or SETu right now, but space optimise by not adding
 715                lots of code to speed up what is probably a rarish case.  */
 716         } else {
 717             /* Left operand is defined, so is it IV? */
 718             if (SvIV_please_nomg(svl)) {
 719                 if ((auvok = SvUOK(svl)))
 720                     auv = SvUVX(svl);
 721                 else {
 722                     const IV aiv = SvIVX(svl);
 723                     if (aiv >= 0) {
 724                         auv = aiv;
 725                         auvok = 1;      /* Now acting as a sign flag.  */
 726                     } else {
 727                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
 728                     }
 729                 }
 730                 a_valid = 1;
 731             }
 732         }
 733         if (a_valid) {
 734             bool result_good = 0;
 735             UV result;
 736             UV buv;
 737             bool buvok = SvUOK(svr);
 738
 739             if (buvok)
 740                 buv = SvUVX(svr);
 741             else {
 742                 const IV biv = SvIVX(svr);
 743                 if (biv >= 0) {
 744                     buv = biv;
 745                     buvok = 1;
 746                 } else
 747                     buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
 748             }
 749             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 750                else "IV" now, independent of how it came in.
 751                if a, b represents positive, A, B negative, a maps to -A etc
 752                a + b =>  (a + b)
 753                A + b => -(a - b)
 754                a + B =>  (a - b)
 755                A + B => -(a + b)
 756                all UV maths. negate result if A negative.
 757                add if signs same, subtract if signs differ. */
 758
 759             if (auvok ^ buvok) {
 760                 /* Signs differ.  */
 761                 if (auv >= buv) {
 762                     result = auv - buv;
 763                     /* Must get smaller */
 764                     if (result <= auv)
 765                         result_good = 1;
 766                 } else {
 767                     result = buv - auv;
 768                     if (result <= buv) {
 769                         /* result really should be -(auv-buv). as its negation
 770                            of true value, need to swap our result flag  */
 771                         auvok = !auvok;
 772                         result_good = 1;
 773                     }
 774                 }
 775             } else {
 776                 /* Signs same */
 777                 result = auv + buv;
 778                 if (result >= auv)
 779                     result_good = 1;
 780             }
 781             if (result_good) {
 782                 SP--;
 783                 if (auvok)
 784                     SETu( result );
 785                 else {
 786                     /* Negate result */
 787                     if (result <= (UV)IV_MIN)
 788                         SETi(result == (UV)IV_MIN
 789                                 ? IV_MIN : -(IV)result);
 790                     else {
 791                         /* result valid, but out of range for IV.  */
 792                         SETn( -(NV)result );
 793                     }
 794                 }
 795                 RETURN;
 796             } /* Overflow, drop through to NVs.  */
 797         }
 798     }
 799
 800 #else
 801     useleft = USE_LEFT(svl);
 802 #endif
 803
 804     {
 805         NV value = SvNV_nomg(svr);
 806         (void)POPs;
 807         if (!useleft) {
 808             /* left operand is undef, treat as zero. + 0.0 is identity. */
 809             SETn(value);
 810             RETURN;
 811         }
 812         SETn( value + SvNV_nomg(svl) );
 813         RETURN;
 814     }
 815 }
 816
 817
 818 /* also used for: pp_aelemfast_lex() */
 819
 820 PP(pp_aelemfast)
 821 {
 822     dSP;
 823     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
 824         ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
 825     const U32 lval = PL_op->op_flags & OPf_MOD;
 826     const I8 key   = (I8)PL_op->op_private;
 827     SV** svp;
 828     SV *sv;
 829
 830     assert(SvTYPE(av) == SVt_PVAV);
 831
 832     EXTEND(SP, 1);
 833
 834     /* inlined av_fetch() for simple cases ... */
 835     if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
 836         sv = AvARRAY(av)[key];
 837         if (sv) {
 838             PUSHs(sv);
 839             RETURN;
 840         }
 841     }
 842
 843     /* ... else do it the hard way */
 844     svp = av_fetch(av, key, lval);
 845     sv = (svp ? *svp : &PL_sv_undef);
 846
 847     if (UNLIKELY(!svp && lval))
 848         DIE(aTHX_ PL_no_aelem, (int)key);
 849
 850     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
 851         mg_get(sv);
 852     PUSHs(sv);
 853     RETURN;
 854 }
 855
 856 PP(pp_join)
 857 {
 858     dSP; dMARK; dTARGET;
 859     MARK++;
 860     do_join(TARG, *MARK, MARK, SP);
 861     SP = MARK;
 862     SETs(TARG);
 863     RETURN;
 864 }
 865
 866 /* Oversized hot code. */
 867
 868 /* also used for: pp_say() */
 869
 870 PP(pp_print)
 871 {
 872     dSP; dMARK; dORIGMARK;
 873     PerlIO *fp;
 874     MAGIC *mg;
 875     GV * const gv
 876         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
 877     IO *io = GvIO(gv);
 878
 879     if (io
 880         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
 881     {
 882       had_magic:
 883         if (MARK == ORIGMARK) {
 884             /* If using default handle then we need to make space to
 885              * pass object as 1st arg, so move other args up ...
 886              */
 887             MEXTEND(SP, 1);
 888             ++MARK;
 889             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 890             ++SP;
 891         }
 892         return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
 893                                 mg,
 894                                 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
 895                                  | (PL_op->op_type == OP_SAY
 896                                     ? TIED_METHOD_SAY : 0)), sp - mark);
 897     }
 898     if (!io) {
 899         if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
 900             && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
 901             goto had_magic;
 902         report_evil_fh(gv);
 903         SETERRNO(EBADF,RMS_IFI);
 904         goto just_say_no;
 905     }
 906     else if (!(fp = IoOFP(io))) {
 907         if (IoIFP(io))
 908             report_wrongway_fh(gv, '<');
 909         else
 910             report_evil_fh(gv);
 911         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 912         goto just_say_no;
 913     }
 914     else {
 915         SV * const ofs = GvSV(PL_ofsgv); /* $, */
 916         MARK++;
 917         if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
 918             while (MARK <= SP) {
 919                 if (!do_print(*MARK, fp))
 920                     break;
 921                 MARK++;
 922                 if (MARK <= SP) {
 923                     /* don't use 'ofs' here - it may be invalidated by magic callbacks */
 924                     if (!do_print(GvSV(PL_ofsgv), fp)) {
 925                         MARK--;
 926                         break;
 927                     }
 928                 }
 929             }
 930         }
 931         else {
 932             while (MARK <= SP) {
 933                 if (!do_print(*MARK, fp))
 934                     break;
 935                 MARK++;
 936             }
 937         }
 938         if (MARK <= SP)
 939             goto just_say_no;
 940         else {
 941             if (PL_op->op_type == OP_SAY) {
 942                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
 943                     goto just_say_no;
 944             }
 945             else if (PL_ors_sv && SvOK(PL_ors_sv))
 946                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 947                     goto just_say_no;
 948
 949             if (IoFLAGS(io) & IOf_FLUSH)
 950                 if (PerlIO_flush(fp) == EOF)
 951                     goto just_say_no;
 952         }
 953     }
 954     SP = ORIGMARK;
 955     XPUSHs(&PL_sv_yes);
 956     RETURN;
 957
 958   just_say_no:
 959     SP = ORIGMARK;
 960     XPUSHs(&PL_sv_undef);
 961     RETURN;
 962 }
 963
 964
 965 /* also used for: pp_rv2hv() */
 966 /* also called directly by pp_lvavref */
 967
 968 PP(pp_rv2av)
 969 {
 970     dSP; dTOPss;
 971     const U8 gimme = GIMME_V;
 972     static const char an_array[] = "an ARRAY";
 973     static const char a_hash[] = "a HASH";
 974     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
 975                           || PL_op->op_type == OP_LVAVREF;
 976     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 977
 978     SvGETMAGIC(sv);
 979     if (SvROK(sv)) {
 980         if (UNLIKELY(SvAMAGIC(sv))) {
 981             sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
 982         }
 983         sv = SvRV(sv);
 984         if (UNLIKELY(SvTYPE(sv) != type))
 985             /* diag_listed_as: Not an ARRAY reference */
 986             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
 987         else if (UNLIKELY(PL_op->op_flags & OPf_MOD
 988                 && PL_op->op_private & OPpLVAL_INTRO))
 989             Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 990     }
 991     else if (UNLIKELY(SvTYPE(sv) != type)) {
 992             GV *gv;
 993
 994             if (!isGV_with_GP(sv)) {
 995                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 996                                      type, &sp);
 997                 if (!gv)
 998                     RETURN;
 999             }
1000             else {
1001                 gv = MUTABLE_GV(sv);
1002             }
1003             sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
1004             if (PL_op->op_private & OPpLVAL_INTRO)
1005                 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
1006     }
1007     if (PL_op->op_flags & OPf_REF) {
1008                 SETs(sv);
1009                 RETURN;
1010     }
1011     else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
1012               const I32 flags = is_lvalue_sub();
1013               if (flags && !(flags & OPpENTERSUB_INARGS)) {
1014                 if (gimme != G_ARRAY)
1015                     goto croak_cant_return;
1016                 SETs(sv);
1017                 RETURN;
1018               }
1019     }
1020
1021     if (is_pp_rv2av) {
1022         AV *const av = MUTABLE_AV(sv);
1023         /* The guts of pp_rv2av  */
1024         if (gimme == G_ARRAY) {
1025             SP--;
1026             PUTBACK;
1027             S_pushav(aTHX_ av);
1028             SPAGAIN;
1029         }
1030         else if (gimme == G_SCALAR) {
1031             dTARGET;
1032             const SSize_t maxarg = AvFILL(av) + 1;
1033             SETi(maxarg);
1034         }
1035     } else {
1036         /* The guts of pp_rv2hv  */
1037         if (gimme == G_ARRAY) { /* array wanted */
1038             *PL_stack_sp = sv;
1039             return Perl_do_kv(aTHX);
1040         }
1041         else if ((PL_op->op_private & OPpTRUEBOOL
1042               || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
1043                  && block_gimme() == G_VOID  ))
1044               && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
1045             SETs(HvUSEDKEYS(MUTABLE_HV(sv)) ? &PL_sv_yes : &PL_sv_zero);
1046         else if (gimme == G_SCALAR) {
1047             dTARG;
1048             TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
1049             SETTARG;
1050         }
1051     }
1052     RETURN;
1053
1054  croak_cant_return:
1055     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
1056                is_pp_rv2av ? "array" : "hash");
1057     RETURN;
1058 }
1059
1060 STATIC void
1061 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
1062 {
1063     PERL_ARGS_ASSERT_DO_ODDBALL;
1064
1065     if (*oddkey) {
1066         if (ckWARN(WARN_MISC)) {
1067             const char *err;
1068             if (oddkey == firstkey &&
1069                 SvROK(*oddkey) &&
1070                 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
1071                  SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
1072             {
1073                 err = "Reference found where even-sized list expected";
1074             }
1075             else
1076                 err = "Odd number of elements in hash assignment";
1077             Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1078         }
1079
1080     }
1081 }
1082
1083
1084 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
1085  * are common to both the LHS and RHS of an aassign, and replace them
1086  * with copies. All these copies are made before the actual list assign is
1087  * done.
1088  *
1089  * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
1090  * element ($b) to the first LH element ($a), modifies $a; when the
1091  * second assignment is done, the second RH element now has the wrong
1092  * value. So we initially replace the RHS with ($b, mortalcopy($a)).
1093  * Note that we don't need to make a mortal copy of $b.
1094  *
1095  * The algorithm below works by, for every RHS element, mark the
1096  * corresponding LHS target element with SVf_BREAK. Then if the RHS
1097  * element is found with SVf_BREAK set, it means it would have been
1098  * modified, so make a copy.
1099  * Note that by scanning both LHS and RHS in lockstep, we avoid
1100  * unnecessary copies (like $b above) compared with a naive
1101  * "mark all LHS; copy all marked RHS; unmark all LHS".
1102  *
1103  * If the LHS element is a 'my' declaration' and has a refcount of 1, then
1104  * it can't be common and can be skipped.
1105  *
1106  * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
1107  * that we thought we didn't need to call S_aassign_copy_common(), but we
1108  * have anyway for sanity checking. If we find we need to copy, then panic.
1109  */
1110
1111 PERL_STATIC_INLINE void
1112 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
1113         SV **firstrelem, SV **lastrelem
1114 #ifdef DEBUGGING
1115         , bool fake
1116 #endif
1117 )
1118 {
1119     dVAR;
1120     SV **relem;
1121     SV **lelem;
1122     SSize_t lcount = lastlelem - firstlelem + 1;
1123     bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
1124     bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
1125     bool copy_all = FALSE;
1126
1127     assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
1128     assert(firstlelem < lastlelem); /* at least 2 LH elements */
1129     assert(firstrelem < lastrelem); /* at least 2 RH elements */
1130
1131
1132     lelem = firstlelem;
1133     /* we never have to copy the first RH element; it can't be corrupted
1134      * by assigning something to the corresponding first LH element.
1135      * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
1136      */
1137     relem = firstrelem + 1;
1138
1139     for (; relem <= lastrelem; relem++) {
1140         SV *svr;
1141
1142         /* mark next LH element */
1143
1144         if (--lcount >= 0) {
1145             SV *svl = *lelem++;
1146
1147             if (UNLIKELY(!svl)) {/* skip AV alias marker */
1148                 assert (lelem <= lastlelem);
1149                 svl = *lelem++;
1150                 lcount--;
1151             }
1152
1153             assert(svl);
1154             if (SvSMAGICAL(svl)) {
1155                 copy_all = TRUE;
1156             }
1157             if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
1158                 if (!marked)
1159                     return;
1160                 /* this LH element will consume all further args;
1161                  * no need to mark any further LH elements (if any).
1162                  * But we still need to scan any remaining RHS elements;
1163                  * set lcount negative to distinguish from  lcount == 0,
1164                  * so the loop condition continues being true
1165                  */
1166                 lcount = -1;
1167                 lelem--; /* no need to unmark this element */
1168             }
1169             else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
1170                 SvFLAGS(svl) |= SVf_BREAK;
1171                 marked = TRUE;
1172             }
1173             else if (!marked) {
1174                 /* don't check RH element if no SVf_BREAK flags set yet */
1175                 if (!lcount)
1176                     break;
1177                 continue;
1178             }
1179         }
1180
1181         /* see if corresponding RH element needs copying */
1182
1183         assert(marked);
1184         svr = *relem;
1185         assert(svr);
1186
1187         if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
1188             U32 brk = (SvFLAGS(svr) & SVf_BREAK);
1189
1190 #ifdef DEBUGGING
1191             if (fake) {
1192                 /* op_dump(PL_op); */
1193                 Perl_croak(aTHX_
1194                     "panic: aassign skipped needed copy of common RH elem %"
1195                         UVuf, (UV)(relem - firstrelem));
1196             }
1197 #endif
1198
1199             TAINT_NOT;  /* Each item is independent */
1200
1201             /* Dear TODO test in t/op/sort.t, I love you.
1202                (It's relying on a panic, not a "semi-panic" from newSVsv()
1203                and then an assertion failure below.)  */
1204             if (UNLIKELY(SvIS_FREED(svr))) {
1205                 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1206                            (void*)svr);
1207             }
1208             /* avoid break flag while copying; otherwise COW etc
1209              * disabled... */
1210             SvFLAGS(svr) &= ~SVf_BREAK;
1211             /* Not newSVsv(), as it does not allow copy-on-write,
1212                resulting in wasteful copies.
1213                Also, we use SV_NOSTEAL in case the SV is used more than
1214                once, e.g.  (...) = (f())[0,0]
1215                Where the same SV appears twice on the RHS without a ref
1216                count bump.  (Although I suspect that the SV won't be
1217                stealable here anyway - DAPM).
1218                */
1219             *relem = sv_mortalcopy_flags(svr,
1220                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1221             /* ... but restore afterwards in case it's needed again,
1222              * e.g. ($a,$b,$c) = (1,$a,$a)
1223              */
1224             SvFLAGS(svr) |= brk;
1225         }
1226
1227         if (!lcount)
1228             break;
1229     }
1230
1231     if (!marked)
1232         return;
1233
1234     /*unmark LHS */
1235
1236     while (lelem > firstlelem) {
1237         SV * const svl = *(--lelem);
1238         if (svl)
1239             SvFLAGS(svl) &= ~SVf_BREAK;
1240     }
1241 }
1242
1243
1244
1245 PP(pp_aassign)
1246 {
1247     dVAR; dSP;
1248     SV **lastlelem = PL_stack_sp;
1249     SV **lastrelem = PL_stack_base + POPMARK;
1250     SV **firstrelem = PL_stack_base + POPMARK + 1;
1251     SV **firstlelem = lastrelem + 1;
1252
1253     SV **relem;
1254     SV **lelem;
1255     U8 gimme;
1256     /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
1257      * only need to save locally, not on the save stack */
1258     U16 old_delaymagic = PL_delaymagic;
1259 #ifdef DEBUGGING
1260     bool fake = 0;
1261 #endif
1262
1263     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
1264
1265     /* If there's a common identifier on both sides we have to take
1266      * special care that assigning the identifier on the left doesn't
1267      * clobber a value on the right that's used later in the list.
1268      */
1269
1270     /* at least 2 LH and RH elements, or commonality isn't an issue */
1271     if (firstlelem < lastlelem && firstrelem < lastrelem) {
1272         for (relem = firstrelem+1; relem <= lastrelem; relem++) {
1273             if (SvGMAGICAL(*relem))
1274                 goto do_scan;
1275         }
1276         for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1277             if (*lelem && SvSMAGICAL(*lelem))
1278                 goto do_scan;
1279         }
1280         if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
1281             if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1282                 /* skip the scan if all scalars have a ref count of 1 */
1283                 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1284                     SV *sv = *lelem;
1285                     if (!sv || SvREFCNT(sv) == 1)
1286                         continue;
1287                     if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1288                         goto do_scan;
1289                     break;
1290                 }
1291             }
1292             else {
1293             do_scan:
1294                 S_aassign_copy_common(aTHX_
1295                                       firstlelem, lastlelem, firstrelem, lastrelem
1296 #ifdef DEBUGGING
1297                     , fake
1298 #endif
1299                 );
1300             }
1301         }
1302     }
1303 #ifdef DEBUGGING
1304     else {
1305         /* on debugging builds, do the scan even if we've concluded we
1306          * don't need to, then panic if we find commonality. Note that the
1307          * scanner assumes at least 2 elements */
1308         if (firstlelem < lastlelem && firstrelem < lastrelem) {
1309             fake = 1;
1310             goto do_scan;
1311         }
1312     }
1313 #endif
1314
1315     gimme = GIMME_V;
1316     relem = firstrelem;
1317     lelem = firstlelem;
1318
1319     if (relem > lastrelem)
1320         goto no_relems;
1321
1322     /* first lelem loop while there are still relems */
1323     while (LIKELY(lelem <= lastlelem)) {
1324         bool alias = FALSE;
1325         SV *lsv = *lelem++;
1326
1327         TAINT_NOT; /* Each item stands on its own, taintwise. */
1328
1329         assert(relem <= lastrelem);
1330         if (UNLIKELY(!lsv)) {
1331             alias = TRUE;
1332             lsv = *lelem++;
1333             ASSUME(SvTYPE(lsv) == SVt_PVAV);
1334         }
1335
1336         switch (SvTYPE(lsv)) {
1337         case SVt_PVAV: {
1338             SV **svp;
1339             SSize_t i;
1340             SSize_t tmps_base;
1341             SSize_t nelems = lastrelem - relem + 1;
1342             AV *ary = MUTABLE_AV(lsv);
1343
1344             /* Assigning to an aggregate is tricky. First there is the
1345              * issue of commonality, e.g. @a = ($a[0]). Since the
1346              * stack isn't refcounted, clearing @a prior to storing
1347              * elements will free $a[0]. Similarly with
1348              *    sub FETCH { $status[$_[1]] } @status = @tied[0,1];
1349              *
1350              * The way to avoid these issues is to make the copy of each
1351              * SV (and we normally store a *copy* in the array) *before*
1352              * clearing the array. But this has a problem in that
1353              * if the code croaks during copying, the not-yet-stored copies
1354              * could leak. One way to avoid this is to make all the copies
1355              * mortal, but that's quite expensive.
1356              *
1357              * The current solution to these issues is to use a chunk
1358              * of the tmps stack as a temporary refcounted-stack. SVs
1359              * will be put on there during processing to avoid leaks,
1360              * but will be removed again before the end of this block,
1361              * so free_tmps() is never normally called. Also, the
1362              * sv_refcnt of the SVs doesn't have to be manipulated, since
1363              * the ownership of 1 reference count is transferred directly
1364              * from the tmps stack to the AV when the SV is stored.
1365              *
1366              * We disarm slots in the temps stack by storing PL_sv_undef
1367              * there: it doesn't matter if that SV's refcount is
1368              * repeatedly decremented during a croak. But usually this is
1369              * only an interim measure. By the end of this code block
1370              * we try where possible to not leave any PL_sv_undef's on the
1371              * tmps stack e.g. by shuffling newer entries down.
1372              *
1373              * There is one case where we don't copy: non-magical
1374              * SvTEMP(sv)'s with a ref count of 1. The only owner of these
1375              * is on the tmps stack, so its safe to directly steal the SV
1376              * rather than copying. This is common in things like function
1377              * returns, map etc, which all return a list of such SVs.
1378              *
1379              * Note however something like @a = (f())[0,0], where there is
1380              * a danger of the same SV being shared:  this avoided because
1381              * when the SV is stored as $a[0], its ref count gets bumped,
1382              * so the RC==1 test fails and the second element is copied
1383              * instead.
1384              *
1385              * We also use one slot in the tmps stack to hold an extra
1386              * ref to the array, to ensure it doesn't get prematurely
1387              * freed. Again, this is removed before the end of this block.
1388              *
1389              * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
1390              * @a = ($a[0]) case, but the current implementation uses the
1391              * same algorithm regardless, so ignores that flag. (It *is*
1392              * used in the hash branch below, however).
1393             */
1394
1395             /* Reserve slots for ary, plus the elems we're about to copy,
1396              * then protect ary and temporarily void the remaining slots
1397              * with &PL_sv_undef */
1398             EXTEND_MORTAL(nelems + 1);
1399             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
1400             tmps_base = PL_tmps_ix + 1;
1401             for (i = 0; i < nelems; i++)
1402                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1403             PL_tmps_ix += nelems;
1404
1405             /* Make a copy of each RHS elem and save on the tmps_stack
1406              * (or pass through where we can optimise away the copy) */
1407
1408             if (UNLIKELY(alias)) {
1409                 U32 lval = (gimme == G_ARRAY)
1410                                 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1411                 for (svp = relem; svp <= lastrelem; svp++) {
1412                     SV *rsv = *svp;
1413
1414                     SvGETMAGIC(rsv);
1415                     if (!SvROK(rsv))
1416                         DIE(aTHX_ "Assigned value is not a reference");
1417                     if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
1418                    /* diag_listed_as: Assigned value is not %s reference */
1419                         DIE(aTHX_
1420                            "Assigned value is not a SCALAR reference");
1421                     if (lval)
1422                         *svp = rsv = sv_mortalcopy(rsv);
1423                     /* XXX else check for weak refs?  */
1424                     rsv = SvREFCNT_inc_NN(SvRV(rsv));
1425                     assert(tmps_base <= PL_tmps_max);
1426                     PL_tmps_stack[tmps_base++] = rsv;
1427                 }
1428             }
1429             else {
1430                 for (svp = relem; svp <= lastrelem; svp++) {
1431                     SV *rsv = *svp;
1432
1433                     if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1434                         /* can skip the copy */
1435                         SvREFCNT_inc_simple_void_NN(rsv);
1436                         SvTEMP_off(rsv);
1437                     }
1438                     else {
1439                         SV *nsv;
1440                         /* do get before newSV, in case it dies and leaks */
1441                         SvGETMAGIC(rsv);
1442                         nsv = newSV(0);
1443                         /* see comment in S_aassign_copy_common about
1444                          * SV_NOSTEAL */
1445                         sv_setsv_flags(nsv, rsv,
1446                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1447                         rsv = *svp = nsv;
1448                     }
1449
1450                     assert(tmps_base <= PL_tmps_max);
1451                     PL_tmps_stack[tmps_base++] = rsv;
1452                 }
1453             }
1454
1455             if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
1456                 av_clear(ary);
1457
1458             /* store in the array, the SVs that are in the tmps stack */
1459
1460             tmps_base -= nelems;
1461
1462             if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
1463                 /* for arrays we can't cheat with, use the official API */
1464                 av_extend(ary, nelems - 1);
1465                 for (i = 0; i < nelems; i++) {
1466                     SV **svp = &(PL_tmps_stack[tmps_base + i]);
1467                     SV *rsv = *svp;
1468                     /* A tied store won't take ownership of rsv, so keep
1469                      * the 1 refcnt on the tmps stack; otherwise disarm
1470                      * the tmps stack entry */
1471                     if (av_store(ary, i, rsv))
1472                         *svp = &PL_sv_undef;
1473                     /* av_store() may have added set magic to rsv */;
1474                     SvSETMAGIC(rsv);
1475                 }
1476                 /* disarm ary refcount: see comments below about leak */
1477                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1478             }
1479             else {
1480                 /* directly access/set the guts of the AV */
1481                 SSize_t fill = nelems - 1;
1482                 if (fill > AvMAX(ary))
1483                     av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
1484                                     &AvARRAY(ary));
1485                 AvFILLp(ary) = fill;
1486                 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
1487                 /* Quietly remove all the SVs from the tmps stack slots,
1488                  * since ary has now taken ownership of the refcnt.
1489                  * Also remove ary: which will now leak if we die before
1490                  * the SvREFCNT_dec_NN(ary) below */
1491                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1492                     Move(&PL_tmps_stack[tmps_base + nelems],
1493                          &PL_tmps_stack[tmps_base - 1],
1494                          PL_tmps_ix - (tmps_base + nelems) + 1,
1495                          SV*);
1496                 PL_tmps_ix -= (nelems + 1);
1497             }
1498
1499             if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1500                 /* its assumed @ISA set magic can't die and leak ary */
1501                 SvSETMAGIC(MUTABLE_SV(ary));
1502             SvREFCNT_dec_NN(ary);
1503
1504             relem = lastrelem + 1;
1505             goto no_relems;
1506         }
1507
1508         case SVt_PVHV: {                                /* normal hash */
1509
1510             SV **svp;
1511             bool dirty_tmps;
1512             SSize_t i;
1513             SSize_t tmps_base;
1514             SSize_t nelems = lastrelem - relem + 1;
1515             HV *hash = MUTABLE_HV(lsv);
1516
1517             if (UNLIKELY(nelems & 1)) {
1518                 do_oddball(lastrelem, relem);
1519                 /* we have firstlelem to reuse, it's not needed any more */
1520                 *++lastrelem = &PL_sv_undef;
1521                 nelems++;
1522             }
1523
1524             /* See the SVt_PVAV branch above for a long description of
1525              * how the following all works. The main difference for hashes
1526              * is that we treat keys and values separately (and have
1527              * separate loops for them): as for arrays, values are always
1528              * copied (except for the SvTEMP optimisation), since they
1529              * need to be stored in the hash; while keys are only
1530              * processed where they might get prematurely freed or
1531              * whatever. */
1532
1533             /* tmps stack slots:
1534              * * reserve a slot for the hash keepalive;
1535              * * reserve slots for the hash values we're about to copy;
1536              * * preallocate for the keys we'll possibly copy or refcount bump
1537              *   later;
1538              * then protect hash and temporarily void the remaining
1539              * value slots with &PL_sv_undef */
1540             EXTEND_MORTAL(nelems + 1);
1541
1542              /* convert to number of key/value pairs */
1543              nelems >>= 1;
1544
1545             PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
1546             tmps_base = PL_tmps_ix + 1;
1547             for (i = 0; i < nelems; i++)
1548                 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1549             PL_tmps_ix += nelems;
1550
1551             /* Make a copy of each RHS hash value and save on the tmps_stack
1552              * (or pass through where we can optimise away the copy) */
1553
1554             for (svp = relem + 1; svp <= lastrelem; svp += 2) {
1555                 SV *rsv = *svp;
1556
1557                 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1558                     /* can skip the copy */
1559                     SvREFCNT_inc_simple_void_NN(rsv);
1560                     SvTEMP_off(rsv);
1561                 }
1562                 else {
1563                     SV *nsv;
1564                     /* do get before newSV, in case it dies and leaks */
1565                     SvGETMAGIC(rsv);
1566                     nsv = newSV(0);
1567                     /* see comment in S_aassign_copy_common about
1568                      * SV_NOSTEAL */
1569                     sv_setsv_flags(nsv, rsv,
1570                             (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1571                     rsv = *svp = nsv;
1572                 }
1573
1574                 assert(tmps_base <= PL_tmps_max);
1575                 PL_tmps_stack[tmps_base++] = rsv;
1576             }
1577             tmps_base -= nelems;
1578
1579
1580             /* possibly protect keys */
1581
1582             if (UNLIKELY(gimme == G_ARRAY)) {
1583                 /* handle e.g.
1584                 *     @a = ((%h = ($$r, 1)), $r = "x");
1585                 *     $_++ for %h = (1,2,3,4);
1586                 */
1587                 EXTEND_MORTAL(nelems);
1588                 for (svp = relem; svp <= lastrelem; svp += 2)
1589                     *svp = sv_mortalcopy_flags(*svp,
1590                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1591             }
1592             else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
1593                 /* for possible commonality, e.g.
1594                  *       %h = ($h{a},1)
1595                  * avoid premature freeing RHS keys by mortalising
1596                  * them.
1597                  * For a magic element, make a copy so that its magic is
1598                  * called *before* the hash is emptied (which may affect
1599                  * a tied value for example).
1600                  * In theory we should check for magic keys in all
1601                  * cases, not just under OPpASSIGN_COMMON_AGG, but in
1602                  * practice, !OPpASSIGN_COMMON_AGG implies only
1603                  * constants or padtmps on the RHS.
1604                  */
1605                 EXTEND_MORTAL(nelems);
1606                 for (svp = relem; svp <= lastrelem; svp += 2) {
1607                     SV *rsv = *svp;
1608                     if (UNLIKELY(SvGMAGICAL(rsv))) {
1609                         SSize_t n;
1610                         *svp = sv_mortalcopy_flags(*svp,
1611                                 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1612                         /* allow other branch to continue pushing
1613                          * onto tmps stack without checking each time */
1614                         n = (lastrelem - relem) >> 1;
1615                         EXTEND_MORTAL(n);
1616                     }
1617                     else
1618                         PL_tmps_stack[++PL_tmps_ix] =
1619                                     SvREFCNT_inc_simple_NN(rsv);
1620                 }
1621             }
1622
1623             if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
1624                 hv_clear(hash);
1625
1626             /* now assign the keys and values to the hash */
1627
1628             dirty_tmps = FALSE;
1629
1630             if (UNLIKELY(gimme == G_ARRAY)) {
1631                 /* @a = (%h = (...)) etc */
1632                 SV **svp;
1633                 SV **topelem = relem;
1634
1635                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1636                     SV *key = *svp++;
1637                     SV *val = *svp;
1638                     /* remove duplicates from list we return */
1639                     if (!hv_exists_ent(hash, key, 0)) {
1640                         /* copy key back: possibly to an earlier
1641                          * stack location if we encountered dups earlier,
1642                          * The values will be updated later
1643                          */
1644                         *topelem = key;
1645                         topelem += 2;
1646                     }
1647                     /* A tied store won't take ownership of val, so keep
1648                      * the 1 refcnt on the tmps stack; otherwise disarm
1649                      * the tmps stack entry */
1650                     if (hv_store_ent(hash, key, val, 0))
1651                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1652                     else
1653                         dirty_tmps = TRUE;
1654                     /* hv_store_ent() may have added set magic to val */;
1655                     SvSETMAGIC(val);
1656                 }
1657                 if (topelem < svp) {
1658                     /* at this point we have removed the duplicate key/value
1659                      * pairs from the stack, but the remaining values may be
1660                      * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1661                      * the (a 2), but the stack now probably contains
1662                      * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1663                      * obliterates the earlier key. So refresh all values. */
1664                     lastrelem = topelem - 1;
1665                     while (relem < lastrelem) {
1666                         HE *he;
1667                         he = hv_fetch_ent(hash, *relem++, 0, 0);
1668                         *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1669                     }
1670                 }
1671             }
1672             else {
1673                 SV **svp;
1674                 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1675                     SV *key = *svp++;
1676                     SV *val = *svp;
1677                     if (hv_store_ent(hash, key, val, 0))
1678                         PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1679                     else
1680                         dirty_tmps = TRUE;
1681                     /* hv_store_ent() may have added set magic to val */;
1682                     SvSETMAGIC(val);
1683                 }
1684             }
1685
1686             if (dirty_tmps) {
1687                 /* there are still some 'live' recounts on the tmps stack
1688                  * - usually caused by storing into a tied hash. So let
1689                  * free_tmps() do the proper but slow job later.
1690                  * Just disarm hash refcount: see comments below about leak
1691                  */
1692                 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1693             }
1694             else {
1695                 /* Quietly remove all the SVs from the tmps stack slots,
1696                  * since hash has now taken ownership of the refcnt.
1697                  * Also remove hash: which will now leak if we die before
1698                  * the SvREFCNT_dec_NN(hash) below */
1699                 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1700                     Move(&PL_tmps_stack[tmps_base + nelems],
1701                          &PL_tmps_stack[tmps_base - 1],
1702                          PL_tmps_ix - (tmps_base + nelems) + 1,
1703                          SV*);
1704                 PL_tmps_ix -= (nelems + 1);
1705             }
1706
1707             SvREFCNT_dec_NN(hash);
1708
1709             relem = lastrelem + 1;
1710             goto no_relems;
1711         }
1712
1713         default:
1714             if (!SvIMMORTAL(lsv)) {
1715                 SV *ref;
1716
1717                 if (UNLIKELY(
1718                   SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
1719                   (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
1720                 ))
1721                     Perl_warner(aTHX_
1722                        packWARN(WARN_MISC),
1723                       "Useless assignment to a temporary"
1724                     );
1725
1726                 /* avoid freeing $$lsv if it might be needed for further
1727                  * elements, e.g. ($ref, $foo) = (1, $$ref) */
1728                 if (   SvROK(lsv)
1729                     && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
1730                     && lelem <= lastlelem
1731                 ) {
1732                     SSize_t ix;
1733                     SvREFCNT_inc_simple_void_NN(ref);
1734                     /* an unrolled sv_2mortal */
1735                     ix = ++PL_tmps_ix;
1736                     if (UNLIKELY(ix >= PL_tmps_max))
1737                         /* speculatively grow enough to cover other
1738                          * possible refs */
1739                          (void)tmps_grow_p(ix + (lastlelem - lelem));
1740                     PL_tmps_stack[ix] = ref;
1741                 }
1742
1743                 sv_setsv(lsv, *relem);
1744                 *relem = lsv;
1745                 SvSETMAGIC(lsv);
1746             }
1747             if (++relem > lastrelem)
1748                 goto no_relems;
1749             break;
1750         } /* switch */
1751     } /* while */
1752
1753
1754   no_relems:
1755
1756     /* simplified lelem loop for when there are no relems left */
1757     while (LIKELY(lelem <= lastlelem)) {
1758         SV *lsv = *lelem++;
1759
1760         TAINT_NOT; /* Each item stands on its own, taintwise. */
1761
1762         if (UNLIKELY(!lsv)) {
1763             lsv = *lelem++;
1764             ASSUME(SvTYPE(lsv) == SVt_PVAV);
1765         }
1766
1767         switch (SvTYPE(lsv)) {
1768         case SVt_PVAV:
1769             if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
1770                 av_clear((AV*)lsv);
1771                 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1772                     SvSETMAGIC(lsv);
1773             }
1774             break;
1775
1776         case SVt_PVHV:
1777             if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
1778                 hv_clear((HV*)lsv);
1779             break;
1780
1781         default:
1782             if (!SvIMMORTAL(lsv)) {
1783                 sv_set_undef(lsv);
1784                 SvSETMAGIC(lsv);
1785                 *relem++ = lsv;
1786             }
1787             break;
1788         } /* switch */
1789     } /* while */
1790
1791     TAINT_NOT; /* result of list assign isn't tainted */
1792
1793     if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1794         /* Will be used to set PL_tainting below */
1795         Uid_t tmp_uid  = PerlProc_getuid();
1796         Uid_t tmp_euid = PerlProc_geteuid();
1797         Gid_t tmp_gid  = PerlProc_getgid();
1798         Gid_t tmp_egid = PerlProc_getegid();
1799
1800         /* XXX $> et al currently silently ignore failures */
1801         if (PL_delaymagic & DM_UID) {
1802 #ifdef HAS_SETRESUID
1803             PERL_UNUSED_RESULT(
1804                setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1805                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1806                          (Uid_t)-1));
1807 #else
1808 #  ifdef HAS_SETREUID
1809             PERL_UNUSED_RESULT(
1810                 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid  : (Uid_t)-1,
1811                          (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1812 #  else
1813 #    ifdef HAS_SETRUID
1814             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1815                 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1816                 PL_delaymagic &= ~DM_RUID;
1817             }
1818 #    endif /* HAS_SETRUID */
1819 #    ifdef HAS_SETEUID
1820             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1821                 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1822                 PL_delaymagic &= ~DM_EUID;
1823             }
1824 #    endif /* HAS_SETEUID */
1825             if (PL_delaymagic & DM_UID) {
1826                 if (PL_delaymagic_uid != PL_delaymagic_euid)
1827                     DIE(aTHX_ "No setreuid available");
1828                 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1829             }
1830 #  endif /* HAS_SETREUID */
1831 #endif /* HAS_SETRESUID */
1832
1833             tmp_uid  = PerlProc_getuid();
1834             tmp_euid = PerlProc_geteuid();
1835         }
1836         /* XXX $> et al currently silently ignore failures */
1837         if (PL_delaymagic & DM_GID) {
1838 #ifdef HAS_SETRESGID
1839             PERL_UNUSED_RESULT(
1840                 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1841                           (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1842                           (Gid_t)-1));
1843 #else
1844 #  ifdef HAS_SETREGID
1845             PERL_UNUSED_RESULT(
1846                 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid  : (Gid_t)-1,
1847                          (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1848 #  else
1849 #    ifdef HAS_SETRGID
1850             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1851                 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1852                 PL_delaymagic &= ~DM_RGID;
1853             }
1854 #    endif /* HAS_SETRGID */
1855 #    ifdef HAS_SETEGID
1856             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1857                 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1858                 PL_delaymagic &= ~DM_EGID;
1859             }
1860 #    endif /* HAS_SETEGID */
1861             if (PL_delaymagic & DM_GID) {
1862                 if (PL_delaymagic_gid != PL_delaymagic_egid)
1863                     DIE(aTHX_ "No setregid available");
1864                 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1865             }
1866 #  endif /* HAS_SETREGID */
1867 #endif /* HAS_SETRESGID */
1868
1869             tmp_gid  = PerlProc_getgid();
1870             tmp_egid = PerlProc_getegid();
1871         }
1872         TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1873 #ifdef NO_TAINT_SUPPORT
1874         PERL_UNUSED_VAR(tmp_uid);
1875         PERL_UNUSED_VAR(tmp_euid);
1876         PERL_UNUSED_VAR(tmp_gid);
1877         PERL_UNUSED_VAR(tmp_egid);
1878 #endif
1879     }
1880     PL_delaymagic = old_delaymagic;
1881
1882     if (gimme == G_VOID)
1883         SP = firstrelem - 1;
1884     else if (gimme == G_SCALAR) {
1885         dTARGET;
1886         SP = firstrelem;
1887         EXTEND(SP,1);
1888         SETi(firstlelem - firstrelem);
1889     }
1890     else
1891         SP = relem - 1;
1892
1893     RETURN;
1894 }
1895
1896 PP(pp_qr)
1897 {
1898     dSP;
1899     PMOP * const pm = cPMOP;
1900     REGEXP * rx = PM_GETRE(pm);
1901     regexp *prog = ReANY(rx);
1902     SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
1903     SV * const rv = sv_newmortal();
1904     CV **cvp;
1905     CV *cv;
1906
1907     SvUPGRADE(rv, SVt_IV);
1908     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1909        loathe to use it here, but it seems to be the right fix. Or close.
1910        The key part appears to be that it's essential for pp_qr to return a new
1911        object (SV), which implies that there needs to be an effective way to
1912        generate a new SV from the existing SV that is pre-compiled in the
1913        optree.  */
1914     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1915     SvROK_on(rv);
1916
1917     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1918     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1919         *cvp = cv_clone(cv);
1920         SvREFCNT_dec_NN(cv);
1921     }
1922
1923     if (pkg) {
1924         HV *const stash = gv_stashsv(pkg, GV_ADD);
1925         SvREFCNT_dec_NN(pkg);
1926         (void)sv_bless(rv, stash);
1927     }
1928
1929     if (UNLIKELY(RXp_ISTAINTED(prog))) {
1930         SvTAINTED_on(rv);
1931         SvTAINTED_on(SvRV(rv));
1932     }
1933     XPUSHs(rv);
1934     RETURN;
1935 }
1936
1937 PP(pp_match)
1938 {
1939     dSP; dTARG;
1940     PMOP *pm = cPMOP;
1941     PMOP *dynpm = pm;
1942     const char *s;
1943     const char *strend;
1944     SSize_t curpos = 0; /* initial pos() or current $+[0] */
1945     I32 global;
1946     U8 r_flags = 0;
1947     const char *truebase;                       /* Start of string  */
1948     REGEXP *rx = PM_GETRE(pm);
1949     regexp *prog = ReANY(rx);
1950     bool rxtainted;
1951     const U8 gimme = GIMME_V;
1952     STRLEN len;
1953     const I32 oldsave = PL_savestack_ix;
1954     I32 had_zerolen = 0;
1955     MAGIC *mg = NULL;
1956
1957     if (PL_op->op_flags & OPf_STACKED)
1958         TARG = POPs;
1959     else {
1960         if (ARGTARG)
1961             GETTARGET;
1962         else {
1963             TARG = DEFSV;
1964         }
1965         EXTEND(SP,1);
1966     }
1967
1968     PUTBACK;                            /* EVAL blocks need stack_sp. */
1969     /* Skip get-magic if this is a qr// clone, because regcomp has
1970        already done it. */
1971     truebase = prog->mother_re
1972          ? SvPV_nomg_const(TARG, len)
1973          : SvPV_const(TARG, len);
1974     if (!truebase)
1975         DIE(aTHX_ "panic: pp_match");
1976     strend = truebase + len;
1977     rxtainted = (RXp_ISTAINTED(prog) ||
1978                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1979     TAINT_NOT;
1980
1981     /* We need to know this in case we fail out early - pos() must be reset */
1982     global = dynpm->op_pmflags & PMf_GLOBAL;
1983
1984     /* PMdf_USED is set after a ?? matches once */
1985     if (
1986 #ifdef USE_ITHREADS
1987         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1988 #else
1989         pm->op_pmflags & PMf_USED
1990 #endif
1991     ) {
1992         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1993         goto nope;
1994     }
1995
1996     /* handle the empty pattern */
1997     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
1998         if (PL_curpm == PL_reg_curpm) {
1999             if (PL_curpm_under) {
2000                 if (PL_curpm_under == PL_reg_curpm) {
2001                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2002                 } else {
2003                     pm = PL_curpm_under;
2004                 }
2005             }
2006         } else {
2007             pm = PL_curpm;
2008         }
2009         rx = PM_GETRE(pm);
2010         prog = ReANY(rx);
2011     }
2012
2013     if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
2014         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
2015                                               UVuf " < %" IVdf ")\n",
2016                                               (UV)len, (IV)RXp_MINLEN(prog)));
2017         goto nope;
2018     }
2019
2020     /* get pos() if //g */
2021     if (global) {
2022         mg = mg_find_mglob(TARG);
2023         if (mg && mg->mg_len >= 0) {
2024             curpos = MgBYTEPOS(mg, TARG, truebase, len);
2025             /* last time pos() was set, it was zero-length match */
2026             if (mg->mg_flags & MGf_MINMATCH)
2027                 had_zerolen = 1;
2028         }
2029     }
2030
2031 #ifdef PERL_SAWAMPERSAND
2032     if (       RXp_NPARENS(prog)
2033             || PL_sawampersand
2034             || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2035             || (dynpm->op_pmflags & PMf_KEEPCOPY)
2036     )
2037 #endif
2038     {
2039         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
2040         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
2041          * only on the first iteration. Therefore we need to copy $' as well
2042          * as $&, to make the rest of the string available for captures in
2043          * subsequent iterations */
2044         if (! (global && gimme == G_ARRAY))
2045             r_flags |= REXEC_COPY_SKIP_POST;
2046     };
2047 #ifdef PERL_SAWAMPERSAND
2048     if (dynpm->op_pmflags & PMf_KEEPCOPY)
2049         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
2050         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
2051 #endif
2052
2053     s = truebase;
2054
2055   play_it_again:
2056     if (global)
2057         s = truebase + curpos;
2058
2059     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
2060                      had_zerolen, TARG, NULL, r_flags))
2061         goto nope;
2062
2063     PL_curpm = pm;
2064     if (dynpm->op_pmflags & PMf_ONCE)
2065 #ifdef USE_ITHREADS
2066         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
2067 #else
2068         dynpm->op_pmflags |= PMf_USED;
2069 #endif
2070
2071     if (rxtainted)
2072         RXp_MATCH_TAINTED_on(prog);
2073     TAINT_IF(RXp_MATCH_TAINTED(prog));
2074
2075     /* update pos */
2076
2077     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
2078         if (!mg)
2079             mg = sv_magicext_mglob(TARG);
2080         MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
2081         if (RXp_ZERO_LEN(prog))
2082             mg->mg_flags |= MGf_MINMATCH;
2083         else
2084             mg->mg_flags &= ~MGf_MINMATCH;
2085     }
2086
2087     if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
2088         LEAVE_SCOPE(oldsave);
2089         RETPUSHYES;
2090     }
2091
2092     /* push captures on stack */
2093
2094     {
2095         const I32 nparens = RXp_NPARENS(prog);
2096         I32 i = (global && !nparens) ? 1 : 0;
2097
2098         SPAGAIN;                        /* EVAL blocks could move the stack. */
2099         EXTEND(SP, nparens + i);
2100         EXTEND_MORTAL(nparens + i);
2101         for (i = !i; i <= nparens; i++) {
2102             PUSHs(sv_newmortal());
2103             if (LIKELY((RXp_OFFS(prog)[i].start != -1)
2104                      && RXp_OFFS(prog)[i].end   != -1 ))
2105             {
2106                 const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
2107                 const char * const s = RXp_OFFS(prog)[i].start + truebase;
2108                 if (UNLIKELY(  RXp_OFFS(prog)[i].end   < 0
2109                             || RXp_OFFS(prog)[i].start < 0
2110                             || len < 0
2111                             || len > strend - s)
2112                 )
2113                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
2114                         "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
2115                         (long) i, (long) RXp_OFFS(prog)[i].start,
2116                         (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
2117                 sv_setpvn(*SP, s, len);
2118                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
2119                     SvUTF8_on(*SP);
2120             }
2121         }
2122         if (global) {
2123             curpos = (UV)RXp_OFFS(prog)[0].end;
2124             had_zerolen = RXp_ZERO_LEN(prog);
2125             PUTBACK;                    /* EVAL blocks may use stack */
2126             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2127             goto play_it_again;
2128         }
2129         LEAVE_SCOPE(oldsave);
2130         RETURN;
2131     }
2132     NOT_REACHED; /* NOTREACHED */
2133
2134   nope:
2135     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
2136         if (!mg)
2137             mg = mg_find_mglob(TARG);
2138         if (mg)
2139             mg->mg_len = -1;
2140     }
2141     LEAVE_SCOPE(oldsave);
2142     if (gimme == G_ARRAY)
2143         RETURN;
2144     RETPUSHNO;
2145 }
2146
2147 OP *
2148 Perl_do_readline(pTHX)
2149 {
2150     dSP; dTARGETSTACKED;
2151     SV *sv;
2152     STRLEN tmplen = 0;
2153     STRLEN offset;
2154     PerlIO *fp;
2155     IO * const io = GvIO(PL_last_in_gv);
2156     const I32 type = PL_op->op_type;
2157     const U8 gimme = GIMME_V;
2158
2159     if (io) {
2160         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2161         if (mg) {
2162             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
2163             if (gimme == G_SCALAR) {
2164                 SPAGAIN;
2165                 SvSetSV_nosteal(TARG, TOPs);
2166                 SETTARG;
2167             }
2168             return NORMAL;
2169         }
2170     }
2171     fp = NULL;
2172     if (io) {
2173         fp = IoIFP(io);
2174         if (!fp) {
2175             if (IoFLAGS(io) & IOf_ARGV) {
2176                 if (IoFLAGS(io) & IOf_START) {
2177                     IoLINES(io) = 0;
2178                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
2179                         IoFLAGS(io) &= ~IOf_START;
2180                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
2181                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
2182                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
2183                         SvSETMAGIC(GvSV(PL_last_in_gv));
2184                         fp = IoIFP(io);
2185                         goto have_fp;
2186                     }
2187                 }
2188                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2189                 if (!fp) { /* Note: fp != IoIFP(io) */
2190                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
2191                 }
2192             }
2193             else if (type == OP_GLOB)
2194                 fp = Perl_start_glob(aTHX_ POPs, io);
2195         }
2196         else if (type == OP_GLOB)
2197             SP--;
2198         else if (IoTYPE(io) == IoTYPE_WRONLY) {
2199             report_wrongway_fh(PL_last_in_gv, '>');
2200         }
2201     }
2202     if (!fp) {
2203         if ((!io || !(IoFLAGS(io) & IOf_START))
2204             && ckWARN(WARN_CLOSED)
2205             && type != OP_GLOB)
2206         {
2207             report_evil_fh(PL_last_in_gv);
2208         }
2209         if (gimme == G_SCALAR) {
2210             /* undef TARG, and push that undefined value */
2211             if (type != OP_RCATLINE) {
2212                 sv_setsv(TARG,NULL);
2213             }
2214             PUSHTARG;
2215         }
2216         RETURN;
2217     }
2218   have_fp:
2219     if (gimme == G_SCALAR) {
2220         sv = TARG;
2221         if (type == OP_RCATLINE && SvGMAGICAL(sv))
2222             mg_get(sv);
2223         if (SvROK(sv)) {
2224             if (type == OP_RCATLINE)
2225                 SvPV_force_nomg_nolen(sv);
2226             else
2227                 sv_unref(sv);
2228         }
2229         else if (isGV_with_GP(sv)) {
2230             SvPV_force_nomg_nolen(sv);
2231         }
2232         SvUPGRADE(sv, SVt_PV);
2233         tmplen = SvLEN(sv);     /* remember if already alloced */
2234         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
2235             /* try short-buffering it. Please update t/op/readline.t
2236              * if you change the growth length.
2237              */
2238             Sv_Grow(sv, 80);
2239         }
2240         offset = 0;
2241         if (type == OP_RCATLINE && SvOK(sv)) {
2242             if (!SvPOK(sv)) {
2243                 SvPV_force_nomg_nolen(sv);
2244             }
2245             offset = SvCUR(sv);
2246         }
2247     }
2248     else {
2249         sv = sv_2mortal(newSV(80));
2250         offset = 0;
2251     }
2252
2253     /* This should not be marked tainted if the fp is marked clean */
2254 #define MAYBE_TAINT_LINE(io, sv) \
2255     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
2256         TAINT;                          \
2257         SvTAINTED_on(sv);               \
2258     }
2259
2260 /* delay EOF state for a snarfed empty file */
2261 #define SNARF_EOF(gimme,rs,io,sv) \
2262     (gimme != G_SCALAR || SvCUR(sv)                                     \
2263      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
2264
2265     for (;;) {
2266         PUTBACK;
2267         if (!sv_gets(sv, fp, offset)
2268             && (type == OP_GLOB
2269                 || SNARF_EOF(gimme, PL_rs, io, sv)
2270                 || PerlIO_error(fp)))
2271         {
2272             PerlIO_clearerr(fp);
2273             if (IoFLAGS(io) & IOf_ARGV) {
2274                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2275                 if (fp)
2276                     continue;
2277                 (void)do_close(PL_last_in_gv, FALSE);
2278             }
2279             else if (type == OP_GLOB) {
2280                 if (!do_close(PL_last_in_gv, FALSE)) {
2281                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
2282                                    "glob failed (child exited with status %d%s)",
2283                                    (int)(STATUS_CURRENT >> 8),
2284                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
2285                 }
2286             }
2287             if (gimme == G_SCALAR) {
2288                 if (type != OP_RCATLINE) {
2289                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
2290                     SvOK_off(TARG);
2291                 }
2292                 SPAGAIN;
2293                 PUSHTARG;
2294             }
2295             MAYBE_TAINT_LINE(io, sv);
2296             RETURN;
2297         }
2298         MAYBE_TAINT_LINE(io, sv);
2299         IoLINES(io)++;
2300         IoFLAGS(io) |= IOf_NOLINE;
2301         SvSETMAGIC(sv);
2302         SPAGAIN;
2303         XPUSHs(sv);
2304         if (type == OP_GLOB) {
2305             const char *t1;
2306             Stat_t statbuf;
2307
2308             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
2309                 char * const tmps = SvEND(sv) - 1;
2310                 if (*tmps == *SvPVX_const(PL_rs)) {
2311                     *tmps = '\0';
2312                     SvCUR_set(sv, SvCUR(sv) - 1);
2313                 }
2314             }
2315             for (t1 = SvPVX_const(sv); *t1; t1++)
2316 #ifdef __VMS
2317                 if (strchr("*%?", *t1))
2318 #else
2319                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
2320 #endif
2321                         break;
2322             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
2323                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
2324                 continue;
2325             }
2326         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
2327              if (ckWARN(WARN_UTF8)) {
2328                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
2329                 const STRLEN len = SvCUR(sv) - offset;
2330                 const U8 *f;
2331
2332                 if (!is_utf8_string_loc(s, len, &f))
2333                     /* Emulate :encoding(utf8) warning in the same case. */
2334                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
2335                                 "utf8 \"\\x%02X\" does not map to Unicode",
2336                                 f < (U8*)SvEND(sv) ? *f : 0);
2337              }
2338         }
2339         if (gimme == G_ARRAY) {
2340             if (SvLEN(sv) - SvCUR(sv) > 20) {
2341                 SvPV_shrink_to_cur(sv);
2342             }
2343             sv = sv_2mortal(newSV(80));
2344             continue;
2345         }
2346         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2347             /* try to reclaim a bit of scalar space (only on 1st alloc) */
2348             const STRLEN new_len
2349                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2350             SvPV_renew(sv, new_len);
2351         }
2352         RETURN;
2353     }
2354 }
2355
2356 PP(pp_helem)
2357 {
2358     dSP;
2359     HE* he;
2360     SV **svp;
2361     SV * const keysv = POPs;
2362     HV * const hv = MUTABLE_HV(POPs);
2363     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2364     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2365     SV *sv;
2366     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2367     bool preeminent = TRUE;
2368
2369     if (SvTYPE(hv) != SVt_PVHV)
2370         RETPUSHUNDEF;
2371
2372     if (localizing) {
2373         MAGIC *mg;
2374         HV *stash;
2375
2376         /* If we can determine whether the element exist,
2377          * Try to preserve the existenceness of a tied hash
2378          * element by using EXISTS and DELETE if possible.
2379          * Fallback to FETCH and STORE otherwise. */
2380         if (SvCANEXISTDELETE(hv))
2381             preeminent = hv_exists_ent(hv, keysv, 0);
2382     }
2383
2384     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2385     svp = he ? &HeVAL(he) : NULL;
2386     if (lval) {
2387         if (!svp || !*svp || *svp == &PL_sv_undef) {
2388             SV* lv;
2389             SV* key2;
2390             if (!defer) {
2391                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2392             }
2393             lv = sv_newmortal();
2394             sv_upgrade(lv, SVt_PVLV);
2395             LvTYPE(lv) = 'y';
2396             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2397             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
2398             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2399             LvTARGLEN(lv) = 1;
2400             PUSHs(lv);
2401             RETURN;
2402         }
2403         if (localizing) {
2404             if (HvNAME_get(hv) && isGV(*svp))
2405                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2406             else if (preeminent)
2407                 save_helem_flags(hv, keysv, svp,
2408                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2409             else
2410                 SAVEHDELETE(hv, keysv);
2411         }
2412         else if (PL_op->op_private & OPpDEREF) {
2413             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2414             RETURN;
2415         }
2416     }
2417     sv = (svp && *svp ? *svp : &PL_sv_undef);
2418     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2419      * was to make C<local $tied{foo} = $tied{foo}> possible.
2420      * However, it seems no longer to be needed for that purpose, and
2421      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2422      * would loop endlessly since the pos magic is getting set on the
2423      * mortal copy and lost. However, the copy has the effect of
2424      * triggering the get magic, and losing it altogether made things like
2425      * c<$tied{foo};> in void context no longer do get magic, which some
2426      * code relied on. Also, delayed triggering of magic on @+ and friends
2427      * meant the original regex may be out of scope by now. So as a
2428      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2429      * being called too many times). */
2430     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2431         mg_get(sv);
2432     PUSHs(sv);
2433     RETURN;
2434 }
2435
2436
2437 /* a stripped-down version of Perl_softref2xv() for use by
2438  * pp_multideref(), which doesn't use PL_op->op_flags */
2439
2440 STATIC GV *
2441 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2442                 const svtype type)
2443 {
2444     if (PL_op->op_private & HINT_STRICT_REFS) {
2445         if (SvOK(sv))
2446             Perl_die(aTHX_ PL_no_symref_sv, sv,
2447                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2448         else
2449             Perl_die(aTHX_ PL_no_usym, what);
2450     }
2451     if (!SvOK(sv))
2452         Perl_die(aTHX_ PL_no_usym, what);
2453     return gv_fetchsv_nomg(sv, GV_ADD, type);
2454 }
2455
2456
2457 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2458  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
2459  *
2460  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2461  * Each of these either contains a set of actions, or an argument, such as
2462  * an IV to use as an array index, or a lexical var to retrieve.
2463  * Several actions re stored per UV; we keep shifting new actions off the
2464  * one UV, and only reload when it becomes zero.
2465  */
2466
2467 PP(pp_multideref)
2468 {
2469     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2470     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2471     UV actions = items->uv;
2472
2473     assert(actions);
2474     /* this tells find_uninit_var() where we're up to */
2475     PL_multideref_pc = items;
2476
2477     while (1) {
2478         /* there are three main classes of action; the first retrieve
2479          * the initial AV or HV from a variable or the stack; the second
2480          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2481          * the third an unrolled (/DREFHV, rv2hv, helem).
2482          */
2483         switch (actions & MDEREF_ACTION_MASK) {
2484
2485         case MDEREF_reload:
2486             actions = (++items)->uv;
2487             continue;
2488
2489         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
2490             sv = PAD_SVl((++items)->pad_offset);
2491             goto do_AV_aelem;
2492
2493         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
2494             sv = UNOP_AUX_item_sv(++items);
2495             assert(isGV_with_GP(sv));
2496             sv = (SV*)GvAVn((GV*)sv);
2497             goto do_AV_aelem;
2498
2499         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
2500             {
2501                 dSP;
2502                 sv = POPs;
2503                 PUTBACK;
2504                 goto do_AV_rv2av_aelem;
2505             }
2506
2507         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
2508             sv = UNOP_AUX_item_sv(++items);
2509             assert(isGV_with_GP(sv));
2510             sv = GvSVn((GV*)sv);
2511             goto do_AV_vivify_rv2av_aelem;
2512
2513         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
2514             sv = PAD_SVl((++items)->pad_offset);
2515             /* FALLTHROUGH */
2516
2517         do_AV_vivify_rv2av_aelem:
2518         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
2519             /* this is the OPpDEREF action normally found at the end of
2520              * ops like aelem, helem, rv2sv */
2521             sv = vivify_ref(sv, OPpDEREF_AV);
2522             /* FALLTHROUGH */
2523
2524         do_AV_rv2av_aelem:
2525             /* this is basically a copy of pp_rv2av when it just has the
2526              * sKR/1 flags */
2527             SvGETMAGIC(sv);
2528             if (LIKELY(SvROK(sv))) {
2529                 if (UNLIKELY(SvAMAGIC(sv))) {
2530                     sv = amagic_deref_call(sv, to_av_amg);
2531                 }
2532                 sv = SvRV(sv);
2533                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2534                     DIE(aTHX_ "Not an ARRAY reference");
2535             }
2536             else if (SvTYPE(sv) != SVt_PVAV) {
2537                 if (!isGV_with_GP(sv))
2538                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2539                 sv = MUTABLE_SV(GvAVn((GV*)sv));
2540             }
2541             /* FALLTHROUGH */
2542
2543         do_AV_aelem:
2544             {
2545                 /* retrieve the key; this may be either a lexical or package
2546                  * var (whose index/ptr is stored as an item) or a signed
2547                  * integer constant stored as an item.
2548                  */
2549                 SV *elemsv;
2550                 IV elem = 0; /* to shut up stupid compiler warnings */
2551
2552
2553                 assert(SvTYPE(sv) == SVt_PVAV);
2554
2555                 switch (actions & MDEREF_INDEX_MASK) {
2556                 case MDEREF_INDEX_none:
2557                     goto finish;
2558                 case MDEREF_INDEX_const:
2559                     elem  = (++items)->iv;
2560                     break;
2561                 case MDEREF_INDEX_padsv:
2562                     elemsv = PAD_SVl((++items)->pad_offset);
2563                     goto check_elem;
2564                 case MDEREF_INDEX_gvsv:
2565                     elemsv = UNOP_AUX_item_sv(++items);
2566                     assert(isGV_with_GP(elemsv));
2567                     elemsv = GvSVn((GV*)elemsv);
2568                 check_elem:
2569                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2570                                             && ckWARN(WARN_MISC)))
2571                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2572                                 "Use of reference \"%" SVf "\" as array index",
2573                                 SVfARG(elemsv));
2574                     /* the only time that S_find_uninit_var() needs this
2575                      * is to determine which index value triggered the
2576                      * undef warning. So just update it here. Note that
2577                      * since we don't save and restore this var (e.g. for
2578                      * tie or overload execution), its value will be
2579                      * meaningless apart from just here */
2580                     PL_multideref_pc = items;
2581                     elem = SvIV(elemsv);
2582                     break;
2583                 }
2584
2585
2586                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2587
2588                 if (!(actions & MDEREF_FLAG_last)) {
2589                     SV** svp = av_fetch((AV*)sv, elem, 1);
2590                     if (!svp || ! (sv=*svp))
2591                         DIE(aTHX_ PL_no_aelem, elem);
2592                     break;
2593                 }
2594
2595                 if (PL_op->op_private &
2596                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2597                 {
2598                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2599                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2600                     }
2601                     else {
2602                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2603                         sv = av_delete((AV*)sv, elem, discard);
2604                         if (discard)
2605                             return NORMAL;
2606                         if (!sv)
2607                             sv = &PL_sv_undef;
2608                     }
2609                 }
2610                 else {
2611                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2612                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2613                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2614                     bool preeminent = TRUE;
2615                     AV *const av = (AV*)sv;
2616                     SV** svp;
2617
2618                     if (UNLIKELY(localizing)) {
2619                         MAGIC *mg;
2620                         HV *stash;
2621
2622                         /* If we can determine whether the element exist,
2623                          * Try to preserve the existenceness of a tied array
2624                          * element by using EXISTS and DELETE if possible.
2625                          * Fallback to FETCH and STORE otherwise. */
2626                         if (SvCANEXISTDELETE(av))
2627                             preeminent = av_exists(av, elem);
2628                     }
2629
2630                     svp = av_fetch(av, elem, lval && !defer);
2631
2632                     if (lval) {
2633                         if (!svp || !(sv = *svp)) {
2634                             IV len;
2635                             if (!defer)
2636                                 DIE(aTHX_ PL_no_aelem, elem);
2637                             len = av_tindex(av);
2638                             sv = sv_2mortal(newSVavdefelem(av,
2639                             /* Resolve a negative index now, unless it points
2640                              * before the beginning of the array, in which
2641                              * case record it for error reporting in
2642                              * magic_setdefelem. */
2643                                 elem < 0 && len + elem >= 0
2644                                     ? len + elem : elem, 1));
2645                         }
2646                         else {
2647                             if (UNLIKELY(localizing)) {
2648                                 if (preeminent) {
2649                                     save_aelem(av, elem, svp);
2650                                     sv = *svp; /* may have changed */
2651                                 }
2652                                 else
2653                                     SAVEADELETE(av, elem);
2654                             }
2655                         }
2656                     }
2657                     else {
2658                         sv = (svp ? *svp : &PL_sv_undef);
2659                         /* see note in pp_helem() */
2660                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2661                             mg_get(sv);
2662                     }
2663                 }
2664
2665             }
2666           finish:
2667             {
2668                 dSP;
2669                 XPUSHs(sv);
2670                 RETURN;
2671             }
2672             /* NOTREACHED */
2673
2674
2675
2676
2677         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
2678             sv = PAD_SVl((++items)->pad_offset);
2679             goto do_HV_helem;
2680
2681         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
2682             sv = UNOP_AUX_item_sv(++items);
2683             assert(isGV_with_GP(sv));
2684             sv = (SV*)GvHVn((GV*)sv);
2685             goto do_HV_helem;
2686
2687         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
2688             {
2689                 dSP;
2690                 sv = POPs;
2691                 PUTBACK;
2692                 goto do_HV_rv2hv_helem;
2693             }
2694
2695         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
2696             sv = UNOP_AUX_item_sv(++items);
2697             assert(isGV_with_GP(sv));
2698             sv = GvSVn((GV*)sv);
2699             goto do_HV_vivify_rv2hv_helem;
2700
2701         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
2702             sv = PAD_SVl((++items)->pad_offset);
2703             /* FALLTHROUGH */
2704
2705         do_HV_vivify_rv2hv_helem:
2706         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
2707             /* this is the OPpDEREF action normally found at the end of
2708              * ops like aelem, helem, rv2sv */
2709             sv = vivify_ref(sv, OPpDEREF_HV);
2710             /* FALLTHROUGH */
2711
2712         do_HV_rv2hv_helem:
2713             /* this is basically a copy of pp_rv2hv when it just has the
2714              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2715
2716             SvGETMAGIC(sv);
2717             if (LIKELY(SvROK(sv))) {
2718                 if (UNLIKELY(SvAMAGIC(sv))) {
2719                     sv = amagic_deref_call(sv, to_hv_amg);
2720                 }
2721                 sv = SvRV(sv);
2722                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2723                     DIE(aTHX_ "Not a HASH reference");
2724             }
2725             else if (SvTYPE(sv) != SVt_PVHV) {
2726                 if (!isGV_with_GP(sv))
2727                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2728                 sv = MUTABLE_SV(GvHVn((GV*)sv));
2729             }
2730             /* FALLTHROUGH */
2731
2732         do_HV_helem:
2733             {
2734                 /* retrieve the key; this may be either a lexical / package
2735                  * var or a string constant, whose index/ptr is stored as an
2736                  * item
2737                  */
2738                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2739
2740                 assert(SvTYPE(sv) == SVt_PVHV);
2741
2742                 switch (actions & MDEREF_INDEX_MASK) {
2743                 case MDEREF_INDEX_none:
2744                     goto finish;
2745
2746                 case MDEREF_INDEX_const:
2747                     keysv = UNOP_AUX_item_sv(++items);
2748                     break;
2749
2750                 case MDEREF_INDEX_padsv:
2751                     keysv = PAD_SVl((++items)->pad_offset);
2752                     break;
2753
2754                 case MDEREF_INDEX_gvsv:
2755                     keysv = UNOP_AUX_item_sv(++items);
2756                     keysv = GvSVn((GV*)keysv);
2757                     break;
2758                 }
2759
2760                 /* see comment above about setting this var */
2761                 PL_multideref_pc = items;
2762
2763
2764                 /* ensure that candidate CONSTs have been HEKified */
2765                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2766                        || SvTYPE(keysv) >= SVt_PVMG
2767                        || !SvOK(keysv)
2768                        || SvROK(keysv)
2769                        || SvIsCOW_shared_hash(keysv));
2770
2771                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2772
2773                 if (!(actions & MDEREF_FLAG_last)) {
2774                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2775                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2776                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2777                     break;
2778                 }
2779
2780                 if (PL_op->op_private &
2781                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2782                 {
2783                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2784                         sv = hv_exists_ent((HV*)sv, keysv, 0)
2785                                                 ? &PL_sv_yes : &PL_sv_no;
2786                     }
2787                     else {
2788                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2789                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2790                         if (discard)
2791                             return NORMAL;
2792                         if (!sv)
2793                             sv = &PL_sv_undef;
2794                     }
2795                 }
2796                 else {
2797                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2798                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2799                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2800                     bool preeminent = TRUE;
2801                     SV **svp;
2802                     HV * const hv = (HV*)sv;
2803                     HE* he;
2804
2805                     if (UNLIKELY(localizing)) {
2806                         MAGIC *mg;
2807                         HV *stash;
2808
2809                         /* If we can determine whether the element exist,
2810                          * Try to preserve the existenceness of a tied hash
2811                          * element by using EXISTS and DELETE if possible.
2812                          * Fallback to FETCH and STORE otherwise. */
2813                         if (SvCANEXISTDELETE(hv))
2814                             preeminent = hv_exists_ent(hv, keysv, 0);
2815                     }
2816
2817                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2818                     svp = he ? &HeVAL(he) : NULL;
2819
2820
2821                     if (lval) {
2822                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2823                             SV* lv;
2824                             SV* key2;
2825                             if (!defer)
2826                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2827                             lv = sv_newmortal();
2828                             sv_upgrade(lv, SVt_PVLV);
2829                             LvTYPE(lv) = 'y';
2830                             sv_magic(lv, key2 = newSVsv(keysv),
2831                                                 PERL_MAGIC_defelem, NULL, 0);
2832                             /* sv_magic() increments refcount */
2833                             SvREFCNT_dec_NN(key2);
2834                             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2835                             LvTARGLEN(lv) = 1;
2836                             sv = lv;
2837                         }
2838                         else {
2839                             if (localizing) {
2840                                 if (HvNAME_get(hv) && isGV(sv))
2841                                     save_gp(MUTABLE_GV(sv),
2842                                         !(PL_op->op_flags & OPf_SPECIAL));
2843                                 else if (preeminent) {
2844                                     save_helem_flags(hv, keysv, svp,
2845                                          (PL_op->op_flags & OPf_SPECIAL)
2846                                             ? 0 : SAVEf_SETMAGIC);
2847                                     sv = *svp; /* may have changed */
2848                                 }
2849                                 else
2850                                     SAVEHDELETE(hv, keysv);
2851                             }
2852                         }
2853                     }
2854                     else {
2855                         sv = (svp && *svp ? *svp : &PL_sv_undef);
2856                         /* see note in pp_helem() */
2857                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2858                             mg_get(sv);
2859                     }
2860                 }
2861                 goto finish;
2862             }
2863
2864         } /* switch */
2865
2866         actions >>= MDEREF_SHIFT;
2867     } /* while */
2868     /* NOTREACHED */
2869 }
2870
2871
2872 PP(pp_iter)
2873 {
2874     PERL_CONTEXT *cx;
2875     SV *oldsv;
2876     SV **itersvp;
2877     SV *retsv;
2878
2879     SV *sv;
2880     AV *av;
2881     IV ix;
2882     IV inc;
2883
2884     cx = CX_CUR();
2885     itersvp = CxITERVAR(cx);
2886     assert(itersvp);
2887
2888     switch (CxTYPE(cx)) {
2889
2890     case CXt_LOOP_LAZYSV: /* string increment */
2891     {
2892         SV* cur = cx->blk_loop.state_u.lazysv.cur;
2893         SV *end = cx->blk_loop.state_u.lazysv.end;
2894         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2895            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
2896         STRLEN maxlen = 0;
2897         const char *max = SvPV_const(end, maxlen);
2898         if (DO_UTF8(end) && IN_UNI_8_BIT)
2899             maxlen = sv_len_utf8_nomg(end);
2900         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2901             goto retno;
2902
2903         oldsv = *itersvp;
2904         /* NB: on the first iteration, oldsv will have a ref count of at
2905          * least 2 (one extra from blk_loop.itersave), so the GV or pad
2906          * slot will get localised; on subsequent iterations the RC==1
2907          * optimisation may kick in and the SV will be reused. */
2908          if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2909             /* safe to reuse old SV */
2910             sv_setsv(oldsv, cur);
2911         }
2912         else
2913         {
2914             /* we need a fresh SV every time so that loop body sees a
2915              * completely new SV for closures/references to work as
2916              * they used to */
2917             *itersvp = newSVsv(cur);
2918             SvREFCNT_dec(oldsv);
2919         }
2920         if (strEQ(SvPVX_const(cur), max))
2921             sv_setiv(cur, 0); /* terminate next time */
2922         else
2923             sv_inc(cur);
2924         break;
2925     }
2926
2927     case CXt_LOOP_LAZYIV: /* integer increment */
2928     {
2929         IV cur = cx->blk_loop.state_u.lazyiv.cur;
2930         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2931             goto retno;
2932
2933         oldsv = *itersvp;
2934         /* see NB comment above */
2935         if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2936             /* safe to reuse old SV */
2937
2938             if (    (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
2939                  == SVt_IV)
2940             {
2941                 /* Cheap SvIOK_only().
2942                  * Assert that flags which SvIOK_only() would test or
2943                  * clear can't be set, because we're SVt_IV */
2944                 assert(!(SvFLAGS(oldsv) &
2945                     (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
2946                 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
2947                 /* SvIV_set() where sv_any points to head */
2948                 oldsv->sv_u.svu_iv = cur;
2949
2950             }
2951             else
2952                 sv_setiv(oldsv, cur);
2953         }
2954         else
2955         {
2956             /* we need a fresh SV every time so that loop body sees a
2957              * completely new SV for closures/references to work as they
2958              * used to */
2959             *itersvp = newSViv(cur);
2960             SvREFCNT_dec(oldsv);
2961         }
2962
2963         if (UNLIKELY(cur == IV_MAX)) {
2964             /* Handle end of range at IV_MAX */
2965             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2966         } else
2967             ++cx->blk_loop.state_u.lazyiv.cur;
2968         break;
2969     }
2970
2971     case CXt_LOOP_LIST: /* for (1,2,3) */
2972
2973         assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
2974         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
2975         ix = (cx->blk_loop.state_u.stack.ix += inc);
2976         if (UNLIKELY(inc > 0
2977                         ? ix > cx->blk_oldsp
2978                         : ix <= cx->blk_loop.state_u.stack.basesp)
2979         )
2980             goto retno;
2981
2982         sv = PL_stack_base[ix];
2983         av = NULL;
2984         goto loop_ary_common;
2985
2986     case CXt_LOOP_ARY: /* for (@ary) */
2987
2988         av = cx->blk_loop.state_u.ary.ary;
2989         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
2990         ix = (cx->blk_loop.state_u.ary.ix += inc);
2991         if (UNLIKELY(inc > 0
2992                         ? ix > AvFILL(av)
2993                         : ix < 0)
2994         )
2995             goto retno;
2996
2997         if (UNLIKELY(SvRMAGICAL(av))) {
2998             SV * const * const svp = av_fetch(av, ix, FALSE);
2999             sv = svp ? *svp : NULL;
3000         }
3001         else {
3002             sv = AvARRAY(av)[ix];
3003         }
3004
3005       loop_ary_common:
3006
3007         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
3008             SvSetMagicSV(*itersvp, sv);
3009             break;
3010         }
3011
3012         if (LIKELY(sv)) {
3013             if (UNLIKELY(SvIS_FREED(sv))) {
3014                 *itersvp = NULL;
3015                 Perl_croak(aTHX_ "Use of freed value in iteration");
3016             }
3017             if (SvPADTMP(sv)) {
3018                 sv = newSVsv(sv);
3019             }
3020             else {
3021                 SvTEMP_off(sv);
3022                 SvREFCNT_inc_simple_void_NN(sv);
3023             }
3024         }
3025         else if (av) {
3026             sv = newSVavdefelem(av, ix, 0);
3027         }
3028         else
3029             sv = &PL_sv_undef;
3030
3031         oldsv = *itersvp;
3032         *itersvp = sv;
3033         SvREFCNT_dec(oldsv);
3034         break;
3035
3036     default:
3037         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
3038     }
3039
3040     retsv = &PL_sv_yes;
3041     if (0) {
3042       retno:
3043         retsv = &PL_sv_no;
3044     }
3045     /* pp_enteriter should have pre-extended the stack */
3046     EXTEND_SKIP(PL_stack_sp, 1);
3047     *++PL_stack_sp =retsv;
3048
3049     return PL_op->op_next;
3050 }
3051
3052 /*
3053 A description of how taint works in pattern matching and substitution.
3054
3055 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
3056 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
3057
3058 While the pattern is being assembled/concatenated and then compiled,
3059 PL_tainted will get set (via TAINT_set) if any component of the pattern
3060 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
3061 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
3062 TAINT_get).  It will also be set if any component of the pattern matches
3063 based on locale-dependent behavior.
3064
3065 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
3066 the pattern is marked as tainted. This means that subsequent usage, such
3067 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
3068 on the new pattern too.
3069
3070 RXf_TAINTED_SEEN is used post-execution by the get magic code
3071 of $1 et al to indicate whether the returned value should be tainted.
3072 It is the responsibility of the caller of the pattern (i.e. pp_match,
3073 pp_subst etc) to set this flag for any other circumstances where $1 needs
3074 to be tainted.
3075
3076 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
3077
3078 There are three possible sources of taint
3079     * the source string
3080     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
3081     * the replacement string (or expression under /e)
3082
3083 There are four destinations of taint and they are affected by the sources
3084 according to the rules below:
3085
3086     * the return value (not including /r):
3087         tainted by the source string and pattern, but only for the
3088         number-of-iterations case; boolean returns aren't tainted;
3089     * the modified string (or modified copy under /r):
3090         tainted by the source string, pattern, and replacement strings;
3091     * $1 et al:
3092         tainted by the pattern, and under 'use re "taint"', by the source
3093         string too;
3094     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
3095         should always be unset before executing subsequent code.
3096
3097 The overall action of pp_subst is:
3098
3099     * at the start, set bits in rxtainted indicating the taint status of
3100         the various sources.
3101
3102     * After each pattern execution, update the SUBST_TAINT_PAT bit in
3103         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
3104         pattern has subsequently become tainted via locale ops.
3105
3106     * If control is being passed to pp_substcont to execute a /e block,
3107         save rxtainted in the CXt_SUBST block, for future use by
3108         pp_substcont.
3109
3110     * Whenever control is being returned to perl code (either by falling
3111         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
3112         use the flag bits in rxtainted to make all the appropriate types of
3113         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
3114         et al will appear tainted.
3115
3116 pp_match is just a simpler version of the above.
3117
3118 */
3119
3120 PP(pp_subst)
3121 {
3122     dSP; dTARG;
3123     PMOP *pm = cPMOP;
3124     PMOP *rpm = pm;
3125     char *s;
3126     char *strend;
3127     const char *c;
3128     STRLEN clen;
3129     SSize_t iters = 0;
3130     SSize_t maxiters;
3131     bool once;
3132     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
3133                         See "how taint works" above */
3134     char *orig;
3135     U8 r_flags;
3136     REGEXP *rx = PM_GETRE(pm);
3137     regexp *prog = ReANY(rx);
3138     STRLEN len;
3139     int force_on_match = 0;
3140     const I32 oldsave = PL_savestack_ix;
3141     STRLEN slen;
3142     bool doutf8 = FALSE; /* whether replacement is in utf8 */
3143 #ifdef PERL_ANY_COW
3144     bool was_cow;
3145 #endif
3146     SV *nsv = NULL;
3147     /* known replacement string? */
3148     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
3149
3150     PERL_ASYNC_CHECK();
3151
3152     if (PL_op->op_flags & OPf_STACKED)
3153         TARG = POPs;
3154     else {
3155         if (ARGTARG)
3156             GETTARGET;
3157         else {
3158             TARG = DEFSV;
3159         }
3160         EXTEND(SP,1);
3161     }
3162
3163     SvGETMAGIC(TARG); /* must come before cow check */
3164 #ifdef PERL_ANY_COW
3165     /* note that a string might get converted to COW during matching */
3166     was_cow = cBOOL(SvIsCOW(TARG));
3167 #endif
3168     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3169 #ifndef PERL_ANY_COW
3170         if (SvIsCOW(TARG))
3171             sv_force_normal_flags(TARG,0);
3172 #endif
3173         if ((SvREADONLY(TARG)
3174                 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
3175                       || SvTYPE(TARG) > SVt_PVLV)
3176                      && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
3177             Perl_croak_no_modify();
3178     }
3179     PUTBACK;
3180
3181     orig = SvPV_nomg(TARG, len);
3182     /* note we don't (yet) force the var into being a string; if we fail
3183      * to match, we leave as-is; on successful match however, we *will*
3184      * coerce into a string, then repeat the match */
3185     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
3186         force_on_match = 1;
3187
3188     /* only replace once? */
3189     once = !(rpm->op_pmflags & PMf_GLOBAL);
3190
3191     /* See "how taint works" above */
3192     if (TAINTING_get) {
3193         rxtainted  = (
3194             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
3195           | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
3196           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
3197           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3198                 ? SUBST_TAINT_BOOLRET : 0));
3199         TAINT_NOT;
3200     }
3201
3202   force_it:
3203     if (!pm || !orig)
3204         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
3205
3206     strend = orig + len;
3207     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
3208     maxiters = 2 * slen + 10;   /* We can match twice at each
3209                                    position, once with zero-length,
3210                                    second time with non-zero. */
3211
3212     /* handle the empty pattern */
3213     if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
3214         if (PL_curpm == PL_reg_curpm) {
3215             if (PL_curpm_under) {
3216                 if (PL_curpm_under == PL_reg_curpm) {
3217                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3218                 } else {
3219                     pm = PL_curpm_under;
3220                 }
3221             }
3222         } else {
3223             pm = PL_curpm;
3224         }
3225         rx = PM_GETRE(pm);
3226         prog = ReANY(rx);
3227     }
3228
3229 #ifdef PERL_SAWAMPERSAND
3230     r_flags = (    RXp_NPARENS(prog)
3231                 || PL_sawampersand
3232                 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3233                 || (rpm->op_pmflags & PMf_KEEPCOPY)
3234               )
3235           ? REXEC_COPY_STR
3236           : 0;
3237 #else
3238     r_flags = REXEC_COPY_STR;
3239 #endif
3240
3241     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
3242     {
3243         SPAGAIN;
3244         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
3245         LEAVE_SCOPE(oldsave);
3246         RETURN;
3247     }
3248     PL_curpm = pm;
3249
3250     /* known replacement string? */
3251     if (dstr) {
3252         /* replacement needing upgrading? */
3253         if (DO_UTF8(TARG) && !doutf8) {
3254              nsv = sv_newmortal();
3255              SvSetSV(nsv, dstr);
3256              sv_utf8_upgrade(nsv);
3257              c = SvPV_const(nsv, clen);
3258              doutf8 = TRUE;
3259         }
3260         else {
3261             c = SvPV_const(dstr, clen);
3262             doutf8 = DO_UTF8(dstr);
3263         }
3264
3265         if (SvTAINTED(dstr))
3266             rxtainted |= SUBST_TAINT_REPL;
3267     }
3268     else {
3269         c = NULL;
3270         doutf8 = FALSE;
3271     }
3272
3273     /* can do inplace substitution? */
3274     if (c
3275 #ifdef PERL_ANY_COW
3276         && !was_cow
3277 #endif
3278         && (I32)clen <= RXp_MINLENRET(prog)
3279         && (  once
3280            || !(r_flags & REXEC_COPY_STR)
3281            || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
3282            )
3283         && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
3284         && (!doutf8 || SvUTF8(TARG))
3285         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3286     {
3287
3288 #ifdef PERL_ANY_COW
3289         /* string might have got converted to COW since we set was_cow */
3290         if (SvIsCOW(TARG)) {
3291           if (!force_on_match)
3292             goto have_a_cow;
3293           assert(SvVOK(TARG));
3294         }
3295 #endif
3296         if (force_on_match) {
3297             /* redo the first match, this time with the orig var
3298              * forced into being a string */
3299             force_on_match = 0;
3300             orig = SvPV_force_nomg(TARG, len);
3301             goto force_it;
3302         }
3303
3304         if (once) {
3305             char *d, *m;
3306             if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
3307                 rxtainted |= SUBST_TAINT_PAT;
3308             m = orig + RXp_OFFS(prog)[0].start;
3309             d = orig + RXp_OFFS(prog)[0].end;
3310             s = orig;
3311             if (m - s > strend - d) {  /* faster to shorten from end */
3312                 I32 i;
3313                 if (clen) {
3314                     Copy(c, m, clen, char);
3315                     m += clen;
3316                 }
3317                 i = strend - d;
3318                 if (i > 0) {
3319                     Move(d, m, i, char);
3320                     m += i;
3321                 }
3322                 *m = '\0';
3323                 SvCUR_set(TARG, m - s);
3324             }
3325             else {      /* faster from front */
3326                 I32 i = m - s;
3327                 d -= clen;
3328                 if (i > 0)
3329                     Move(s, d - i, i, char);
3330                 sv_chop(TARG, d-i);
3331                 if (clen)
3332                     Copy(c, d, clen, char);
3333             }
3334             SPAGAIN;
3335             PUSHs(&PL_sv_yes);
3336         }
3337         else {
3338             char *d, *m;
3339             d = s = RXp_OFFS(prog)[0].start + orig;
3340             do {
3341                 I32 i;
3342                 if (UNLIKELY(iters++ > maxiters))
3343                     DIE(aTHX_ "Substitution loop");
3344                 /* run time pattern taint, eg locale */
3345                 if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
3346                     rxtainted |= SUBST_TAINT_PAT;
3347                 m = RXp_OFFS(prog)[0].start + orig;
3348                 if ((i = m - s)) {
3349                     if (s != d)
3350                         Move(s, d, i, char);
3351                     d += i;
3352                 }
3353                 if (clen) {
3354                     Copy(c, d, clen, char);
3355                     d += clen;
3356                 }
3357                 s = RXp_OFFS(prog)[0].end + orig;
3358             } while (CALLREGEXEC(rx, s, strend, orig,
3359                                  s == m, /* don't match same null twice */
3360                                  TARG, NULL,
3361                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3362             if (s != d) {
3363                 I32 i = strend - s;
3364                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
3365                 Move(s, d, i+1, char);          /* include the NUL */
3366             }
3367             SPAGAIN;
3368             mPUSHi(iters);
3369         }
3370     }
3371     else {
3372         bool first;
3373         char *m;
3374         SV *repl;
3375         if (force_on_match) {
3376             /* redo the first match, this time with the orig var
3377              * forced into being a string */
3378             force_on_match = 0;
3379             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3380                 /* I feel that it should be possible to avoid this mortal copy
3381                    given that the code below copies into a new destination.
3382                    However, I suspect it isn't worth the complexity of
3383                    unravelling the C<goto force_it> for the small number of
3384                    cases where it would be viable to drop into the copy code. */
3385                 TARG = sv_2mortal(newSVsv(TARG));
3386             }
3387             orig = SvPV_force_nomg(TARG, len);
3388             goto force_it;
3389         }
3390 #ifdef PERL_ANY_COW
3391       have_a_cow:
3392 #endif
3393         if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
3394             rxtainted |= SUBST_TAINT_PAT;
3395         repl = dstr;
3396         s = RXp_OFFS(prog)[0].start + orig;
3397         dstr = newSVpvn_flags(orig, s-orig,
3398                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3399         if (!c) {
3400             PERL_CONTEXT *cx;
3401             SPAGAIN;
3402             m = orig;
3403             /* note that a whole bunch of local vars are saved here for
3404              * use by pp_substcont: here's a list of them in case you're
3405              * searching for places in this sub that uses a particular var:
3406              * iters maxiters r_flags oldsave rxtainted orig dstr targ
3407              * s m strend rx once */
3408             CX_PUSHSUBST(cx);
3409             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3410         }
3411         first = TRUE;
3412         do {
3413             if (UNLIKELY(iters++ > maxiters))
3414                 DIE(aTHX_ "Substitution loop");
3415             if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
3416                 rxtainted |= SUBST_TAINT_PAT;
3417             if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
3418                 char *old_s    = s;
3419                 char *old_orig = orig;
3420                 assert(RXp_SUBOFFSET(prog) == 0);
3421
3422                 orig = RXp_SUBBEG(prog);
3423                 s = orig + (old_s - old_orig);
3424                 strend = s + (strend - old_s);
3425             }
3426             m = RXp_OFFS(prog)[0].start + orig;
3427             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3428             s = RXp_OFFS(prog)[0].end + orig;
3429             if (first) {
3430                 /* replacement already stringified */
3431               if (clen)
3432                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3433               first = FALSE;
3434             }
3435             else {
3436                 sv_catsv(dstr, repl);
3437                 if (UNLIKELY(SvTAINTED(repl)))
3438                     rxtainted |= SUBST_TAINT_REPL;
3439             }
3440             if (once)
3441                 break;
3442         } while (CALLREGEXEC(rx, s, strend, orig,
3443                              s == m,    /* Yields minend of 0 or 1 */
3444                              TARG, NULL,
3445                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3446         assert(strend >= s);
3447         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3448
3449         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3450             /* From here on down we're using the copy, and leaving the original
3451                untouched.  */
3452             TARG = dstr;
3453             SPAGAIN;
3454             PUSHs(dstr);
3455         } else {
3456 #ifdef PERL_ANY_COW
3457             /* The match may make the string COW. If so, brilliant, because
3458                that's just saved us one malloc, copy and free - the regexp has
3459                donated the old buffer, and we malloc an entirely new one, rather
3460                than the regexp malloc()ing a buffer and copying our original,
3461                only for us to throw it away here during the substitution.  */
3462             if (SvIsCOW(TARG)) {
3463                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3464             } else
3465 #endif
3466             {
3467                 SvPV_free(TARG);
3468             }
3469             SvPV_set(TARG, SvPVX(dstr));
3470             SvCUR_set(TARG, SvCUR(dstr));
3471             SvLEN_set(TARG, SvLEN(dstr));
3472             SvFLAGS(TARG) |= SvUTF8(dstr);
3473             SvPV_set(dstr, NULL);
3474
3475             SPAGAIN;
3476             mPUSHi(iters);
3477         }
3478     }
3479
3480     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3481         (void)SvPOK_only_UTF8(TARG);
3482     }
3483
3484     /* See "how taint works" above */
3485     if (TAINTING_get) {
3486         if ((rxtainted & SUBST_TAINT_PAT) ||
3487             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3488                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3489         )
3490             (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
3491
3492         if (!(rxtainted & SUBST_TAINT_BOOLRET)
3493             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3494         )
3495             SvTAINTED_on(TOPs);  /* taint return value */
3496         else
3497             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
3498
3499         /* needed for mg_set below */
3500         TAINT_set(
3501           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3502         );
3503         SvTAINT(TARG);
3504     }
3505     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3506     TAINT_NOT;
3507     LEAVE_SCOPE(oldsave);
3508     RETURN;
3509 }
3510
3511 PP(pp_grepwhile)
3512 {
3513     dSP;
3514
3515     if (SvTRUEx(POPs))
3516         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3517     ++*PL_markstack_ptr;
3518     FREETMPS;
3519     LEAVE_with_name("grep_item");                                       /* exit inner scope */
3520
3521     /* All done yet? */
3522     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3523         I32 items;
3524         const U8 gimme = GIMME_V;
3525
3526         LEAVE_with_name("grep");                                        /* exit outer scope */
3527         (void)POPMARK;                          /* pop src */
3528         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3529         (void)POPMARK;                          /* pop dst */
3530         SP = PL_stack_base + POPMARK;           /* pop original mark */
3531         if (gimme == G_SCALAR) {
3532                 dTARGET;
3533                 XPUSHi(items);
3534         }
3535         else if (gimme == G_ARRAY)
3536             SP += items;
3537         RETURN;
3538     }
3539     else {
3540         SV *src;
3541
3542         ENTER_with_name("grep_item");                                   /* enter inner scope */
3543         SAVEVPTR(PL_curpm);
3544
3545         src = PL_stack_base[TOPMARK];
3546         if (SvPADTMP(src)) {
3547             src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
3548             PL_tmps_floor++;
3549         }
3550         SvTEMP_off(src);
3551         DEFSV_set(src);
3552
3553         RETURNOP(cLOGOP->op_other);
3554     }
3555 }
3556
3557 /* leave_adjust_stacks():
3558  *
3559  * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
3560  * positioning them at to_sp+1 onwards, and do the equivalent of a
3561  * FREEMPS and TAINT_NOT.
3562  *
3563  * Not intended to be called in void context.
3564  *
3565  * When leaving a sub, eval, do{} or other scope, the things that need
3566  * doing to process the return args are:
3567  *    * in scalar context, only return the last arg (or PL_sv_undef if none);
3568  *    * for the types of return that return copies of their args (such
3569  *      as rvalue sub return), make a mortal copy of every return arg,
3570  *      except where we can optimise the copy away without it being
3571  *      semantically visible;
3572  *    * make sure that the arg isn't prematurely freed; in the case of an
3573  *      arg not copied, this may involve mortalising it. For example, in
3574  *      C<sub f { my $x = ...; $x }>, $x would be freed when we do
3575  *      CX_LEAVE_SCOPE(cx) unless it's protected or copied.
3576  *
3577  * What condition to use when deciding whether to pass the arg through
3578  * or make a copy, is determined by the 'pass' arg; its valid values are:
3579  *   0: rvalue sub/eval exit
3580  *   1: other rvalue scope exit
3581  *   2: :lvalue sub exit in rvalue context
3582  *   3: :lvalue sub exit in lvalue context and other lvalue scope exits
3583  *
3584  * There is a big issue with doing a FREETMPS. We would like to free any
3585  * temps created by the last statement which the sub executed, rather than
3586  * leaving them for the caller. In a situation where a sub call isn't
3587  * soon followed by a nextstate (e.g. nested recursive calls, a la
3588  * fibonacci()), temps can accumulate, causing memory and performance
3589  * issues.
3590  *
3591  * On the other hand, we don't want to free any TEMPs which are keeping
3592  * alive any return args that we skipped copying; nor do we wish to undo
3593  * any mortalising done here.
3594  *
3595  * The solution is to split the temps stack frame into two, with a cut
3596  * point delineating the two halves. We arrange that by the end of this
3597  * function, all the temps stack frame entries we wish to keep are in the
3598  * range  PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
3599  * the range  tmps_base .. PL_tmps_ix.  During the course of this
3600  * function, tmps_base starts off as PL_tmps_floor+1, then increases
3601  * whenever we find or create a temp that we know should be kept. In
3602  * general the stuff above tmps_base is undecided until we reach the end,
3603  * and we may need a sort stage for that.
3604  *
3605  * To determine whether a TEMP is keeping a return arg alive, every
3606  * arg that is kept rather than copied and which has the SvTEMP flag
3607  * set, has the flag temporarily unset, to mark it. At the end we scan
3608  * the temps stack frame above the cut for entries without SvTEMP and
3609  * keep them, while turning SvTEMP on again. Note that if we die before
3610  * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
3611  * those SVs may be slightly less efficient.
3612  *
3613  * In practice various optimisations for some common cases mean we can
3614  * avoid most of the scanning and swapping about with the temps stack.
3615  */
3616
3617 void
3618 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
3619 {
3620     dVAR;
3621     dSP;
3622     SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
3623     SSize_t nargs;
3624
3625     PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
3626
3627     TAINT_NOT;
3628
3629     if (gimme == G_ARRAY) {
3630         nargs = SP - from_sp;
3631         from_sp++;
3632     }
3633     else {
3634         assert(gimme == G_SCALAR);
3635         if (UNLIKELY(from_sp >= SP)) {
3636             /* no return args */
3637             assert(from_sp == SP);
3638             EXTEND(SP, 1);
3639             *++SP = &PL_sv_undef;
3640             to_sp = SP;
3641             nargs   = 0;
3642         }
3643         else {
3644             from_sp = SP;
3645             nargs   = 1;
3646         }
3647     }
3648
3649     /* common code for G_SCALAR and G_ARRAY */
3650
3651     tmps_base = PL_tmps_floor + 1;
3652
3653     assert(nargs >= 0);
3654     if (nargs) {
3655         /* pointer version of tmps_base. Not safe across temp stack
3656          * reallocs. */
3657         SV **tmps_basep;
3658
3659         EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
3660         tmps_basep = PL_tmps_stack + tmps_base;
3661
3662         /* process each return arg */
3663
3664         do {
3665             SV *sv = *from_sp++;
3666
3667             assert(PL_tmps_ix + nargs < PL_tmps_max);
3668 #ifdef DEBUGGING
3669             /* PADTMPs with container set magic shouldn't appear in the
3670              * wild. This assert is more important for pp_leavesublv(),
3671              * but by testing for it here, we're more likely to catch
3672              * bad cases (what with :lvalue subs not being widely
3673              * deployed). The two issues are that for something like
3674              *     sub :lvalue { $tied{foo} }
3675              * or
3676              *     sub :lvalue { substr($foo,1,2) }
3677              * pp_leavesublv() will croak if the sub returns a PADTMP,
3678              * and currently functions like pp_substr() return a mortal
3679              * rather than using their PADTMP when returning a PVLV.
3680              * This is because the PVLV will hold a ref to $foo,
3681              * so $foo would get delayed in being freed while
3682              * the PADTMP SV remained in the PAD.
3683              * So if this assert fails it means either:
3684              *  1) there is pp code similar to pp_substr that is
3685              *     returning a PADTMP instead of a mortal, and probably
3686              *     needs fixing, or
3687              *  2) pp_leavesublv is making unwarranted assumptions
3688              *     about always croaking on a PADTMP
3689              */
3690             if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
3691                 MAGIC *mg;
3692                 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
3693                     assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
3694                 }
3695             }
3696 #endif
3697
3698             if (
3699                pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3700              : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3701              : pass == 2 ? (!SvPADTMP(sv))
3702              : 1)
3703             {
3704                 /* pass through: skip copy for logic or optimisation
3705                  * reasons; instead mortalise it, except that ... */
3706                 *++to_sp = sv;
3707
3708                 if (SvTEMP(sv)) {
3709                     /* ... since this SV is an SvTEMP , we don't need to
3710                      * re-mortalise it; instead we just need to ensure
3711                      * that its existing entry in the temps stack frame
3712                      * ends up below the cut and so avoids being freed
3713                      * this time round. We mark it as needing to be kept
3714                      * by temporarily unsetting SvTEMP; then at the end,
3715                      * we shuffle any !SvTEMP entries on the tmps stack
3716                      * back below the cut.
3717                      * However, there's a significant chance that there's
3718                      * a 1:1 correspondence between the first few (or all)
3719                      * elements in the return args stack frame and those
3720                      * in the temps stack frame; e,g.:
3721                      *      sub f { ....; map {...} .... },
3722                      * or if we're exiting multiple scopes and one of the
3723                      * inner scopes has already made mortal copies of each
3724                      * return arg.
3725                      *
3726                      * If so, this arg sv will correspond to the next item
3727                      * on the tmps stack above the cut, and so can be kept
3728                      * merely by moving the cut boundary up one, rather
3729                      * than messing with SvTEMP.  If all args are 1:1 then
3730                      * we can avoid the sorting stage below completely.
3731                      *
3732                      * If there are no items above the cut on the tmps
3733                      * stack, then the SvTEMP must comne from an item
3734                      * below the cut, so there's nothing to do.
3735                      */
3736                     if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
3737                         if (sv == *tmps_basep)
3738                             tmps_basep++;
3739                         else
3740                             SvTEMP_off(sv);
3741                     }
3742                 }
3743                 else if (!SvPADTMP(sv)) {
3744                     /* mortalise arg to avoid it being freed during save
3745                      * stack unwinding. Pad tmps don't need mortalising as
3746                      * they're never freed. This is the equivalent of
3747                      * sv_2mortal(SvREFCNT_inc(sv)), except that:
3748                      *  * it assumes that the temps stack has already been
3749                      *    extended;
3750                      *  * it puts the new item at the cut rather than at
3751                      *    ++PL_tmps_ix, moving the previous occupant there
3752                      *    instead.
3753                      */
3754                     if (!SvIMMORTAL(sv)) {
3755                         SvREFCNT_inc_simple_void_NN(sv);
3756                         SvTEMP_on(sv);
3757                         /* Note that if there's nothing above the cut,
3758                          * this copies the garbage one slot above
3759                          * PL_tmps_ix onto itself. This is harmless (the
3760                          * stack's already been extended), but might in
3761                          * theory trigger warnings from tools like ASan
3762                          */
3763                         PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3764                         *tmps_basep++ = sv;
3765                     }
3766                 }
3767             }
3768             else {
3769                 /* Make a mortal copy of the SV.
3770                  * The following code is the equivalent of sv_mortalcopy()
3771                  * except that:
3772                  *  * it assumes the temps stack has already been extended;
3773                  *  * it optimises the copying for some simple SV types;
3774                  *  * it puts the new item at the cut rather than at
3775                  *    ++PL_tmps_ix, moving the previous occupant there
3776                  *    instead.
3777                  */
3778                 SV *newsv = newSV(0);
3779
3780                 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3781                 /* put it on the tmps stack early so it gets freed if we die */
3782                 *tmps_basep++ = newsv;
3783                 *++to_sp = newsv;
3784
3785                 if (SvTYPE(sv) <= SVt_IV) {
3786                     /* arg must be one of undef, IV/UV, or RV: skip
3787                      * sv_setsv_flags() and do the copy directly */
3788                     U32 dstflags;
3789                     U32 srcflags = SvFLAGS(sv);
3790
3791                     assert(!SvGMAGICAL(sv));
3792                     if (srcflags & (SVf_IOK|SVf_ROK)) {
3793                         SET_SVANY_FOR_BODYLESS_IV(newsv);
3794
3795                         if (srcflags & SVf_ROK) {
3796                             newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
3797                             /* SV type plus flags */
3798                             dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
3799                         }
3800                         else {
3801                             /* both src and dst are <= SVt_IV, so sv_any
3802                              * points to the head; so access the heads
3803                              * directly rather than going via sv_any.
3804                              */
3805                             assert(    &(sv->sv_u.svu_iv)
3806                                     == &(((XPVIV*) SvANY(sv))->xiv_iv));
3807                             assert(    &(newsv->sv_u.svu_iv)
3808                                     == &(((XPVIV*) SvANY(newsv))->xiv_iv));
3809                             newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
3810                             /* SV type plus flags */
3811                             dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
3812                                             |(srcflags & SVf_IVisUV));
3813                         }
3814                     }
3815                     else {
3816                         assert(!(srcflags & SVf_OK));
3817                         dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
3818                     }
3819                     SvFLAGS(newsv) = dstflags;
3820
3821                 }
3822                 else {
3823                     /* do the full sv_setsv() */
3824                     SSize_t old_base;
3825
3826                     SvTEMP_on(newsv);
3827                     old_base = tmps_basep - PL_tmps_stack;
3828                     SvGETMAGIC(sv);
3829                     sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
3830                     /* the mg_get or sv_setsv might have created new temps
3831                      * or realloced the tmps stack; regrow and reload */
3832                     EXTEND_MORTAL(nargs);
3833                     tmps_basep = PL_tmps_stack + old_base;
3834                     TAINT_NOT;  /* Each item is independent */
3835                 }
3836
3837             }
3838         } while (--nargs);
3839
3840         /* If there are any temps left above the cut, we need to sort
3841          * them into those to keep and those to free. The only ones to
3842          * keep are those for which we've temporarily unset SvTEMP.
3843          * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
3844          * swapping pairs as necessary. Stop when we meet in the middle.
3845          */
3846         {
3847             SV **top = PL_tmps_stack + PL_tmps_ix;
3848             while (tmps_basep <= top) {
3849                 SV *sv = *top;
3850                 if (SvTEMP(sv))
3851                     top--;
3852                 else {
3853                     SvTEMP_on(sv);
3854                     *top = *tmps_basep;
3855                     *tmps_basep = sv;
3856                     tmps_basep++;
3857                 }
3858             }
3859         }
3860
3861         tmps_base = tmps_basep - PL_tmps_stack;
3862     }
3863
3864     PL_stack_sp = to_sp;
3865
3866     /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
3867     while (PL_tmps_ix >= tmps_base) {
3868         SV* const sv = PL_tmps_stack[PL_tmps_ix--];
3869 #ifdef PERL_POISON
3870         PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
3871 #endif
3872         if (LIKELY(sv)) {
3873             SvTEMP_off(sv);
3874             SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
3875         }
3876     }
3877 }
3878
3879
3880 /* also tail-called by pp_return */
3881
3882 PP(pp_leavesub)
3883 {
3884     U8 gimme;
3885     PERL_CONTEXT *cx;
3886     SV **oldsp;
3887     OP *retop;
3888
3889     cx = CX_CUR();
3890     assert(CxTYPE(cx) == CXt_SUB);
3891
3892     if (CxMULTICALL(cx)) {
3893         /* entry zero of a stack is always PL_sv_undef, which
3894          * simplifies converting a '()' return into undef in scalar context */
3895         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
3896         return 0;
3897     }
3898
3899     gimme = cx->blk_gimme;
3900     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
3901
3902     if (gimme == G_VOID)
3903         PL_stack_sp = oldsp;
3904     else
3905         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
3906
3907     CX_LEAVE_SCOPE(cx);
3908     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
3909     cx_popblock(cx);
3910     retop = cx->blk_sub.retop;
3911     CX_POP(cx);
3912
3913     return retop;
3914 }
3915
3916
3917 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
3918  * forces an abandon */
3919
3920 void
3921 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
3922 {
3923     const SSize_t fill = AvFILLp(av);
3924
3925     PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
3926
3927     if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
3928         av_clear(av);
3929         AvREIFY_only(av);
3930     }
3931     else {
3932         AV *newav = newAV();
3933         av_extend(newav, fill);
3934         AvREIFY_only(newav);
3935         PAD_SVl(0) = MUTABLE_SV(newav);
3936         SvREFCNT_dec_NN(av);
3937     }
3938 }
3939
3940
3941 PP(pp_entersub)
3942 {
3943     dSP; dPOPss;
3944     GV *gv;
3945     CV *cv;
3946     PERL_CONTEXT *cx;
3947     I32 old_savestack_ix;
3948
3949     if (UNLIKELY(!sv))
3950         goto do_die;
3951
3952     /* Locate the CV to call:
3953      * - most common case: RV->CV: f(), $ref->():
3954      *   note that if a sub is compiled before its caller is compiled,
3955      *   the stash entry will be a ref to a CV, rather than being a GV.
3956      * - second most common case: CV: $ref->method()
3957      */
3958
3959     /* a non-magic-RV -> CV ? */
3960     if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
3961         cv = MUTABLE_CV(SvRV(sv));
3962         if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
3963             goto do_ref;
3964     }
3965     else
3966         cv = MUTABLE_CV(sv);
3967
3968     /* a CV ? */
3969     if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
3970         /* handle all the weird cases */
3971         switch (SvTYPE(sv)) {
3972         case SVt_PVLV:
3973             if (!isGV_with_GP(sv))
3974                 goto do_default;
3975             /* FALLTHROUGH */
3976         case SVt_PVGV:
3977             cv = GvCVu((const GV *)sv);
3978             if (UNLIKELY(!cv)) {
3979                 HV *stash;
3980                 cv = sv_2cv(sv, &stash, &gv, 0);
3981                 if (!cv) {
3982                     old_savestack_ix = PL_savestack_ix;
3983                     goto try_autoload;
3984                 }
3985             }
3986             break;
3987
3988         default:
3989           do_default:
3990             SvGETMAGIC(sv);
3991             if (SvROK(sv)) {
3992               do_ref:
3993                 if (UNLIKELY(SvAMAGIC(sv))) {
3994                     sv = amagic_deref_call(sv, to_cv_amg);
3995                     /* Don't SPAGAIN here.  */
3996                 }
3997             }
3998             else {
3999                 const char *sym;
4000                 STRLEN len;
4001                 if (UNLIKELY(!SvOK(sv)))
4002                     DIE(aTHX_ PL_no_usym, "a subroutine");
4003
4004                 if (UNLIKELY(sv == &PL_sv_yes)) { /* unfound import, ignore */
4005                     if (PL_op->op_flags & OPf_STACKED) /* hasargs */
4006                         SP = PL_stack_base + POPMARK;
4007                     else
4008                         (void)POPMARK;
4009                     if (GIMME_V == G_SCALAR)
4010                         PUSHs(&PL_sv_undef);
4011                     RETURN;
4012                 }
4013
4014                 sym = SvPV_nomg_const(sv, len);
4015                 if (PL_op->op_private & HINT_STRICT_REFS)
4016                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
4017                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
4018                 break;
4019             }
4020             cv = MUTABLE_CV(SvRV(sv));
4021             if (LIKELY(SvTYPE(cv) == SVt_PVCV))
4022                 break;
4023             /* FALLTHROUGH */
4024         case SVt_PVHV:
4025         case SVt_PVAV:
4026           do_die:
4027             DIE(aTHX_ "Not a CODE reference");
4028         }
4029     }
4030
4031     /* At this point we want to save PL_savestack_ix, either by doing a
4032      * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
4033      * CV we will be using (so we don't know whether its XS, so we can't
4034      * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
4035      * the save stack. So remember where we are currently on the save
4036      * stack, and later update the CX or scopestack entry accordingly. */
4037     old_savestack_ix = PL_savestack_ix;
4038
4039     /* these two fields are in a union. If they ever become separate,
4040      * we have to test for both of them being null below */
4041     assert(cv);
4042     assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
4043     while (UNLIKELY(!CvROOT(cv))) {
4044         GV* autogv;
4045         SV* sub_name;
4046
4047         /* anonymous or undef'd function leaves us no recourse */
4048         if (CvLEXICAL(cv) && CvHASGV(cv))
4049             DIE(aTHX_ "Undefined subroutine &%" SVf " called",
4050                        SVfARG(cv_name(cv, NULL, 0)));
4051         if (CvANON(cv) || !CvHASGV(cv)) {
4052             DIE(aTHX_ "Undefined subroutine called");
4053         }
4054
4055         /* autoloaded stub? */
4056         if (cv != GvCV(gv = CvGV(cv))) {
4057             cv = GvCV(gv);
4058         }
4059         /* should call AUTOLOAD now? */
4060         else {
4061           try_autoload:
4062             autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
4063                                      (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
4064                                     |(PL_op->op_flags & OPf_REF
4065                                        ? GV_AUTOLOAD_ISMETHOD
4066                                        : 0));
4067             cv = autogv ? GvCV(autogv) : NULL;
4068         }
4069         if (!cv) {
4070             sub_name = sv_newmortal();
4071             gv_efullname3(sub_name, gv, NULL);
4072             DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
4073         }
4074     }
4075
4076     /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
4077     if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
4078         DIE(aTHX_ "Closure prototype called");
4079
4080     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
4081             && !CvNODEBUG(cv)))
4082     {
4083          Perl_get_db_sub(aTHX_ &sv, cv);
4084          if (CvISXSUB(cv))
4085              PL_curcopdb = PL_curcop;
4086          if (CvLVALUE(cv)) {
4087              /* check for lsub that handles lvalue subroutines */
4088              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
4089              /* if lsub not found then fall back to DB::sub */
4090              if (!cv) cv = GvCV(PL_DBsub);
4091          } else {
4092              cv = GvCV(PL_DBsub);
4093          }
4094
4095         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
4096             DIE(aTHX_ "No DB::sub routine defined");
4097     }
4098
4099     if (!(CvISXSUB(cv))) {
4100         /* This path taken at least 75% of the time   */
4101         dMARK;
4102         PADLIST *padlist;
4103         I32 depth;
4104         bool hasargs;
4105         U8 gimme;
4106
4107         /* keep PADTMP args alive throughout the call (we need to do this
4108          * because @_ isn't refcounted). Note that we create the mortals
4109          * in the caller's tmps frame, so they won't be freed until after
4110          * we return from the sub.
4111          */
4112         {
4113             SV **svp = MARK;
4114             while (svp < SP) {
4115                 SV *sv = *++svp;
4116                 if (!sv)
4117                     continue;
4118                 if (SvPADTMP(sv))
4119                     *svp = sv = sv_mortalcopy(sv);
4120                 SvTEMP_off(sv);
4121             }
4122         }
4123
4124         gimme = GIMME_V;
4125         cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
4126         hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
4127         cx_pushsub(cx, cv, PL_op->op_next, hasargs);
4128
4129         padlist = CvPADLIST(cv);
4130         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
4131             pad_push(padlist, depth);
4132         PAD_SET_CUR_NOSAVE(padlist, depth);
4133         if (LIKELY(hasargs)) {
4134             AV *const av = MUTABLE_AV(PAD_SVl(0));
4135             SSize_t items;
4136             AV **defavp;
4137
4138             defavp = &GvAV(PL_defgv);
4139             cx->blk_sub.savearray = *defavp;
4140             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
4141
4142             /* it's the responsibility of whoever leaves a sub to ensure
4143              * that a clean, empty AV is left in pad[0]. This is normally
4144              * done by cx_popsub() */
4145             assert(!AvREAL(av) && AvFILLp(av) == -1);
4146
4147             items = SP - MARK;
4148             if (UNLIKELY(items - 1 > AvMAX(av))) {
4149                 SV **ary = AvALLOC(av);
4150                 Renew(ary, items, SV*);
4151                 AvMAX(av) = items - 1;
4152                 AvALLOC(av) = ary;
4153                 AvARRAY(av) = ary;
4154             }
4155
4156             Copy(MARK+1,AvARRAY(av),items,SV*);
4157             AvFILLp(av) = items - 1;
4158         }
4159         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
4160             !CvLVALUE(cv)))
4161             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
4162                 SVfARG(cv_name(cv, NULL, 0)));
4163         /* warning must come *after* we fully set up the context
4164          * stuff so that __WARN__ handlers can safely dounwind()
4165          * if they want to
4166          */
4167         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
4168                 && ckWARN(WARN_RECURSION)
4169                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4170             sub_crush_depth(cv);
4171         RETURNOP(CvSTART(cv));
4172     }
4173     else {
4174         SSize_t markix = TOPMARK;
4175         bool is_scalar;
4176
4177         ENTER;
4178         /* pretend we did the ENTER earlier */
4179         PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
4180
4181         SAVETMPS;
4182         PUTBACK;
4183
4184         if (UNLIKELY(((PL_op->op_private
4185                & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
4186              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
4187             !CvLVALUE(cv)))
4188             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
4189                 SVfARG(cv_name(cv, NULL, 0)));
4190
4191         if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
4192             /* Need to copy @_ to stack. Alternative may be to
4193              * switch stack to @_, and copy return values
4194              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
4195             AV * const av = GvAV(PL_defgv);
4196             const SSize_t items = AvFILL(av) + 1;
4197
4198             if (items) {
4199                 SSize_t i = 0;
4200                 const bool m = cBOOL(SvRMAGICAL(av));
4201                 /* Mark is at the end of the stack. */
4202                 EXTEND(SP, items);
4203                 for (; i < items; ++i)
4204                 {
4205                     SV *sv;
4206                     if (m) {
4207                         SV ** const svp = av_fetch(av, i, 0);
4208                         sv = svp ? *svp : NULL;
4209                     }
4210                     else sv = AvARRAY(av)[i];
4211                     if (sv) SP[i+1] = sv;
4212                     else {
4213                         SP[i+1] = newSVavdefelem(av, i, 1);
4214                     }
4215                 }
4216                 SP += items;
4217                 PUTBACK ;
4218             }
4219         }
4220         else {
4221             SV **mark = PL_stack_base + markix;
4222             SSize_t items = SP - mark;
4223             while (items--) {
4224                 mark++;
4225                 if (*mark && SvPADTMP(*mark)) {
4226                     *mark = sv_mortalcopy(*mark);
4227                 }
4228             }
4229         }
4230         /* We assume first XSUB in &DB::sub is the called one. */
4231         if (UNLIKELY(PL_curcopdb)) {
4232             SAVEVPTR(PL_curcop);
4233             PL_curcop = PL_curcopdb;
4234             PL_curcopdb = NULL;
4235         }
4236         /* Do we need to open block here? XXXX */
4237
4238         /* calculate gimme here as PL_op might get changed and then not
4239          * restored until the LEAVE further down */
4240         is_scalar = (GIMME_V == G_SCALAR);
4241
4242         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
4243         assert(CvXSUB(cv));
4244         CvXSUB(cv)(aTHX_ cv);
4245
4246         /* Enforce some sanity in scalar context. */
4247         if (is_scalar) {
4248             SV **svp = PL_stack_base + markix + 1;
4249             if (svp != PL_stack_sp) {
4250                 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
4251                 PL_stack_sp = svp;
4252             }
4253         }
4254         LEAVE;
4255         return NORMAL;
4256     }
4257 }
4258
4259 void
4260 Perl_sub_crush_depth(pTHX_ CV *cv)
4261 {
4262     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
4263
4264     if (CvANON(cv))
4265         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
4266     else {
4267         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
4268                     SVfARG(cv_name(cv,NULL,0)));
4269     }
4270 }
4271
4272
4273
4274 /* like croak, but report in context of caller */
4275
4276 void
4277 Perl_croak_caller(const char *pat, ...)
4278 {
4279     dTHX;
4280     va_list args;
4281     const PERL_CONTEXT *cx = caller_cx(0, NULL);
4282
4283     /* make error appear at call site */
4284     assert(cx);
4285     PL_curcop = cx->blk_oldcop;
4286
4287     va_start(args, pat);
4288     vcroak(pat, &args);
4289     NOT_REACHED; /* NOTREACHED */
4290     va_end(args);
4291 }
4292
4293
4294 PP(pp_aelem)
4295 {
4296     dSP;
4297     SV** svp;
4298     SV* const elemsv = POPs;
4299     IV elem = SvIV(elemsv);
4300     AV *const av = MUTABLE_AV(POPs);
4301     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4302     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4303     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4304     bool preeminent = TRUE;
4305     SV *sv;
4306
4307     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
4308         Perl_warner(aTHX_ packWARN(WARN_MISC),
4309                     "Use of reference \"%" SVf "\" as array index",
4310                     SVfARG(elemsv));
4311     if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
4312         RETPUSHUNDEF;
4313
4314     if (UNLIKELY(localizing)) {
4315         MAGIC *mg;
4316         HV *stash;
4317
4318         /* If we can determine whether the element exist,
4319          * Try to preserve the existenceness of a tied array
4320          * element by using EXISTS and DELETE if possible.
4321          * Fallback to FETCH and STORE otherwise. */
4322         if (SvCANEXISTDELETE(av))
4323             preeminent = av_exists(av, elem);
4324     }
4325
4326     svp = av_fetch(av, elem, lval && !defer);
4327     if (lval) {
4328 #ifdef PERL_MALLOC_WRAP
4329          if (SvUOK(elemsv)) {
4330               const UV uv = SvUV(elemsv);
4331               elem = uv > IV_MAX ? IV_MAX : uv;
4332          }
4333          else if (SvNOK(elemsv))
4334               elem = (IV)SvNV(elemsv);
4335          if (elem > 0) {
4336               static const char oom_array_extend[] =
4337                 "Out of memory during array extend"; /* Duplicated in av.c */
4338               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
4339          }
4340 #endif