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