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