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