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_no);
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     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1902     SV * const rv = sv_newmortal();
1903     CV **cvp;
1904     CV *cv;
1905
1906     SvUPGRADE(rv, SVt_IV);
1907     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1908        loathe to use it here, but it seems to be the right fix. Or close.
1909        The key part appears to be that it's essential for pp_qr to return a new
1910        object (SV), which implies that there needs to be an effective way to
1911        generate a new SV from the existing SV that is pre-compiled in the
1912        optree.  */
1913     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1914     SvROK_on(rv);
1915
1916     cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1917     if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1918         *cvp = cv_clone(cv);
1919         SvREFCNT_dec_NN(cv);
1920     }
1921
1922     if (pkg) {
1923         HV *const stash = gv_stashsv(pkg, GV_ADD);
1924         SvREFCNT_dec_NN(pkg);
1925         (void)sv_bless(rv, stash);
1926     }
1927
1928     if (UNLIKELY(RX_ISTAINTED(rx))) {
1929         SvTAINTED_on(rv);
1930         SvTAINTED_on(SvRV(rv));
1931     }
1932     XPUSHs(rv);
1933     RETURN;
1934 }
1935
1936 PP(pp_match)
1937 {
1938     dSP; dTARG;
1939     PMOP *pm = cPMOP;
1940     PMOP *dynpm = pm;
1941     const char *s;
1942     const char *strend;
1943     SSize_t curpos = 0; /* initial pos() or current $+[0] */
1944     I32 global;
1945     U8 r_flags = 0;
1946     const char *truebase;                       /* Start of string  */
1947     REGEXP *rx = PM_GETRE(pm);
1948     bool rxtainted;
1949     const U8 gimme = GIMME_V;
1950     STRLEN len;
1951     const I32 oldsave = PL_savestack_ix;
1952     I32 had_zerolen = 0;
1953     MAGIC *mg = NULL;
1954
1955     if (PL_op->op_flags & OPf_STACKED)
1956         TARG = POPs;
1957     else {
1958         if (ARGTARG)
1959             GETTARGET;
1960         else {
1961             TARG = DEFSV;
1962         }
1963         EXTEND(SP,1);
1964     }
1965
1966     PUTBACK;                            /* EVAL blocks need stack_sp. */
1967     /* Skip get-magic if this is a qr// clone, because regcomp has
1968        already done it. */
1969     truebase = ReANY(rx)->mother_re
1970          ? SvPV_nomg_const(TARG, len)
1971          : SvPV_const(TARG, len);
1972     if (!truebase)
1973         DIE(aTHX_ "panic: pp_match");
1974     strend = truebase + len;
1975     rxtainted = (RX_ISTAINTED(rx) ||
1976                  (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1977     TAINT_NOT;
1978
1979     /* We need to know this in case we fail out early - pos() must be reset */
1980     global = dynpm->op_pmflags & PMf_GLOBAL;
1981
1982     /* PMdf_USED is set after a ?? matches once */
1983     if (
1984 #ifdef USE_ITHREADS
1985         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1986 #else
1987         pm->op_pmflags & PMf_USED
1988 #endif
1989     ) {
1990         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1991         goto nope;
1992     }
1993
1994     /* handle the empty pattern */
1995     if (!RX_PRELEN(rx) && PL_curpm && !ReANY(rx)->mother_re) {
1996         if (PL_curpm == PL_reg_curpm) {
1997             if (PL_curpm_under) {
1998                 if (PL_curpm_under == PL_reg_curpm) {
1999                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
2000                 } else {
2001                     pm = PL_curpm_under;
2002                 }
2003             }
2004         } else {
2005             pm = PL_curpm;
2006         }
2007         rx = PM_GETRE(pm);
2008     }
2009
2010     if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
2011         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
2012                                               UVuf " < %" IVdf ")\n",
2013                                               (UV)len, (IV)RX_MINLEN(rx)));
2014         goto nope;
2015     }
2016
2017     /* get pos() if //g */
2018     if (global) {
2019         mg = mg_find_mglob(TARG);
2020         if (mg && mg->mg_len >= 0) {
2021             curpos = MgBYTEPOS(mg, TARG, truebase, len);
2022             /* last time pos() was set, it was zero-length match */
2023             if (mg->mg_flags & MGf_MINMATCH)
2024                 had_zerolen = 1;
2025         }
2026     }
2027
2028 #ifdef PERL_SAWAMPERSAND
2029     if (       RX_NPARENS(rx)
2030             || PL_sawampersand
2031             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2032             || (dynpm->op_pmflags & PMf_KEEPCOPY)
2033     )
2034 #endif
2035     {
2036         r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
2037         /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
2038          * only on the first iteration. Therefore we need to copy $' as well
2039          * as $&, to make the rest of the string available for captures in
2040          * subsequent iterations */
2041         if (! (global && gimme == G_ARRAY))
2042             r_flags |= REXEC_COPY_SKIP_POST;
2043     };
2044 #ifdef PERL_SAWAMPERSAND
2045     if (dynpm->op_pmflags & PMf_KEEPCOPY)
2046         /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
2047         r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
2048 #endif
2049
2050     s = truebase;
2051
2052   play_it_again:
2053     if (global)
2054         s = truebase + curpos;
2055
2056     if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
2057                      had_zerolen, TARG, NULL, r_flags))
2058         goto nope;
2059
2060     PL_curpm = pm;
2061     if (dynpm->op_pmflags & PMf_ONCE)
2062 #ifdef USE_ITHREADS
2063         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
2064 #else
2065         dynpm->op_pmflags |= PMf_USED;
2066 #endif
2067
2068     if (rxtainted)
2069         RX_MATCH_TAINTED_on(rx);
2070     TAINT_IF(RX_MATCH_TAINTED(rx));
2071
2072     /* update pos */
2073
2074     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
2075         if (!mg)
2076             mg = sv_magicext_mglob(TARG);
2077         MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
2078         if (RX_ZERO_LEN(rx))
2079             mg->mg_flags |= MGf_MINMATCH;
2080         else
2081             mg->mg_flags &= ~MGf_MINMATCH;
2082     }
2083
2084     if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
2085         LEAVE_SCOPE(oldsave);
2086         RETPUSHYES;
2087     }
2088
2089     /* push captures on stack */
2090
2091     {
2092         const I32 nparens = RX_NPARENS(rx);
2093         I32 i = (global && !nparens) ? 1 : 0;
2094
2095         SPAGAIN;                        /* EVAL blocks could move the stack. */
2096         EXTEND(SP, nparens + i);
2097         EXTEND_MORTAL(nparens + i);
2098         for (i = !i; i <= nparens; i++) {
2099             PUSHs(sv_newmortal());
2100             if (LIKELY((RX_OFFS(rx)[i].start != -1)
2101                      && RX_OFFS(rx)[i].end   != -1 ))
2102             {
2103                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
2104                 const char * const s = RX_OFFS(rx)[i].start + truebase;
2105                 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
2106                         || len < 0 || len > strend - s))
2107                     DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
2108                         "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
2109                         (long) i, (long) RX_OFFS(rx)[i].start,
2110                         (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
2111                 sv_setpvn(*SP, s, len);
2112                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
2113                     SvUTF8_on(*SP);
2114             }
2115         }
2116         if (global) {
2117             curpos = (UV)RX_OFFS(rx)[0].end;
2118             had_zerolen = RX_ZERO_LEN(rx);
2119             PUTBACK;                    /* EVAL blocks may use stack */
2120             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2121             goto play_it_again;
2122         }
2123         LEAVE_SCOPE(oldsave);
2124         RETURN;
2125     }
2126     NOT_REACHED; /* NOTREACHED */
2127
2128   nope:
2129     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
2130         if (!mg)
2131             mg = mg_find_mglob(TARG);
2132         if (mg)
2133             mg->mg_len = -1;
2134     }
2135     LEAVE_SCOPE(oldsave);
2136     if (gimme == G_ARRAY)
2137         RETURN;
2138     RETPUSHNO;
2139 }
2140
2141 OP *
2142 Perl_do_readline(pTHX)
2143 {
2144     dSP; dTARGETSTACKED;
2145     SV *sv;
2146     STRLEN tmplen = 0;
2147     STRLEN offset;
2148     PerlIO *fp;
2149     IO * const io = GvIO(PL_last_in_gv);
2150     const I32 type = PL_op->op_type;
2151     const U8 gimme = GIMME_V;
2152
2153     if (io) {
2154         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2155         if (mg) {
2156             Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
2157             if (gimme == G_SCALAR) {
2158                 SPAGAIN;
2159                 SvSetSV_nosteal(TARG, TOPs);
2160                 SETTARG;
2161             }
2162             return NORMAL;
2163         }
2164     }
2165     fp = NULL;
2166     if (io) {
2167         fp = IoIFP(io);
2168         if (!fp) {
2169             if (IoFLAGS(io) & IOf_ARGV) {
2170                 if (IoFLAGS(io) & IOf_START) {
2171                     IoLINES(io) = 0;
2172                     if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
2173                         IoFLAGS(io) &= ~IOf_START;
2174                         do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
2175                         SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
2176                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
2177                         SvSETMAGIC(GvSV(PL_last_in_gv));
2178                         fp = IoIFP(io);
2179                         goto have_fp;
2180                     }
2181                 }
2182                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2183                 if (!fp) { /* Note: fp != IoIFP(io) */
2184                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
2185                 }
2186             }
2187             else if (type == OP_GLOB)
2188                 fp = Perl_start_glob(aTHX_ POPs, io);
2189         }
2190         else if (type == OP_GLOB)
2191             SP--;
2192         else if (IoTYPE(io) == IoTYPE_WRONLY) {
2193             report_wrongway_fh(PL_last_in_gv, '>');
2194         }
2195     }
2196     if (!fp) {
2197         if ((!io || !(IoFLAGS(io) & IOf_START))
2198             && ckWARN(WARN_CLOSED)
2199             && type != OP_GLOB)
2200         {
2201             report_evil_fh(PL_last_in_gv);
2202         }
2203         if (gimme == G_SCALAR) {
2204             /* undef TARG, and push that undefined value */
2205             if (type != OP_RCATLINE) {
2206                 sv_setsv(TARG,NULL);
2207             }
2208             PUSHTARG;
2209         }
2210         RETURN;
2211     }
2212   have_fp:
2213     if (gimme == G_SCALAR) {
2214         sv = TARG;
2215         if (type == OP_RCATLINE && SvGMAGICAL(sv))
2216             mg_get(sv);
2217         if (SvROK(sv)) {
2218             if (type == OP_RCATLINE)
2219                 SvPV_force_nomg_nolen(sv);
2220             else
2221                 sv_unref(sv);
2222         }
2223         else if (isGV_with_GP(sv)) {
2224             SvPV_force_nomg_nolen(sv);
2225         }
2226         SvUPGRADE(sv, SVt_PV);
2227         tmplen = SvLEN(sv);     /* remember if already alloced */
2228         if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
2229             /* try short-buffering it. Please update t/op/readline.t
2230              * if you change the growth length.
2231              */
2232             Sv_Grow(sv, 80);
2233         }
2234         offset = 0;
2235         if (type == OP_RCATLINE && SvOK(sv)) {
2236             if (!SvPOK(sv)) {
2237                 SvPV_force_nomg_nolen(sv);
2238             }
2239             offset = SvCUR(sv);
2240         }
2241     }
2242     else {
2243         sv = sv_2mortal(newSV(80));
2244         offset = 0;
2245     }
2246
2247     /* This should not be marked tainted if the fp is marked clean */
2248 #define MAYBE_TAINT_LINE(io, sv) \
2249     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
2250         TAINT;                          \
2251         SvTAINTED_on(sv);               \
2252     }
2253
2254 /* delay EOF state for a snarfed empty file */
2255 #define SNARF_EOF(gimme,rs,io,sv) \
2256     (gimme != G_SCALAR || SvCUR(sv)                                     \
2257      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
2258
2259     for (;;) {
2260         PUTBACK;
2261         if (!sv_gets(sv, fp, offset)
2262             && (type == OP_GLOB
2263                 || SNARF_EOF(gimme, PL_rs, io, sv)
2264                 || PerlIO_error(fp)))
2265         {
2266             PerlIO_clearerr(fp);
2267             if (IoFLAGS(io) & IOf_ARGV) {
2268                 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2269                 if (fp)
2270                     continue;
2271                 (void)do_close(PL_last_in_gv, FALSE);
2272             }
2273             else if (type == OP_GLOB) {
2274                 if (!do_close(PL_last_in_gv, FALSE)) {
2275                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
2276                                    "glob failed (child exited with status %d%s)",
2277                                    (int)(STATUS_CURRENT >> 8),
2278                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
2279                 }
2280             }
2281             if (gimme == G_SCALAR) {
2282                 if (type != OP_RCATLINE) {
2283                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
2284                     SvOK_off(TARG);
2285                 }
2286                 SPAGAIN;
2287                 PUSHTARG;
2288             }
2289             MAYBE_TAINT_LINE(io, sv);
2290             RETURN;
2291         }
2292         MAYBE_TAINT_LINE(io, sv);
2293         IoLINES(io)++;
2294         IoFLAGS(io) |= IOf_NOLINE;
2295         SvSETMAGIC(sv);
2296         SPAGAIN;
2297         XPUSHs(sv);
2298         if (type == OP_GLOB) {
2299             const char *t1;
2300             Stat_t statbuf;
2301
2302             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
2303                 char * const tmps = SvEND(sv) - 1;
2304                 if (*tmps == *SvPVX_const(PL_rs)) {
2305                     *tmps = '\0';
2306                     SvCUR_set(sv, SvCUR(sv) - 1);
2307                 }
2308             }
2309             for (t1 = SvPVX_const(sv); *t1; t1++)
2310 #ifdef __VMS
2311                 if (strchr("*%?", *t1))
2312 #else
2313                 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
2314 #endif
2315                         break;
2316             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
2317                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
2318                 continue;
2319             }
2320         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
2321              if (ckWARN(WARN_UTF8)) {
2322                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
2323                 const STRLEN len = SvCUR(sv) - offset;
2324                 const U8 *f;
2325
2326                 if (!is_utf8_string_loc(s, len, &f))
2327                     /* Emulate :encoding(utf8) warning in the same case. */
2328                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
2329                                 "utf8 \"\\x%02X\" does not map to Unicode",
2330                                 f < (U8*)SvEND(sv) ? *f : 0);
2331              }
2332         }
2333         if (gimme == G_ARRAY) {
2334             if (SvLEN(sv) - SvCUR(sv) > 20) {
2335                 SvPV_shrink_to_cur(sv);
2336             }
2337             sv = sv_2mortal(newSV(80));
2338             continue;
2339         }
2340         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2341             /* try to reclaim a bit of scalar space (only on 1st alloc) */
2342             const STRLEN new_len
2343                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2344             SvPV_renew(sv, new_len);
2345         }
2346         RETURN;
2347     }
2348 }
2349
2350 PP(pp_helem)
2351 {
2352     dSP;
2353     HE* he;
2354     SV **svp;
2355     SV * const keysv = POPs;
2356     HV * const hv = MUTABLE_HV(POPs);
2357     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2358     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2359     SV *sv;
2360     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2361     bool preeminent = TRUE;
2362
2363     if (SvTYPE(hv) != SVt_PVHV)
2364         RETPUSHUNDEF;
2365
2366     if (localizing) {
2367         MAGIC *mg;
2368         HV *stash;
2369
2370         /* If we can determine whether the element exist,
2371          * Try to preserve the existenceness of a tied hash
2372          * element by using EXISTS and DELETE if possible.
2373          * Fallback to FETCH and STORE otherwise. */
2374         if (SvCANEXISTDELETE(hv))
2375             preeminent = hv_exists_ent(hv, keysv, 0);
2376     }
2377
2378     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2379     svp = he ? &HeVAL(he) : NULL;
2380     if (lval) {
2381         if (!svp || !*svp || *svp == &PL_sv_undef) {
2382             SV* lv;
2383             SV* key2;
2384             if (!defer) {
2385                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2386             }
2387             lv = sv_newmortal();
2388             sv_upgrade(lv, SVt_PVLV);
2389             LvTYPE(lv) = 'y';
2390             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2391             SvREFCNT_dec_NN(key2);      /* sv_magic() increments refcount */
2392             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2393             LvTARGLEN(lv) = 1;
2394             PUSHs(lv);
2395             RETURN;
2396         }
2397         if (localizing) {
2398             if (HvNAME_get(hv) && isGV(*svp))
2399                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2400             else if (preeminent)
2401                 save_helem_flags(hv, keysv, svp,
2402                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2403             else
2404                 SAVEHDELETE(hv, keysv);
2405         }
2406         else if (PL_op->op_private & OPpDEREF) {
2407             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2408             RETURN;
2409         }
2410     }
2411     sv = (svp && *svp ? *svp : &PL_sv_undef);
2412     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2413      * was to make C<local $tied{foo} = $tied{foo}> possible.
2414      * However, it seems no longer to be needed for that purpose, and
2415      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2416      * would loop endlessly since the pos magic is getting set on the
2417      * mortal copy and lost. However, the copy has the effect of
2418      * triggering the get magic, and losing it altogether made things like
2419      * c<$tied{foo};> in void context no longer do get magic, which some
2420      * code relied on. Also, delayed triggering of magic on @+ and friends
2421      * meant the original regex may be out of scope by now. So as a
2422      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2423      * being called too many times). */
2424     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2425         mg_get(sv);
2426     PUSHs(sv);
2427     RETURN;
2428 }
2429
2430
2431 /* a stripped-down version of Perl_softref2xv() for use by
2432  * pp_multideref(), which doesn't use PL_op->op_flags */
2433
2434 STATIC GV *
2435 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2436                 const svtype type)
2437 {
2438     if (PL_op->op_private & HINT_STRICT_REFS) {
2439         if (SvOK(sv))
2440             Perl_die(aTHX_ PL_no_symref_sv, sv,
2441                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2442         else
2443             Perl_die(aTHX_ PL_no_usym, what);
2444     }
2445     if (!SvOK(sv))
2446         Perl_die(aTHX_ PL_no_usym, what);
2447     return gv_fetchsv_nomg(sv, GV_ADD, type);
2448 }
2449
2450
2451 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2452  * $h->{foo}  or  $a[0]{$key}[$i]  or  f()->[1]
2453  *
2454  * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2455  * Each of these either contains a set of actions, or an argument, such as
2456  * an IV to use as an array index, or a lexical var to retrieve.
2457  * Several actions re stored per UV; we keep shifting new actions off the
2458  * one UV, and only reload when it becomes zero.
2459  */
2460
2461 PP(pp_multideref)
2462 {
2463     SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2464     UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2465     UV actions = items->uv;
2466
2467     assert(actions);
2468     /* this tells find_uninit_var() where we're up to */
2469     PL_multideref_pc = items;
2470
2471     while (1) {
2472         /* there are three main classes of action; the first retrieve
2473          * the initial AV or HV from a variable or the stack; the second
2474          * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2475          * the third an unrolled (/DREFHV, rv2hv, helem).
2476          */
2477         switch (actions & MDEREF_ACTION_MASK) {
2478
2479         case MDEREF_reload:
2480             actions = (++items)->uv;
2481             continue;
2482
2483         case MDEREF_AV_padav_aelem:                 /* $lex[...] */
2484             sv = PAD_SVl((++items)->pad_offset);
2485             goto do_AV_aelem;
2486
2487         case MDEREF_AV_gvav_aelem:                  /* $pkg[...] */
2488             sv = UNOP_AUX_item_sv(++items);
2489             assert(isGV_with_GP(sv));
2490             sv = (SV*)GvAVn((GV*)sv);
2491             goto do_AV_aelem;
2492
2493         case MDEREF_AV_pop_rv2av_aelem:             /* expr->[...] */
2494             {
2495                 dSP;
2496                 sv = POPs;
2497                 PUTBACK;
2498                 goto do_AV_rv2av_aelem;
2499             }
2500
2501         case MDEREF_AV_gvsv_vivify_rv2av_aelem:     /* $pkg->[...] */
2502             sv = UNOP_AUX_item_sv(++items);
2503             assert(isGV_with_GP(sv));
2504             sv = GvSVn((GV*)sv);
2505             goto do_AV_vivify_rv2av_aelem;
2506
2507         case MDEREF_AV_padsv_vivify_rv2av_aelem:     /* $lex->[...] */
2508             sv = PAD_SVl((++items)->pad_offset);
2509             /* FALLTHROUGH */
2510
2511         do_AV_vivify_rv2av_aelem:
2512         case MDEREF_AV_vivify_rv2av_aelem:           /* vivify, ->[...] */
2513             /* this is the OPpDEREF action normally found at the end of
2514              * ops like aelem, helem, rv2sv */
2515             sv = vivify_ref(sv, OPpDEREF_AV);
2516             /* FALLTHROUGH */
2517
2518         do_AV_rv2av_aelem:
2519             /* this is basically a copy of pp_rv2av when it just has the
2520              * sKR/1 flags */
2521             SvGETMAGIC(sv);
2522             if (LIKELY(SvROK(sv))) {
2523                 if (UNLIKELY(SvAMAGIC(sv))) {
2524                     sv = amagic_deref_call(sv, to_av_amg);
2525                 }
2526                 sv = SvRV(sv);
2527                 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2528                     DIE(aTHX_ "Not an ARRAY reference");
2529             }
2530             else if (SvTYPE(sv) != SVt_PVAV) {
2531                 if (!isGV_with_GP(sv))
2532                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2533                 sv = MUTABLE_SV(GvAVn((GV*)sv));
2534             }
2535             /* FALLTHROUGH */
2536
2537         do_AV_aelem:
2538             {
2539                 /* retrieve the key; this may be either a lexical or package
2540                  * var (whose index/ptr is stored as an item) or a signed
2541                  * integer constant stored as an item.
2542                  */
2543                 SV *elemsv;
2544                 IV elem = 0; /* to shut up stupid compiler warnings */
2545
2546
2547                 assert(SvTYPE(sv) == SVt_PVAV);
2548
2549                 switch (actions & MDEREF_INDEX_MASK) {
2550                 case MDEREF_INDEX_none:
2551                     goto finish;
2552                 case MDEREF_INDEX_const:
2553                     elem  = (++items)->iv;
2554                     break;
2555                 case MDEREF_INDEX_padsv:
2556                     elemsv = PAD_SVl((++items)->pad_offset);
2557                     goto check_elem;
2558                 case MDEREF_INDEX_gvsv:
2559                     elemsv = UNOP_AUX_item_sv(++items);
2560                     assert(isGV_with_GP(elemsv));
2561                     elemsv = GvSVn((GV*)elemsv);
2562                 check_elem:
2563                     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2564                                             && ckWARN(WARN_MISC)))
2565                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2566                                 "Use of reference \"%" SVf "\" as array index",
2567                                 SVfARG(elemsv));
2568                     /* the only time that S_find_uninit_var() needs this
2569                      * is to determine which index value triggered the
2570                      * undef warning. So just update it here. Note that
2571                      * since we don't save and restore this var (e.g. for
2572                      * tie or overload execution), its value will be
2573                      * meaningless apart from just here */
2574                     PL_multideref_pc = items;
2575                     elem = SvIV(elemsv);
2576                     break;
2577                 }
2578
2579
2580                 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2581
2582                 if (!(actions & MDEREF_FLAG_last)) {
2583                     SV** svp = av_fetch((AV*)sv, elem, 1);
2584                     if (!svp || ! (sv=*svp))
2585                         DIE(aTHX_ PL_no_aelem, elem);
2586                     break;
2587                 }
2588
2589                 if (PL_op->op_private &
2590                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2591                 {
2592                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2593                         sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2594                     }
2595                     else {
2596                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2597                         sv = av_delete((AV*)sv, elem, discard);
2598                         if (discard)
2599                             return NORMAL;
2600                         if (!sv)
2601                             sv = &PL_sv_undef;
2602                     }
2603                 }
2604                 else {
2605                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2606                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2607                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2608                     bool preeminent = TRUE;
2609                     AV *const av = (AV*)sv;
2610                     SV** svp;
2611
2612                     if (UNLIKELY(localizing)) {
2613                         MAGIC *mg;
2614                         HV *stash;
2615
2616                         /* If we can determine whether the element exist,
2617                          * Try to preserve the existenceness of a tied array
2618                          * element by using EXISTS and DELETE if possible.
2619                          * Fallback to FETCH and STORE otherwise. */
2620                         if (SvCANEXISTDELETE(av))
2621                             preeminent = av_exists(av, elem);
2622                     }
2623
2624                     svp = av_fetch(av, elem, lval && !defer);
2625
2626                     if (lval) {
2627                         if (!svp || !(sv = *svp)) {
2628                             IV len;
2629                             if (!defer)
2630                                 DIE(aTHX_ PL_no_aelem, elem);
2631                             len = av_tindex(av);
2632                             sv = sv_2mortal(newSVavdefelem(av,
2633                             /* Resolve a negative index now, unless it points
2634                              * before the beginning of the array, in which
2635                              * case record it for error reporting in
2636                              * magic_setdefelem. */
2637                                 elem < 0 && len + elem >= 0
2638                                     ? len + elem : elem, 1));
2639                         }
2640                         else {
2641                             if (UNLIKELY(localizing)) {
2642                                 if (preeminent) {
2643                                     save_aelem(av, elem, svp);
2644                                     sv = *svp; /* may have changed */
2645                                 }
2646                                 else
2647                                     SAVEADELETE(av, elem);
2648                             }
2649                         }
2650                     }
2651                     else {
2652                         sv = (svp ? *svp : &PL_sv_undef);
2653                         /* see note in pp_helem() */
2654                         if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2655                             mg_get(sv);
2656                     }
2657                 }
2658
2659             }
2660           finish:
2661             {
2662                 dSP;
2663                 XPUSHs(sv);
2664                 RETURN;
2665             }
2666             /* NOTREACHED */
2667
2668
2669
2670
2671         case MDEREF_HV_padhv_helem:                 /* $lex{...} */
2672             sv = PAD_SVl((++items)->pad_offset);
2673             goto do_HV_helem;
2674
2675         case MDEREF_HV_gvhv_helem:                  /* $pkg{...} */
2676             sv = UNOP_AUX_item_sv(++items);
2677             assert(isGV_with_GP(sv));
2678             sv = (SV*)GvHVn((GV*)sv);
2679             goto do_HV_helem;
2680
2681         case MDEREF_HV_pop_rv2hv_helem:             /* expr->{...} */
2682             {
2683                 dSP;
2684                 sv = POPs;
2685                 PUTBACK;
2686                 goto do_HV_rv2hv_helem;
2687             }
2688
2689         case MDEREF_HV_gvsv_vivify_rv2hv_helem:     /* $pkg->{...} */
2690             sv = UNOP_AUX_item_sv(++items);
2691             assert(isGV_with_GP(sv));
2692             sv = GvSVn((GV*)sv);
2693             goto do_HV_vivify_rv2hv_helem;
2694
2695         case MDEREF_HV_padsv_vivify_rv2hv_helem:    /* $lex->{...} */
2696             sv = PAD_SVl((++items)->pad_offset);
2697             /* FALLTHROUGH */
2698
2699         do_HV_vivify_rv2hv_helem:
2700         case MDEREF_HV_vivify_rv2hv_helem:           /* vivify, ->{...} */
2701             /* this is the OPpDEREF action normally found at the end of
2702              * ops like aelem, helem, rv2sv */
2703             sv = vivify_ref(sv, OPpDEREF_HV);
2704             /* FALLTHROUGH */
2705
2706         do_HV_rv2hv_helem:
2707             /* this is basically a copy of pp_rv2hv when it just has the
2708              * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2709
2710             SvGETMAGIC(sv);
2711             if (LIKELY(SvROK(sv))) {
2712                 if (UNLIKELY(SvAMAGIC(sv))) {
2713                     sv = amagic_deref_call(sv, to_hv_amg);
2714                 }
2715                 sv = SvRV(sv);
2716                 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2717                     DIE(aTHX_ "Not a HASH reference");
2718             }
2719             else if (SvTYPE(sv) != SVt_PVHV) {
2720                 if (!isGV_with_GP(sv))
2721                     sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2722                 sv = MUTABLE_SV(GvHVn((GV*)sv));
2723             }
2724             /* FALLTHROUGH */
2725
2726         do_HV_helem:
2727             {
2728                 /* retrieve the key; this may be either a lexical / package
2729                  * var or a string constant, whose index/ptr is stored as an
2730                  * item
2731                  */
2732                 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2733
2734                 assert(SvTYPE(sv) == SVt_PVHV);
2735
2736                 switch (actions & MDEREF_INDEX_MASK) {
2737                 case MDEREF_INDEX_none:
2738                     goto finish;
2739
2740                 case MDEREF_INDEX_const:
2741                     keysv = UNOP_AUX_item_sv(++items);
2742                     break;
2743
2744                 case MDEREF_INDEX_padsv:
2745                     keysv = PAD_SVl((++items)->pad_offset);
2746                     break;
2747
2748                 case MDEREF_INDEX_gvsv:
2749                     keysv = UNOP_AUX_item_sv(++items);
2750                     keysv = GvSVn((GV*)keysv);
2751                     break;
2752                 }
2753
2754                 /* see comment above about setting this var */
2755                 PL_multideref_pc = items;
2756
2757
2758                 /* ensure that candidate CONSTs have been HEKified */
2759                 assert(   ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2760                        || SvTYPE(keysv) >= SVt_PVMG
2761                        || !SvOK(keysv)
2762                        || SvROK(keysv)
2763                        || SvIsCOW_shared_hash(keysv));
2764
2765                 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2766
2767                 if (!(actions & MDEREF_FLAG_last)) {
2768                     HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2769                     if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2770                         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2771                     break;
2772                 }
2773
2774                 if (PL_op->op_private &
2775                     (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2776                 {
2777                     if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2778                         sv = hv_exists_ent((HV*)sv, keysv, 0)
2779                                                 ? &PL_sv_yes : &PL_sv_no;
2780                     }
2781                     else {
2782                         I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2783                         sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2784                         if (discard)
2785                             return NORMAL;
2786                         if (!sv)
2787                             sv = &PL_sv_undef;
2788                     }
2789                 }
2790                 else {
2791                     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2792                     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2793                     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2794                     bool preeminent = TRUE;
2795                     SV **svp;
2796                     HV * const hv = (HV*)sv;
2797                     HE* he;
2798
2799                     if (UNLIKELY(localizing)) {
2800                         MAGIC *mg;
2801                         HV *stash;
2802
2803                         /* If we can determine whether the element exist,
2804                          * Try to preserve the existenceness of a tied hash
2805                          * element by using EXISTS and DELETE if possible.
2806                          * Fallback to FETCH and STORE otherwise. */
2807                         if (SvCANEXISTDELETE(hv))
2808                             preeminent = hv_exists_ent(hv, keysv, 0);
2809                     }
2810
2811                     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2812                     svp = he ? &HeVAL(he) : NULL;
2813
2814
2815                     if (lval) {
2816                         if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2817                             SV* lv;
2818                             SV* key2;
2819                             if (!defer)
2820                                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2821                             lv = sv_newmortal();
2822                             sv_upgrade(lv, SVt_PVLV);
2823                             LvTYPE(lv) = 'y';
2824                             sv_magic(lv, key2 = newSVsv(keysv),
2825                                                 PERL_MAGIC_defelem, NULL, 0);
2826                             /* sv_magic() increments refcount */
2827                             SvREFCNT_dec_NN(key2);
2828                             LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2829                             LvTARGLEN(lv) = 1;
2830                             sv = lv;
2831                         }
2832                         else {
2833                             if (localizing) {
2834                                 if (HvNAME_get(hv) && isGV(sv))
2835                                     save_gp(MUTABLE_GV(sv),
2836                                         !(PL_op->op_flags & OPf_SPECIAL));
2837                                 else if (preeminent) {
2838                                     save_helem_flags(hv, keysv, svp,
2839                                          (PL_op->op_flags & OPf_SPECIAL)
2840                                             ? 0 : SAVEf_SETMAGIC);
2841                                     sv = *svp; /* may have changed */
2842                                 }
2843                                 else
2844                                     SAVEHDELETE(hv, keysv);
2845                             }
2846                         }
2847                     }
2848                     else {
2849                         sv = (svp && *svp ? *svp : &PL_sv_undef);
2850                         /* see note in pp_helem() */
2851                         if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2852                             mg_get(sv);
2853                     }
2854                 }
2855                 goto finish;
2856             }
2857
2858         } /* switch */
2859
2860         actions >>= MDEREF_SHIFT;
2861     } /* while */
2862     /* NOTREACHED */
2863 }
2864
2865
2866 PP(pp_iter)
2867 {
2868     PERL_CONTEXT *cx;
2869     SV *oldsv;
2870     SV **itersvp;
2871     SV *retsv;
2872
2873     SV *sv;
2874     AV *av;
2875     IV ix;
2876     IV inc;
2877
2878     cx = CX_CUR();
2879     itersvp = CxITERVAR(cx);
2880     assert(itersvp);
2881
2882     switch (CxTYPE(cx)) {
2883
2884     case CXt_LOOP_LAZYSV: /* string increment */
2885     {
2886         SV* cur = cx->blk_loop.state_u.lazysv.cur;
2887         SV *end = cx->blk_loop.state_u.lazysv.end;
2888         /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2889            It has SvPVX of "" and SvCUR of 0, which is what we want.  */
2890         STRLEN maxlen = 0;
2891         const char *max = SvPV_const(end, maxlen);
2892         if (DO_UTF8(end) && IN_UNI_8_BIT)
2893             maxlen = sv_len_utf8_nomg(end);
2894         if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2895             goto retno;
2896
2897         oldsv = *itersvp;
2898         /* NB: on the first iteration, oldsv will have a ref count of at
2899          * least 2 (one extra from blk_loop.itersave), so the GV or pad
2900          * slot will get localised; on subsequent iterations the RC==1
2901          * optimisation may kick in and the SV will be reused. */
2902          if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2903             /* safe to reuse old SV */
2904             sv_setsv(oldsv, cur);
2905         }
2906         else
2907         {
2908             /* we need a fresh SV every time so that loop body sees a
2909              * completely new SV for closures/references to work as
2910              * they used to */
2911             *itersvp = newSVsv(cur);
2912             SvREFCNT_dec(oldsv);
2913         }
2914         if (strEQ(SvPVX_const(cur), max))
2915             sv_setiv(cur, 0); /* terminate next time */
2916         else
2917             sv_inc(cur);
2918         break;
2919     }
2920
2921     case CXt_LOOP_LAZYIV: /* integer increment */
2922     {
2923         IV cur = cx->blk_loop.state_u.lazyiv.cur;
2924         if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2925             goto retno;
2926
2927         oldsv = *itersvp;
2928         /* see NB comment above */
2929         if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2930             /* safe to reuse old SV */
2931
2932             if (    (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
2933                  == SVt_IV)
2934             {
2935                 /* Cheap SvIOK_only().
2936                  * Assert that flags which SvIOK_only() would test or
2937                  * clear can't be set, because we're SVt_IV */
2938                 assert(!(SvFLAGS(oldsv) &
2939                     (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
2940                 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
2941                 /* SvIV_set() where sv_any points to head */
2942                 oldsv->sv_u.svu_iv = cur;
2943
2944             }
2945             else
2946                 sv_setiv(oldsv, cur);
2947         }
2948         else
2949         {
2950             /* we need a fresh SV every time so that loop body sees a
2951              * completely new SV for closures/references to work as they
2952              * used to */
2953             *itersvp = newSViv(cur);
2954             SvREFCNT_dec(oldsv);
2955         }
2956
2957         if (UNLIKELY(cur == IV_MAX)) {
2958             /* Handle end of range at IV_MAX */
2959             cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2960         } else
2961             ++cx->blk_loop.state_u.lazyiv.cur;
2962         break;
2963     }
2964
2965     case CXt_LOOP_LIST: /* for (1,2,3) */
2966
2967         assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
2968         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
2969         ix = (cx->blk_loop.state_u.stack.ix += inc);
2970         if (UNLIKELY(inc > 0
2971                         ? ix > cx->blk_oldsp
2972                         : ix <= cx->blk_loop.state_u.stack.basesp)
2973         )
2974             goto retno;
2975
2976         sv = PL_stack_base[ix];
2977         av = NULL;
2978         goto loop_ary_common;
2979
2980     case CXt_LOOP_ARY: /* for (@ary) */
2981
2982         av = cx->blk_loop.state_u.ary.ary;
2983         inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
2984         ix = (cx->blk_loop.state_u.ary.ix += inc);
2985         if (UNLIKELY(inc > 0
2986                         ? ix > AvFILL(av)
2987                         : ix < 0)
2988         )
2989             goto retno;
2990
2991         if (UNLIKELY(SvRMAGICAL(av))) {
2992             SV * const * const svp = av_fetch(av, ix, FALSE);
2993             sv = svp ? *svp : NULL;
2994         }
2995         else {
2996             sv = AvARRAY(av)[ix];
2997         }
2998
2999       loop_ary_common:
3000
3001         if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
3002             SvSetMagicSV(*itersvp, sv);
3003             break;
3004         }
3005
3006         if (LIKELY(sv)) {
3007             if (UNLIKELY(SvIS_FREED(sv))) {
3008                 *itersvp = NULL;
3009                 Perl_croak(aTHX_ "Use of freed value in iteration");
3010             }
3011             if (SvPADTMP(sv)) {
3012                 sv = newSVsv(sv);
3013             }
3014             else {
3015                 SvTEMP_off(sv);
3016                 SvREFCNT_inc_simple_void_NN(sv);
3017             }
3018         }
3019         else if (av) {
3020             sv = newSVavdefelem(av, ix, 0);
3021         }
3022         else
3023             sv = &PL_sv_undef;
3024
3025         oldsv = *itersvp;
3026         *itersvp = sv;
3027         SvREFCNT_dec(oldsv);
3028         break;
3029
3030     default:
3031         DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
3032     }
3033
3034     retsv = &PL_sv_yes;
3035     if (0) {
3036       retno:
3037         retsv = &PL_sv_no;
3038     }
3039     /* pp_enteriter should have pre-extended the stack */
3040     EXTEND_SKIP(PL_stack_sp, 1);
3041     *++PL_stack_sp =retsv;
3042
3043     return PL_op->op_next;
3044 }
3045
3046 /*
3047 A description of how taint works in pattern matching and substitution.
3048
3049 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
3050 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
3051
3052 While the pattern is being assembled/concatenated and then compiled,
3053 PL_tainted will get set (via TAINT_set) if any component of the pattern
3054 is tainted, e.g. /.*$tainted/.  At the end of pattern compilation,
3055 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
3056 TAINT_get).  It will also be set if any component of the pattern matches
3057 based on locale-dependent behavior.
3058
3059 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
3060 the pattern is marked as tainted. This means that subsequent usage, such
3061 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
3062 on the new pattern too.
3063
3064 RXf_TAINTED_SEEN is used post-execution by the get magic code
3065 of $1 et al to indicate whether the returned value should be tainted.
3066 It is the responsibility of the caller of the pattern (i.e. pp_match,
3067 pp_subst etc) to set this flag for any other circumstances where $1 needs
3068 to be tainted.
3069
3070 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
3071
3072 There are three possible sources of taint
3073     * the source string
3074     * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
3075     * the replacement string (or expression under /e)
3076
3077 There are four destinations of taint and they are affected by the sources
3078 according to the rules below:
3079
3080     * the return value (not including /r):
3081         tainted by the source string and pattern, but only for the
3082         number-of-iterations case; boolean returns aren't tainted;
3083     * the modified string (or modified copy under /r):
3084         tainted by the source string, pattern, and replacement strings;
3085     * $1 et al:
3086         tainted by the pattern, and under 'use re "taint"', by the source
3087         string too;
3088     * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
3089         should always be unset before executing subsequent code.
3090
3091 The overall action of pp_subst is:
3092
3093     * at the start, set bits in rxtainted indicating the taint status of
3094         the various sources.
3095
3096     * After each pattern execution, update the SUBST_TAINT_PAT bit in
3097         rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
3098         pattern has subsequently become tainted via locale ops.
3099
3100     * If control is being passed to pp_substcont to execute a /e block,
3101         save rxtainted in the CXt_SUBST block, for future use by
3102         pp_substcont.
3103
3104     * Whenever control is being returned to perl code (either by falling
3105         off the "end" of pp_subst/pp_substcont, or by entering a /e block),
3106         use the flag bits in rxtainted to make all the appropriate types of
3107         destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
3108         et al will appear tainted.
3109
3110 pp_match is just a simpler version of the above.
3111
3112 */
3113
3114 PP(pp_subst)
3115 {
3116     dSP; dTARG;
3117     PMOP *pm = cPMOP;
3118     PMOP *rpm = pm;
3119     char *s;
3120     char *strend;
3121     const char *c;
3122     STRLEN clen;
3123     SSize_t iters = 0;
3124     SSize_t maxiters;
3125     bool once;
3126     U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
3127                         See "how taint works" above */
3128     char *orig;
3129     U8 r_flags;
3130     REGEXP *rx = PM_GETRE(pm);
3131     STRLEN len;
3132     int force_on_match = 0;
3133     const I32 oldsave = PL_savestack_ix;
3134     STRLEN slen;
3135     bool doutf8 = FALSE; /* whether replacement is in utf8 */
3136 #ifdef PERL_ANY_COW
3137     bool was_cow;
3138 #endif
3139     SV *nsv = NULL;
3140     /* known replacement string? */
3141     SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
3142
3143     PERL_ASYNC_CHECK();
3144
3145     if (PL_op->op_flags & OPf_STACKED)
3146         TARG = POPs;
3147     else {
3148         if (ARGTARG)
3149             GETTARGET;
3150         else {
3151             TARG = DEFSV;
3152         }
3153         EXTEND(SP,1);
3154     }
3155
3156     SvGETMAGIC(TARG); /* must come before cow check */
3157 #ifdef PERL_ANY_COW
3158     /* note that a string might get converted to COW during matching */
3159     was_cow = cBOOL(SvIsCOW(TARG));
3160 #endif
3161     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3162 #ifndef PERL_ANY_COW
3163         if (SvIsCOW(TARG))
3164             sv_force_normal_flags(TARG,0);
3165 #endif
3166         if ((SvREADONLY(TARG)
3167                 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
3168                       || SvTYPE(TARG) > SVt_PVLV)
3169                      && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
3170             Perl_croak_no_modify();
3171     }
3172     PUTBACK;
3173
3174     orig = SvPV_nomg(TARG, len);
3175     /* note we don't (yet) force the var into being a string; if we fail
3176      * to match, we leave as-is; on successful match however, we *will*
3177      * coerce into a string, then repeat the match */
3178     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
3179         force_on_match = 1;
3180
3181     /* only replace once? */
3182     once = !(rpm->op_pmflags & PMf_GLOBAL);
3183
3184     /* See "how taint works" above */
3185     if (TAINTING_get) {
3186         rxtainted  = (
3187             (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
3188           | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
3189           | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
3190           | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3191                 ? SUBST_TAINT_BOOLRET : 0));
3192         TAINT_NOT;
3193     }
3194
3195   force_it:
3196     if (!pm || !orig)
3197         DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
3198
3199     strend = orig + len;
3200     slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
3201     maxiters = 2 * slen + 10;   /* We can match twice at each
3202                                    position, once with zero-length,
3203                                    second time with non-zero. */
3204
3205     /* handle the empty pattern */
3206     if (!RX_PRELEN(rx) && PL_curpm && !ReANY(rx)->mother_re) {
3207         if (PL_curpm == PL_reg_curpm) {
3208             if (PL_curpm_under) {
3209                 if (PL_curpm_under == PL_reg_curpm) {
3210                     Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3211                 } else {
3212                     pm = PL_curpm_under;
3213                 }
3214             }
3215         } else {
3216             pm = PL_curpm;
3217         }
3218         rx = PM_GETRE(pm);
3219     }
3220
3221 #ifdef PERL_SAWAMPERSAND
3222     r_flags = (    RX_NPARENS(rx)
3223                 || PL_sawampersand
3224                 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3225                 || (rpm->op_pmflags & PMf_KEEPCOPY)
3226               )
3227           ? REXEC_COPY_STR
3228           : 0;
3229 #else
3230     r_flags = REXEC_COPY_STR;
3231 #endif
3232
3233     if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
3234     {
3235         SPAGAIN;
3236         PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
3237         LEAVE_SCOPE(oldsave);
3238         RETURN;
3239     }
3240     PL_curpm = pm;
3241
3242     /* known replacement string? */
3243     if (dstr) {
3244         /* replacement needing upgrading? */
3245         if (DO_UTF8(TARG) && !doutf8) {
3246              nsv = sv_newmortal();
3247              SvSetSV(nsv, dstr);
3248              sv_utf8_upgrade(nsv);
3249              c = SvPV_const(nsv, clen);
3250              doutf8 = TRUE;
3251         }
3252         else {
3253             c = SvPV_const(dstr, clen);
3254             doutf8 = DO_UTF8(dstr);
3255         }
3256
3257         if (SvTAINTED(dstr))
3258             rxtainted |= SUBST_TAINT_REPL;
3259     }
3260     else {
3261         c = NULL;
3262         doutf8 = FALSE;
3263     }
3264
3265     /* can do inplace substitution? */
3266     if (c
3267 #ifdef PERL_ANY_COW
3268         && !was_cow
3269 #endif
3270         && (I32)clen <= RX_MINLENRET(rx)
3271         && (  once
3272            || !(r_flags & REXEC_COPY_STR)
3273            || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
3274            )
3275         && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
3276         && (!doutf8 || SvUTF8(TARG))
3277         && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3278     {
3279
3280 #ifdef PERL_ANY_COW
3281         /* string might have got converted to COW since we set was_cow */
3282         if (SvIsCOW(TARG)) {
3283           if (!force_on_match)
3284             goto have_a_cow;
3285           assert(SvVOK(TARG));
3286         }
3287 #endif
3288         if (force_on_match) {
3289             /* redo the first match, this time with the orig var
3290              * forced into being a string */
3291             force_on_match = 0;
3292             orig = SvPV_force_nomg(TARG, len);
3293             goto force_it;
3294         }
3295
3296         if (once) {
3297             char *d, *m;
3298             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
3299                 rxtainted |= SUBST_TAINT_PAT;
3300             m = orig + RX_OFFS(rx)[0].start;
3301             d = orig + RX_OFFS(rx)[0].end;
3302             s = orig;
3303             if (m - s > strend - d) {  /* faster to shorten from end */
3304                 I32 i;
3305                 if (clen) {
3306                     Copy(c, m, clen, char);
3307                     m += clen;
3308                 }
3309                 i = strend - d;
3310                 if (i > 0) {
3311                     Move(d, m, i, char);
3312                     m += i;
3313                 }
3314                 *m = '\0';
3315                 SvCUR_set(TARG, m - s);
3316             }
3317             else {      /* faster from front */
3318                 I32 i = m - s;
3319                 d -= clen;
3320                 if (i > 0)
3321                     Move(s, d - i, i, char);
3322                 sv_chop(TARG, d-i);
3323                 if (clen)
3324                     Copy(c, d, clen, char);
3325             }
3326             SPAGAIN;
3327             PUSHs(&PL_sv_yes);
3328         }
3329         else {
3330             char *d, *m;
3331             d = s = RX_OFFS(rx)[0].start + orig;
3332             do {
3333                 I32 i;
3334                 if (UNLIKELY(iters++ > maxiters))
3335                     DIE(aTHX_ "Substitution loop");
3336                 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
3337                     rxtainted |= SUBST_TAINT_PAT;
3338                 m = RX_OFFS(rx)[0].start + orig;
3339                 if ((i = m - s)) {
3340                     if (s != d)
3341                         Move(s, d, i, char);
3342                     d += i;
3343                 }
3344                 if (clen) {
3345                     Copy(c, d, clen, char);
3346                     d += clen;
3347                 }
3348                 s = RX_OFFS(rx)[0].end + orig;
3349             } while (CALLREGEXEC(rx, s, strend, orig,
3350                                  s == m, /* don't match same null twice */
3351                                  TARG, NULL,
3352                      REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3353             if (s != d) {
3354                 I32 i = strend - s;
3355                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
3356                 Move(s, d, i+1, char);          /* include the NUL */
3357             }
3358             SPAGAIN;
3359             mPUSHi(iters);
3360         }
3361     }
3362     else {
3363         bool first;
3364         char *m;
3365         SV *repl;
3366         if (force_on_match) {
3367             /* redo the first match, this time with the orig var
3368              * forced into being a string */
3369             force_on_match = 0;
3370             if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3371                 /* I feel that it should be possible to avoid this mortal copy
3372                    given that the code below copies into a new destination.
3373                    However, I suspect it isn't worth the complexity of
3374                    unravelling the C<goto force_it> for the small number of
3375                    cases where it would be viable to drop into the copy code. */
3376                 TARG = sv_2mortal(newSVsv(TARG));
3377             }
3378             orig = SvPV_force_nomg(TARG, len);
3379             goto force_it;
3380         }
3381 #ifdef PERL_ANY_COW
3382       have_a_cow:
3383 #endif
3384         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
3385             rxtainted |= SUBST_TAINT_PAT;
3386         repl = dstr;
3387         s = RX_OFFS(rx)[0].start + orig;
3388         dstr = newSVpvn_flags(orig, s-orig,
3389                     SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3390         if (!c) {
3391             PERL_CONTEXT *cx;
3392             SPAGAIN;
3393             m = orig;
3394             /* note that a whole bunch of local vars are saved here for
3395              * use by pp_substcont: here's a list of them in case you're
3396              * searching for places in this sub that uses a particular var:
3397              * iters maxiters r_flags oldsave rxtainted orig dstr targ
3398              * s m strend rx once */
3399             CX_PUSHSUBST(cx);
3400             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3401         }
3402         first = TRUE;
3403         do {
3404             if (UNLIKELY(iters++ > maxiters))
3405                 DIE(aTHX_ "Substitution loop");
3406             if (UNLIKELY(RX_MATCH_TAINTED(rx)))
3407                 rxtainted |= SUBST_TAINT_PAT;
3408             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
3409                 char *old_s    = s;
3410                 char *old_orig = orig;
3411                 assert(RX_SUBOFFSET(rx) == 0);
3412
3413                 orig = RX_SUBBEG(rx);
3414                 s = orig + (old_s - old_orig);
3415                 strend = s + (strend - old_s);
3416             }
3417             m = RX_OFFS(rx)[0].start + orig;
3418             sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3419             s = RX_OFFS(rx)[0].end + orig;
3420             if (first) {
3421                 /* replacement already stringified */
3422               if (clen)
3423                 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3424               first = FALSE;
3425             }
3426             else {
3427                 sv_catsv(dstr, repl);
3428                 if (UNLIKELY(SvTAINTED(repl)))
3429                     rxtainted |= SUBST_TAINT_REPL;
3430             }
3431             if (once)
3432                 break;
3433         } while (CALLREGEXEC(rx, s, strend, orig,
3434                              s == m,    /* Yields minend of 0 or 1 */
3435                              TARG, NULL,
3436                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3437         assert(strend >= s);
3438         sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3439
3440         if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3441             /* From here on down we're using the copy, and leaving the original
3442                untouched.  */
3443             TARG = dstr;
3444             SPAGAIN;
3445             PUSHs(dstr);
3446         } else {
3447 #ifdef PERL_ANY_COW
3448             /* The match may make the string COW. If so, brilliant, because
3449                that's just saved us one malloc, copy and free - the regexp has
3450                donated the old buffer, and we malloc an entirely new one, rather
3451                than the regexp malloc()ing a buffer and copying our original,
3452                only for us to throw it away here during the substitution.  */
3453             if (SvIsCOW(TARG)) {
3454                 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3455             } else
3456 #endif
3457             {
3458                 SvPV_free(TARG);
3459             }
3460             SvPV_set(TARG, SvPVX(dstr));
3461             SvCUR_set(TARG, SvCUR(dstr));
3462             SvLEN_set(TARG, SvLEN(dstr));
3463             SvFLAGS(TARG) |= SvUTF8(dstr);
3464             SvPV_set(dstr, NULL);
3465
3466             SPAGAIN;
3467             mPUSHi(iters);
3468         }
3469     }
3470
3471     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3472         (void)SvPOK_only_UTF8(TARG);
3473     }
3474
3475     /* See "how taint works" above */
3476     if (TAINTING_get) {
3477         if ((rxtainted & SUBST_TAINT_PAT) ||
3478             ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3479                                 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3480         )
3481             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
3482
3483         if (!(rxtainted & SUBST_TAINT_BOOLRET)
3484             && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3485         )
3486             SvTAINTED_on(TOPs);  /* taint return value */
3487         else
3488             SvTAINTED_off(TOPs);  /* may have got tainted earlier */
3489
3490         /* needed for mg_set below */
3491         TAINT_set(
3492           cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3493         );
3494         SvTAINT(TARG);
3495     }
3496     SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3497     TAINT_NOT;
3498     LEAVE_SCOPE(oldsave);
3499     RETURN;
3500 }
3501
3502 PP(pp_grepwhile)
3503 {
3504     dSP;
3505
3506     if (SvTRUEx(POPs))
3507         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3508     ++*PL_markstack_ptr;
3509     FREETMPS;
3510     LEAVE_with_name("grep_item");                                       /* exit inner scope */
3511
3512     /* All done yet? */
3513     if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3514         I32 items;
3515         const U8 gimme = GIMME_V;
3516
3517         LEAVE_with_name("grep");                                        /* exit outer scope */
3518         (void)POPMARK;                          /* pop src */
3519         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3520         (void)POPMARK;                          /* pop dst */
3521         SP = PL_stack_base + POPMARK;           /* pop original mark */
3522         if (gimme == G_SCALAR) {
3523                 dTARGET;
3524                 XPUSHi(items);
3525         }
3526         else if (gimme == G_ARRAY)
3527             SP += items;
3528         RETURN;
3529     }
3530     else {
3531         SV *src;
3532
3533         ENTER_with_name("grep_item");                                   /* enter inner scope */
3534         SAVEVPTR(PL_curpm);
3535
3536         src = PL_stack_base[TOPMARK];
3537         if (SvPADTMP(src)) {
3538             src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
3539             PL_tmps_floor++;
3540         }
3541         SvTEMP_off(src);
3542         DEFSV_set(src);
3543
3544         RETURNOP(cLOGOP->op_other);
3545     }
3546 }
3547
3548 /* leave_adjust_stacks():
3549  *
3550  * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
3551  * positioning them at to_sp+1 onwards, and do the equivalent of a
3552  * FREEMPS and TAINT_NOT.
3553  *
3554  * Not intended to be called in void context.
3555  *
3556  * When leaving a sub, eval, do{} or other scope, the things that need
3557  * doing to process the return args are:
3558  *    * in scalar context, only return the last arg (or PL_sv_undef if none);
3559  *    * for the types of return that return copies of their args (such
3560  *      as rvalue sub return), make a mortal copy of every return arg,
3561  *      except where we can optimise the copy away without it being
3562  *      semantically visible;
3563  *    * make sure that the arg isn't prematurely freed; in the case of an
3564  *      arg not copied, this may involve mortalising it. For example, in
3565  *      C<sub f { my $x = ...; $x }>, $x would be freed when we do
3566  *      CX_LEAVE_SCOPE(cx) unless it's protected or copied.
3567  *
3568  * What condition to use when deciding whether to pass the arg through
3569  * or make a copy, is determined by the 'pass' arg; its valid values are:
3570  *   0: rvalue sub/eval exit
3571  *   1: other rvalue scope exit
3572  *   2: :lvalue sub exit in rvalue context
3573  *   3: :lvalue sub exit in lvalue context and other lvalue scope exits
3574  *
3575  * There is a big issue with doing a FREETMPS. We would like to free any
3576  * temps created by the last statement which the sub executed, rather than
3577  * leaving them for the caller. In a situation where a sub call isn't
3578  * soon followed by a nextstate (e.g. nested recursive calls, a la
3579  * fibonacci()), temps can accumulate, causing memory and performance
3580  * issues.
3581  *
3582  * On the other hand, we don't want to free any TEMPs which are keeping
3583  * alive any return args that we skipped copying; nor do we wish to undo
3584  * any mortalising done here.
3585  *
3586  * The solution is to split the temps stack frame into two, with a cut
3587  * point delineating the two halves. We arrange that by the end of this
3588  * function, all the temps stack frame entries we wish to keep are in the
3589  * range  PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
3590  * the range  tmps_base .. PL_tmps_ix.  During the course of this
3591  * function, tmps_base starts off as PL_tmps_floor+1, then increases
3592  * whenever we find or create a temp that we know should be kept. In
3593  * general the stuff above tmps_base is undecided until we reach the end,
3594  * and we may need a sort stage for that.
3595  *
3596  * To determine whether a TEMP is keeping a return arg alive, every
3597  * arg that is kept rather than copied and which has the SvTEMP flag
3598  * set, has the flag temporarily unset, to mark it. At the end we scan
3599  * the temps stack frame above the cut for entries without SvTEMP and
3600  * keep them, while turning SvTEMP on again. Note that if we die before
3601  * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
3602  * those SVs may be slightly less efficient.
3603  *
3604  * In practice various optimisations for some common cases mean we can
3605  * avoid most of the scanning and swapping about with the temps stack.
3606  */
3607
3608 void
3609 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
3610 {
3611     dVAR;
3612     dSP;
3613     SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
3614     SSize_t nargs;
3615
3616     PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
3617
3618     TAINT_NOT;
3619
3620     if (gimme == G_ARRAY) {
3621         nargs = SP - from_sp;
3622         from_sp++;
3623     }
3624     else {
3625         assert(gimme == G_SCALAR);
3626         if (UNLIKELY(from_sp >= SP)) {
3627             /* no return args */
3628             assert(from_sp == SP);
3629             EXTEND(SP, 1);
3630             *++SP = &PL_sv_undef;
3631             to_sp = SP;
3632             nargs   = 0;
3633         }
3634         else {
3635             from_sp = SP;
3636             nargs   = 1;
3637         }
3638     }
3639
3640     /* common code for G_SCALAR and G_ARRAY */
3641
3642     tmps_base = PL_tmps_floor + 1;
3643
3644     assert(nargs >= 0);
3645     if (nargs) {
3646         /* pointer version of tmps_base. Not safe across temp stack
3647          * reallocs. */
3648         SV **tmps_basep;
3649
3650         EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
3651         tmps_basep = PL_tmps_stack + tmps_base;
3652
3653         /* process each return arg */
3654
3655         do {
3656             SV *sv = *from_sp++;
3657
3658             assert(PL_tmps_ix + nargs < PL_tmps_max);
3659 #ifdef DEBUGGING
3660             /* PADTMPs with container set magic shouldn't appear in the
3661              * wild. This assert is more important for pp_leavesublv(),
3662              * but by testing for it here, we're more likely to catch
3663              * bad cases (what with :lvalue subs not being widely
3664              * deployed). The two issues are that for something like
3665              *     sub :lvalue { $tied{foo} }
3666              * or
3667              *     sub :lvalue { substr($foo,1,2) }
3668              * pp_leavesublv() will croak if the sub returns a PADTMP,
3669              * and currently functions like pp_substr() return a mortal
3670              * rather than using their PADTMP when returning a PVLV.
3671              * This is because the PVLV will hold a ref to $foo,
3672              * so $foo would get delayed in being freed while
3673              * the PADTMP SV remained in the PAD.
3674              * So if this assert fails it means either:
3675              *  1) there is pp code similar to pp_substr that is
3676              *     returning a PADTMP instead of a mortal, and probably
3677              *     needs fixing, or
3678              *  2) pp_leavesublv is making unwarranted assumptions
3679              *     about always croaking on a PADTMP
3680              */
3681             if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
3682                 MAGIC *mg;
3683                 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
3684                     assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
3685                 }
3686             }
3687 #endif
3688
3689             if (
3690                pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3691              : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3692              : pass == 2 ? (!SvPADTMP(sv))
3693              : 1)
3694             {
3695                 /* pass through: skip copy for logic or optimisation
3696                  * reasons; instead mortalise it, except that ... */
3697                 *++to_sp = sv;
3698
3699                 if (SvTEMP(sv)) {
3700                     /* ... since this SV is an SvTEMP , we don't need to
3701                      * re-mortalise it; instead we just need to ensure
3702                      * that its existing entry in the temps stack frame
3703                      * ends up below the cut and so avoids being freed
3704                      * this time round. We mark it as needing to be kept
3705                      * by temporarily unsetting SvTEMP; then at the end,
3706                      * we shuffle any !SvTEMP entries on the tmps stack
3707                      * back below the cut.
3708                      * However, there's a significant chance that there's
3709                      * a 1:1 correspondence between the first few (or all)
3710                      * elements in the return args stack frame and those
3711                      * in the temps stack frame; e,g.:
3712                      *      sub f { ....; map {...} .... },
3713                      * or if we're exiting multiple scopes and one of the
3714                      * inner scopes has already made mortal copies of each
3715                      * return arg.
3716                      *
3717                      * If so, this arg sv will correspond to the next item
3718                      * on the tmps stack above the cut, and so can be kept
3719                      * merely by moving the cut boundary up one, rather
3720                      * than messing with SvTEMP.  If all args are 1:1 then
3721                      * we can avoid the sorting stage below completely.
3722                      *
3723                      * If there are no items above the cut on the tmps
3724                      * stack, then the SvTEMP must comne from an item
3725                      * below the cut, so there's nothing to do.
3726                      */
3727                     if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
3728                         if (sv == *tmps_basep)
3729                             tmps_basep++;
3730                         else
3731                             SvTEMP_off(sv);
3732                     }
3733                 }
3734                 else if (!SvPADTMP(sv)) {
3735                     /* mortalise arg to avoid it being freed during save
3736                      * stack unwinding. Pad tmps don't need mortalising as
3737                      * they're never freed. This is the equivalent of
3738                      * sv_2mortal(SvREFCNT_inc(sv)), except that:
3739                      *  * it assumes that the temps stack has already been
3740                      *    extended;
3741                      *  * it puts the new item at the cut rather than at
3742                      *    ++PL_tmps_ix, moving the previous occupant there
3743                      *    instead.
3744                      */
3745                     if (!SvIMMORTAL(sv)) {
3746                         SvREFCNT_inc_simple_void_NN(sv);
3747                         SvTEMP_on(sv);
3748                         /* Note that if there's nothing above the cut,
3749                          * this copies the garbage one slot above
3750                          * PL_tmps_ix onto itself. This is harmless (the
3751                          * stack's already been extended), but might in
3752                          * theory trigger warnings from tools like ASan
3753                          */
3754                         PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3755                         *tmps_basep++ = sv;
3756                     }
3757                 }
3758             }
3759             else {
3760                 /* Make a mortal copy of the SV.
3761                  * The following code is the equivalent of sv_mortalcopy()
3762                  * except that:
3763                  *  * it assumes the temps stack has already been extended;
3764                  *  * it optimises the copying for some simple SV types;
3765                  *  * it puts the new item at the cut rather than at
3766                  *    ++PL_tmps_ix, moving the previous occupant there
3767                  *    instead.
3768                  */
3769                 SV *newsv = newSV(0);
3770
3771                 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3772                 /* put it on the tmps stack early so it gets freed if we die */
3773                 *tmps_basep++ = newsv;
3774                 *++to_sp = newsv;
3775
3776                 if (SvTYPE(sv) <= SVt_IV) {
3777                     /* arg must be one of undef, IV/UV, or RV: skip
3778                      * sv_setsv_flags() and do the copy directly */
3779                     U32 dstflags;
3780                     U32 srcflags = SvFLAGS(sv);
3781
3782                     assert(!SvGMAGICAL(sv));
3783                     if (srcflags & (SVf_IOK|SVf_ROK)) {
3784                         SET_SVANY_FOR_BODYLESS_IV(newsv);
3785
3786                         if (srcflags & SVf_ROK) {
3787                             newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
3788                             /* SV type plus flags */
3789                             dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
3790                         }
3791                         else {
3792                             /* both src and dst are <= SVt_IV, so sv_any
3793                              * points to the head; so access the heads
3794                              * directly rather than going via sv_any.
3795                              */
3796                             assert(    &(sv->sv_u.svu_iv)
3797                                     == &(((XPVIV*) SvANY(sv))->xiv_iv));
3798                             assert(    &(newsv->sv_u.svu_iv)
3799                                     == &(((XPVIV*) SvANY(newsv))->xiv_iv));
3800                             newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
3801                             /* SV type plus flags */
3802                             dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
3803                                             |(srcflags & SVf_IVisUV));
3804                         }
3805                     }
3806                     else {
3807                         assert(!(srcflags & SVf_OK));
3808                         dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
3809                     }
3810                     SvFLAGS(newsv) = dstflags;
3811
3812                 }
3813                 else {
3814                     /* do the full sv_setsv() */
3815                     SSize_t old_base;
3816
3817                     SvTEMP_on(newsv);
3818                     old_base = tmps_basep - PL_tmps_stack;
3819                     SvGETMAGIC(sv);
3820                     sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
3821                     /* the mg_get or sv_setsv might have created new temps
3822                      * or realloced the tmps stack; regrow and reload */
3823                     EXTEND_MORTAL(nargs);
3824                     tmps_basep = PL_tmps_stack + old_base;
3825                     TAINT_NOT;  /* Each item is independent */
3826                 }
3827
3828             }
3829         } while (--nargs);
3830
3831         /* If there are any temps left above the cut, we need to sort
3832          * them into those to keep and those to free. The only ones to
3833          * keep are those for which we've temporarily unset SvTEMP.
3834          * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
3835          * swapping pairs as necessary. Stop when we meet in the middle.
3836          */
3837         {
3838             SV **top = PL_tmps_stack + PL_tmps_ix;
3839             while (tmps_basep <= top) {
3840                 SV *sv = *top;
3841                 if (SvTEMP(sv))
3842                     top--;
3843                 else {
3844                     SvTEMP_on(sv);
3845                     *top = *tmps_basep;
3846                     *tmps_basep = sv;
3847                     tmps_basep++;
3848                 }
3849             }
3850         }
3851
3852         tmps_base = tmps_basep - PL_tmps_stack;
3853     }
3854
3855     PL_stack_sp = to_sp;
3856
3857     /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
3858     while (PL_tmps_ix >= tmps_base) {
3859         SV* const sv = PL_tmps_stack[PL_tmps_ix--];
3860 #ifdef PERL_POISON
3861         PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
3862 #endif
3863         if (LIKELY(sv)) {
3864             SvTEMP_off(sv);
3865             SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
3866         }
3867     }
3868 }
3869
3870
3871 /* also tail-called by pp_return */
3872
3873 PP(pp_leavesub)
3874 {
3875     U8 gimme;
3876     PERL_CONTEXT *cx;
3877     SV **oldsp;
3878     OP *retop;
3879
3880     cx = CX_CUR();
3881     assert(CxTYPE(cx) == CXt_SUB);
3882
3883     if (CxMULTICALL(cx)) {
3884         /* entry zero of a stack is always PL_sv_undef, which
3885          * simplifies converting a '()' return into undef in scalar context */
3886         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
3887         return 0;
3888     }
3889
3890     gimme = cx->blk_gimme;
3891     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
3892
3893     if (gimme == G_VOID)
3894         PL_stack_sp = oldsp;
3895     else
3896         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
3897
3898     CX_LEAVE_SCOPE(cx);
3899     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
3900     cx_popblock(cx);
3901     retop = cx->blk_sub.retop;
3902     CX_POP(cx);
3903
3904     return retop;
3905 }
3906
3907
3908 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
3909  * forces an abandon */
3910
3911 void
3912 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
3913 {
3914     const SSize_t fill = AvFILLp(av);
3915
3916     PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
3917
3918     if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
3919         av_clear(av);
3920         AvREIFY_only(av);
3921     }
3922     else {
3923         AV *newav = newAV();
3924         av_extend(newav, fill);
3925         AvREIFY_only(newav);
3926         PAD_SVl(0) = MUTABLE_SV(newav);
3927         SvREFCNT_dec_NN(av);
3928     }
3929 }
3930
3931
3932 PP(pp_entersub)
3933 {
3934     dSP; dPOPss;
3935     GV *gv;
3936     CV *cv;
3937     PERL_CONTEXT *cx;
3938     I32 old_savestack_ix;
3939
3940     if (UNLIKELY(!sv))
3941         goto do_die;
3942
3943     /* Locate the CV to call:
3944      * - most common case: RV->CV: f(), $ref->():
3945      *   note that if a sub is compiled before its caller is compiled,
3946      *   the stash entry will be a ref to a CV, rather than being a GV.
3947      * - second most common case: CV: $ref->method()
3948      */
3949
3950     /* a non-magic-RV -> CV ? */
3951     if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
3952         cv = MUTABLE_CV(SvRV(sv));
3953         if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
3954             goto do_ref;
3955     }
3956     else
3957         cv = MUTABLE_CV(sv);
3958
3959     /* a CV ? */
3960     if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
3961         /* handle all the weird cases */
3962         switch (SvTYPE(sv)) {
3963         case SVt_PVLV:
3964             if (!isGV_with_GP(sv))
3965                 goto do_default;
3966             /* FALLTHROUGH */
3967         case SVt_PVGV:
3968             cv = GvCVu((const GV *)sv);
3969             if (UNLIKELY(!cv)) {
3970                 HV *stash;
3971                 cv = sv_2cv(sv, &stash, &gv, 0);
3972                 if (!cv) {
3973                     old_savestack_ix = PL_savestack_ix;
3974                     goto try_autoload;
3975                 }
3976             }
3977             break;
3978
3979         default:
3980           do_default:
3981             SvGETMAGIC(sv);
3982             if (SvROK(sv)) {
3983               do_ref:
3984                 if (UNLIKELY(SvAMAGIC(sv))) {
3985                     sv = amagic_deref_call(sv, to_cv_amg);
3986                     /* Don't SPAGAIN here.  */
3987                 }
3988             }
3989             else {
3990                 const char *sym;
3991                 STRLEN len;
3992                 if (UNLIKELY(!SvOK(sv)))
3993                     DIE(aTHX_ PL_no_usym, "a subroutine");
3994
3995                 if (UNLIKELY(sv == &PL_sv_yes)) { /* unfound import, ignore */
3996                     if (PL_op->op_flags & OPf_STACKED) /* hasargs */
3997                         SP = PL_stack_base + POPMARK;
3998                     else
3999                         (void)POPMARK;
4000                     if (GIMME_V == G_SCALAR)
4001                         PUSHs(&PL_sv_undef);
4002                     RETURN;
4003                 }
4004
4005                 sym = SvPV_nomg_const(sv, len);
4006                 if (PL_op->op_private & HINT_STRICT_REFS)
4007                     DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
4008                 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
4009                 break;
4010             }
4011             cv = MUTABLE_CV(SvRV(sv));
4012             if (LIKELY(SvTYPE(cv) == SVt_PVCV))
4013                 break;
4014             /* FALLTHROUGH */
4015         case SVt_PVHV:
4016         case SVt_PVAV:
4017           do_die:
4018             DIE(aTHX_ "Not a CODE reference");
4019         }
4020     }
4021
4022     /* At this point we want to save PL_savestack_ix, either by doing a
4023      * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
4024      * CV we will be using (so we don't know whether its XS, so we can't
4025      * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
4026      * the save stack. So remember where we are currently on the save
4027      * stack, and later update the CX or scopestack entry accordingly. */
4028     old_savestack_ix = PL_savestack_ix;
4029
4030     /* these two fields are in a union. If they ever become separate,
4031      * we have to test for both of them being null below */
4032     assert(cv);
4033     assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
4034     while (UNLIKELY(!CvROOT(cv))) {
4035         GV* autogv;
4036         SV* sub_name;
4037
4038         /* anonymous or undef'd function leaves us no recourse */
4039         if (CvLEXICAL(cv) && CvHASGV(cv))
4040             DIE(aTHX_ "Undefined subroutine &%" SVf " called",
4041                        SVfARG(cv_name(cv, NULL, 0)));
4042         if (CvANON(cv) || !CvHASGV(cv)) {
4043             DIE(aTHX_ "Undefined subroutine called");
4044         }
4045
4046         /* autoloaded stub? */
4047         if (cv != GvCV(gv = CvGV(cv))) {
4048             cv = GvCV(gv);
4049         }
4050         /* should call AUTOLOAD now? */
4051         else {
4052           try_autoload:
4053             autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
4054                                      (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
4055                                     |(PL_op->op_flags & OPf_REF
4056                                        ? GV_AUTOLOAD_ISMETHOD
4057                                        : 0));
4058             cv = autogv ? GvCV(autogv) : NULL;
4059         }
4060         if (!cv) {
4061             sub_name = sv_newmortal();
4062             gv_efullname3(sub_name, gv, NULL);
4063             DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
4064         }
4065     }
4066
4067     /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
4068     if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
4069         DIE(aTHX_ "Closure prototype called");
4070
4071     if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
4072             && !CvNODEBUG(cv)))
4073     {
4074          Perl_get_db_sub(aTHX_ &sv, cv);
4075          if (CvISXSUB(cv))
4076              PL_curcopdb = PL_curcop;
4077          if (CvLVALUE(cv)) {
4078              /* check for lsub that handles lvalue subroutines */
4079              cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
4080              /* if lsub not found then fall back to DB::sub */
4081              if (!cv) cv = GvCV(PL_DBsub);
4082          } else {
4083              cv = GvCV(PL_DBsub);
4084          }
4085
4086         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
4087             DIE(aTHX_ "No DB::sub routine defined");
4088     }
4089
4090     if (!(CvISXSUB(cv))) {
4091         /* This path taken at least 75% of the time   */
4092         dMARK;
4093         PADLIST *padlist;
4094         I32 depth;
4095         bool hasargs;
4096         U8 gimme;
4097
4098         /* keep PADTMP args alive throughout the call (we need to do this
4099          * because @_ isn't refcounted). Note that we create the mortals
4100          * in the caller's tmps frame, so they won't be freed until after
4101          * we return from the sub.
4102          */
4103         {
4104             SV **svp = MARK;
4105             while (svp < SP) {
4106                 SV *sv = *++svp;
4107                 if (!sv)
4108                     continue;
4109                 if (SvPADTMP(sv))
4110                     *svp = sv = sv_mortalcopy(sv);
4111                 SvTEMP_off(sv);
4112             }
4113         }
4114
4115         gimme = GIMME_V;
4116         cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
4117         hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
4118         cx_pushsub(cx, cv, PL_op->op_next, hasargs);
4119
4120         padlist = CvPADLIST(cv);
4121         if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
4122             pad_push(padlist, depth);
4123         PAD_SET_CUR_NOSAVE(padlist, depth);
4124         if (LIKELY(hasargs)) {
4125             AV *const av = MUTABLE_AV(PAD_SVl(0));
4126             SSize_t items;
4127             AV **defavp;
4128
4129             defavp = &GvAV(PL_defgv);
4130             cx->blk_sub.savearray = *defavp;
4131             *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
4132
4133             /* it's the responsibility of whoever leaves a sub to ensure
4134              * that a clean, empty AV is left in pad[0]. This is normally
4135              * done by cx_popsub() */
4136             assert(!AvREAL(av) && AvFILLp(av) == -1);
4137
4138             items = SP - MARK;
4139             if (UNLIKELY(items - 1 > AvMAX(av))) {
4140                 SV **ary = AvALLOC(av);
4141                 Renew(ary, items, SV*);
4142                 AvMAX(av) = items - 1;
4143                 AvALLOC(av) = ary;
4144                 AvARRAY(av) = ary;
4145             }
4146
4147             Copy(MARK+1,AvARRAY(av),items,SV*);
4148             AvFILLp(av) = items - 1;
4149         }
4150         if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
4151             !CvLVALUE(cv)))
4152             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
4153                 SVfARG(cv_name(cv, NULL, 0)));
4154         /* warning must come *after* we fully set up the context
4155          * stuff so that __WARN__ handlers can safely dounwind()
4156          * if they want to
4157          */
4158         if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
4159                 && ckWARN(WARN_RECURSION)
4160                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4161             sub_crush_depth(cv);
4162         RETURNOP(CvSTART(cv));
4163     }
4164     else {
4165         SSize_t markix = TOPMARK;
4166         bool is_scalar;
4167
4168         ENTER;
4169         /* pretend we did the ENTER earlier */
4170         PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
4171
4172         SAVETMPS;
4173         PUTBACK;
4174
4175         if (UNLIKELY(((PL_op->op_private
4176                & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
4177              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
4178             !CvLVALUE(cv)))
4179             DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
4180                 SVfARG(cv_name(cv, NULL, 0)));
4181
4182         if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
4183             /* Need to copy @_ to stack. Alternative may be to
4184              * switch stack to @_, and copy return values
4185              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
4186             AV * const av = GvAV(PL_defgv);
4187             const SSize_t items = AvFILL(av) + 1;
4188
4189             if (items) {
4190                 SSize_t i = 0;
4191                 const bool m = cBOOL(SvRMAGICAL(av));
4192                 /* Mark is at the end of the stack. */
4193                 EXTEND(SP, items);
4194                 for (; i < items; ++i)
4195                 {
4196                     SV *sv;
4197                     if (m) {
4198                         SV ** const svp = av_fetch(av, i, 0);
4199                         sv = svp ? *svp : NULL;
4200                     }
4201                     else sv = AvARRAY(av)[i];
4202                     if (sv) SP[i+1] = sv;
4203                     else {
4204                         SP[i+1] = newSVavdefelem(av, i, 1);
4205                     }
4206                 }
4207                 SP += items;
4208                 PUTBACK ;
4209             }
4210         }
4211         else {
4212             SV **mark = PL_stack_base + markix;
4213             SSize_t items = SP - mark;
4214             while (items--) {
4215                 mark++;
4216                 if (*mark && SvPADTMP(*mark)) {
4217                     *mark = sv_mortalcopy(*mark);
4218                 }
4219             }
4220         }
4221         /* We assume first XSUB in &DB::sub is the called one. */
4222         if (UNLIKELY(PL_curcopdb)) {
4223             SAVEVPTR(PL_curcop);
4224             PL_curcop = PL_curcopdb;
4225             PL_curcopdb = NULL;
4226         }
4227         /* Do we need to open block here? XXXX */
4228
4229         /* calculate gimme here as PL_op might get changed and then not
4230          * restored until the LEAVE further down */
4231         is_scalar = (GIMME_V == G_SCALAR);
4232
4233         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
4234         assert(CvXSUB(cv));
4235         CvXSUB(cv)(aTHX_ cv);
4236
4237         /* Enforce some sanity in scalar context. */
4238         if (is_scalar) {
4239             SV **svp = PL_stack_base + markix + 1;
4240             if (svp != PL_stack_sp) {
4241                 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
4242                 PL_stack_sp = svp;
4243             }
4244         }
4245         LEAVE;
4246         return NORMAL;
4247     }
4248 }
4249
4250 void
4251 Perl_sub_crush_depth(pTHX_ CV *cv)
4252 {
4253     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
4254
4255     if (CvANON(cv))
4256         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
4257     else {
4258         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
4259                     SVfARG(cv_name(cv,NULL,0)));
4260     }
4261 }
4262
4263
4264
4265 /* like croak, but report in context of caller */
4266
4267 void
4268 Perl_croak_caller(const char *pat, ...)
4269 {
4270     dTHX;
4271     va_list args;
4272     const PERL_CONTEXT *cx = caller_cx(0, NULL);
4273
4274     /* make error appear at call site */
4275     assert(cx);
4276     PL_curcop = cx->blk_oldcop;
4277
4278     va_start(args, pat);
4279     vcroak(pat, &args);
4280     NOT_REACHED; /* NOTREACHED */
4281     va_end(args);
4282 }
4283
4284
4285 PP(pp_aelem)
4286 {
4287     dSP;
4288     SV** svp;
4289     SV* const elemsv = POPs;
4290     IV elem = SvIV(elemsv);
4291     AV *const av = MUTABLE_AV(POPs);
4292     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4293     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4294     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4295     bool preeminent = TRUE;
4296     SV *sv;
4297
4298     if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
4299         Perl_warner(aTHX_ packWARN(WARN_MISC),
4300                     "Use of reference \"%" SVf "\" as array index",
4301                     SVfARG(elemsv));
4302     if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
4303         RETPUSHUNDEF;
4304
4305     if (UNLIKELY(localizing)) {
4306         MAGIC *mg;
4307         HV *stash;
4308
4309         /* If we can determine whether the element exist,
4310          * Try to preserve the existenceness of a tied array
4311          * element by using EXISTS and DELETE if possible.
4312          * Fallback to FETCH and STORE otherwise. */
4313         if (SvCANEXISTDELETE(av))
4314             preeminent = av_exists(av, elem);
4315     }
4316
4317     svp = av_fetch(av, elem, lval && !defer);
4318     if (lval) {
4319 #ifdef PERL_MALLOC_WRAP
4320          if (SvUOK(elemsv)) {
4321               const UV uv = SvUV(elemsv);
4322               elem = uv > IV_MAX ? IV_MAX : uv;
4323          }
4324          else if (SvNOK(elemsv))
4325               elem = (IV)SvNV(elemsv);
4326          if (elem > 0) {
4327               static const char oom_array_extend[] =
4328                 "Out of memory during array extend"; /* Duplicated in av.c */
4329               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
4330          }
4331 #endif
4332         if (!svp || !*svp) {
4333             IV len;
4334             if (!defer)
4335                 DIE(aTHX_ PL_no_aelem, elem);
4336             len = av_tindex(av);
4337             mPUSHs(newSVavdefelem(av,
4338             /* Resolve a negative index now, unless it points before the
4339                beginning of the array, in which case record it for error
4340                reporting in magic_setdefelem. */
4341                 elem < 0 && len + elem >= 0 ? len + elem : elem,
4342                 1));
4343             RETURN;
4344         }
4345         if (UNLIKELY(localizing)) {
4346             if (preeminent)
4347                 save_aelem(av, elem, svp);
4348             else
4349                 SAVEADELETE(av, elem);
4350         }
4351         else if (PL_op->op_private & OPpDEREF) {
4352             PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
4353             RETURN;
4354         }
4355     }
4356     sv = (svp ? *svp : &PL_sv_undef);
4357     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
4358         mg_get(sv);
4359     PUSHs(sv);
4360     RETURN;
4361 }
4362
4363 SV*
4364 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
4365 {
4366     PERL_ARGS_ASSERT_VIVIFY_REF;
4367
4368     SvGETMAGIC(sv);
4369     if (!SvOK(sv)) {
4370         if (SvREADONLY(sv))
4371             Perl_croak_no_modify();
4372         prepare_SV_for_RV(sv);
4373         switch (to_what) {
4374         case OPpDEREF_SV:
4375             SvRV_set(sv, newSV(0));
4376             break;
4377         case OPpDEREF_AV:
4378             SvRV_set(sv, MUTABLE_SV(newAV()));
4379             break;
4380         case OPpDEREF_HV:
4381             SvRV_set(sv, MUTABLE_SV(newHV()));
4382             break;
4383         }
4384         SvROK_on(sv);
4385         SvSETMAGIC(sv);
4386         SvGETMAGIC(sv);
4387     }
4388     if (SvGMAGICAL(sv)) {
4389         /* copy the sv without magic to prevent magic from being
4390            executed twice */
4391         SV* msv = sv_newmortal();
4392         sv_setsv_nomg(msv, sv);
4393         return msv;
4394     }
4395     return sv;
4396 }
4397
4398 PERL_STATIC_INLINE HV *
4399 S_opmethod_stash(pTHX_ SV* meth)
4400 {
4401     SV* ob;
4402     HV* stash;
4403
4404     SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
4405         ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
4406                             "package or object reference", SVfARG(meth)),
4407            (SV *)NULL)
4408         : *(PL_stack_base + TOPMARK + 1);
4409
4410     PERL_ARGS_ASSERT_OPMETHOD_STASH;
4411
4412     if (UNLIKELY(!sv))
4413        undefined:
4414         Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
4415                    SVfARG(meth));
4416
4417     if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
4418     else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
4419         stash = gv_stashsv(sv, GV_CACHE_ONLY);
4420         if (stash) return stash;
4421     }
4422
4423     if (SvROK(sv))
4424         ob = MUTABLE_SV(SvRV(sv));
4425     else if (!SvOK(sv)) goto undefined;
4426     else if (isGV_with_GP(sv)) {
4427         if (!GvIO(sv))
4428             Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
4429                              "without a package or object reference",
4430                               SVfARG(meth));
4431         ob = sv;
4432         if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
4433             assert(!LvTARGLEN(ob));
4434             ob = LvTARG(ob);
4435             assert(ob);
4436         }
4437         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
4438     }
4439     else {
4440         /* this isn't a reference */
4441         GV* iogv;
4442         STRLEN packlen;
4443         const char * const packname = SvPV_nomg_const(sv, packlen);
4444         const U32 packname_utf8 = SvUTF8(sv);
4445         stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
4446         if (stash) return stash;
4447
4448         if (!(iogv = gv_fetchpvn_flags(
4449                 packname, packlen, packname_utf8, SVt_PVIO
4450              )) ||
4451             !(ob=MUTABLE_SV(GvIO(iogv))))
4452         {
4453             /* this isn't the name of a filehandle either */
4454             if (!packlen)
4455             {
4456                 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
4457                                  "without a package or object reference",
4458                                   SVfARG(meth));
4459             }
4460             /* assume it's a package name */
4461             stash = gv_stashpvn(packname, packlen, packname_utf8);
4462             if (stash) return stash;
4463             else return MUTABLE_HV(sv);
4464         }
4465         /* it _is_ a filehandle name -- replace with a reference */
4466         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
4467     }
4468
4469     /* if we got here, ob should be an object or a glob */
4470     if (!ob || !(SvOBJECT(ob)
4471                  || (isGV_with_GP(ob)
4472                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
4473                      && SvOBJECT(ob))))
4474     {
4475         Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
4476                    SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
4477                                         ? newSVpvs_flags("DOES", SVs_TEMP)
4478                                         : meth));
4479     }
4480
4481     return SvSTASH(ob);
4482 }
4483
4484 PP(pp_method)
4485 {
4486     dSP;
4487     GV* gv;
4488     HV* stash;
4489     SV* const meth = TOPs;
4490
4491     if (SvROK(meth)) {
4492         SV* const rmeth = SvRV(meth);
4493         if (SvTYPE(rmeth) == SVt_PVCV) {
4494             SETs(rmeth);
4495             RETURN;
4496         }
4497     }
4498
4499     stash = opmethod_stash(meth);
4500
4501     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
4502     assert(gv);
4503
4504     SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4505     RETURN;
4506 }
4507
4508 #define METHOD_CHECK_CACHE(stash,cache,meth)                            \
4509     const HE* const he = hv_fetch_ent(cache, meth, 0, 0);               \
4510     if (he) {                                                           \
4511         gv = MUTABLE_GV(HeVAL(he));                                     \
4512         if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv)        \
4513              == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))     \
4514         {                                                               \
4515             XPUSHs(MUTABLE_SV(GvCV(gv)));                               \
4516             RETURN;                                                     \
4517         }                                                               \
4518     }                                                                   \
4519
4520 PP(pp_method_named)
4521 {
4522     dSP;
4523     GV* gv;
4524     SV* const meth = cMETHOPx_meth(PL_op);
4525     HV* const stash = opmethod_stash(meth);
4526
4527     if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
4528         METHOD_CHECK_CACHE(stash, stash, meth);
4529     }
4530
4531     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
4532     assert(gv);
4533
4534     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4535     RETURN;
4536 }
4537
4538 PP(pp_method_super)
4539 {
4540     dSP;
4541     GV* gv;
4542     HV* cache;
4543     SV* const meth = cMETHOPx_meth(PL_op);
4544     HV* const stash = CopSTASH(PL_curcop);
4545     /* Actually, SUPER doesn't need real object's (or class') stash at all,
4546      * as it uses CopSTASH. However, we must ensure that object(class) is
4547      * correct (this check is done by S_opmethod_stash) */
4548     opmethod_stash(meth);
4549
4550     if ((cache = HvMROMETA(stash)->super)) {
4551         METHOD_CHECK_CACHE(stash, cache, meth);
4552     }
4553
4554     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
4555     assert(gv);
4556
4557     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4558     RETURN;
4559 }
4560
4561 PP(pp_method_redir)
4562 {
4563     dSP;
4564     GV* gv;
4565     SV* const meth = cMETHOPx_meth(PL_op);
4566     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
4567     opmethod_stash(meth); /* not used but needed for error checks */
4568
4569     if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
4570     else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
4571
4572     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
4573     assert(gv);
4574
4575     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4576     RETURN;
4577 }
4578
4579 PP(pp_method_redir_super)
4580 {
4581     dSP;
4582     GV* gv;
4583     HV* cache;
4584     SV* const meth = cMETHOPx_meth(PL_op);
4585     HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
4586     opmethod_stash(meth); /* not used but needed for error checks */
4587
4588     if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
4589     else if ((cache = HvMROMETA(stash)->super)) {
4590          METHOD_CHECK_CACHE(stash, cache, meth);
4591     }
4592
4593     gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
4594     assert(gv);
4595
4596     XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4597     RETURN;
4598 }
4599
4600 /*
4601  * ex: set ts=8 sts=4 sw=4 et:
4602  */