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