pp.c

   1 /*    pp.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  * 'It's a big house this, and very peculiar.  Always a bit more
  13  *  to discover, and no knowing what you'll find round a corner.
  14  *  And Elves, sir!'                            --Samwise Gamgee
  15  *
  16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
  17  */
  18
  19 /* This file contains general pp ("push/pop") functions that execute the
  20  * opcodes that make up a perl program. A typical pp function expects to
  21  * find its arguments on the stack, and usually pushes its results onto
  22  * the stack, hence the 'pp' terminology. Each OP structure contains
  23  * a pointer to the relevant pp_foo() function.
  24  */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_PP_C
  28 #include "perl.h"
  29 #include "keywords.h"
  30
  31 #include "reentr.h"
  32 #include "regcharclass.h"
  33
  34 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
  35 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
  36
  37 /* variations on pp_null */
  38
  39 PP(pp_stub)
  40 {
  41     dSP;
  42     if (GIMME_V == G_SCALAR)
  43         XPUSHs(&PL_sv_undef);
  44     RETURN;
  45 }
  46
  47 /* Pushy stuff. */
  48
  49
  50
  51 PP(pp_padcv)
  52 {
  53     dSP; dTARGET;
  54     assert(SvTYPE(TARG) == SVt_PVCV);
  55     XPUSHs(TARG);
  56     RETURN;
  57 }
  58
  59 PP(pp_introcv)
  60 {
  61     dTARGET;
  62     SvPADSTALE_off(TARG);
  63     return NORMAL;
  64 }
  65
  66 PP(pp_clonecv)
  67 {
  68     dTARGET;
  69     CV * const protocv = PadnamePROTOCV(
  70         PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
  71     );
  72     assert(SvTYPE(TARG) == SVt_PVCV);
  73     assert(protocv);
  74     if (CvISXSUB(protocv)) { /* constant */
  75         /* XXX Should we clone it here? */
  76         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
  77            to introcv and remove the SvPADSTALE_off. */
  78         SAVEPADSVANDMORTALIZE(ARGTARG);
  79         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
  80     }
  81     else {
  82         if (CvROOT(protocv)) {
  83             assert(CvCLONE(protocv));
  84             assert(!CvCLONED(protocv));
  85         }
  86         cv_clone_into(protocv,(CV *)TARG);
  87         SAVECLEARSV(PAD_SVl(ARGTARG));
  88     }
  89     return NORMAL;
  90 }
  91
  92 /* Translations. */
  93
  94 /* In some cases this function inspects PL_op.  If this function is called
  95    for new op types, more bool parameters may need to be added in place of
  96    the checks.
  97
  98    When noinit is true, the absence of a gv will cause a retval of undef.
  99    This is unrelated to the cv-to-gv assignment case.
 100 */
 101
 102 static SV *
 103 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
 104               const bool noinit)
 105 {
 106     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
 107     if (SvROK(sv)) {
 108         if (SvAMAGIC(sv)) {
 109             sv = amagic_deref_call(sv, to_gv_amg);
 110         }
 111       wasref:
 112         sv = SvRV(sv);
 113         if (SvTYPE(sv) == SVt_PVIO) {
 114             GV * const gv = MUTABLE_GV(sv_newmortal());
 115             gv_init(gv, 0, "__ANONIO__", 10, 0);
 116             GvIOp(gv) = MUTABLE_IO(sv);
 117             SvREFCNT_inc_void_NN(sv);
 118             sv = MUTABLE_SV(gv);
 119         }
 120         else if (!isGV_with_GP(sv)) {
 121             Perl_die(aTHX_ "Not a GLOB reference");
 122         }
 123     }
 124     else {
 125         if (!isGV_with_GP(sv)) {
 126             if (!SvOK(sv)) {
 127                 /* If this is a 'my' scalar and flag is set then vivify
 128                  * NI-S 1999/05/07
 129                  */
 130                 if (vivify_sv && sv != &PL_sv_undef) {
 131                     GV *gv;
 132                     if (SvREADONLY(sv))
 133                         Perl_croak_no_modify();
 134                     if (cUNOP->op_targ) {
 135                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 136                         HV *stash = CopSTASH(PL_curcop);
 137                         if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
 138                         gv = MUTABLE_GV(newSV(0));
 139                         gv_init_sv(gv, stash, namesv, 0);
 140                     }
 141                     else {
 142                         const char * const name = CopSTASHPV(PL_curcop);
 143                         gv = newGVgen_flags(name,
 144                                 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
 145                         SvREFCNT_inc_simple_void_NN(gv);
 146                     }
 147                     prepare_SV_for_RV(sv);
 148                     SvRV_set(sv, MUTABLE_SV(gv));
 149                     SvROK_on(sv);
 150                     SvSETMAGIC(sv);
 151                     goto wasref;
 152                 }
 153                 if (PL_op->op_flags & OPf_REF || strict) {
 154                     Perl_die(aTHX_ PL_no_usym, "a symbol");
 155                 }
 156                 if (ckWARN(WARN_UNINITIALIZED))
 157                     report_uninit(sv);
 158                 return &PL_sv_undef;
 159             }
 160             if (noinit)
 161             {
 162                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
 163                            sv, GV_ADDMG, SVt_PVGV
 164                    ))))
 165                     return &PL_sv_undef;
 166             }
 167             else {
 168                 if (strict) {
 169                     Perl_die(aTHX_
 170                              PL_no_symref_sv,
 171                              sv,
 172                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
 173                              "a symbol"
 174                              );
 175                 }
 176                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 177                     == OPpDONT_INIT_GV) {
 178                     /* We are the target of a coderef assignment.  Return
 179                        the scalar unchanged, and let pp_sasssign deal with
 180                        things.  */
 181                     return sv;
 182                 }
 183                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
 184             }
 185             /* FAKE globs in the symbol table cause weird bugs (#77810) */
 186             SvFAKE_off(sv);
 187         }
 188     }
 189     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
 190         SV *newsv = sv_newmortal();
 191         sv_setsv_flags(newsv, sv, 0);
 192         SvFAKE_off(newsv);
 193         sv = newsv;
 194     }
 195     return sv;
 196 }
 197
 198 PP(pp_rv2gv)
 199 {
 200     dSP; dTOPss;
 201
 202     sv = S_rv2gv(aTHX_
 203           sv, PL_op->op_private & OPpDEREF,
 204           PL_op->op_private & HINT_STRICT_REFS,
 205           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
 206              || PL_op->op_type == OP_READLINE
 207          );
 208     if (PL_op->op_private & OPpLVAL_INTRO)
 209         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 210     SETs(sv);
 211     RETURN;
 212 }
 213
 214 /* Helper function for pp_rv2sv and pp_rv2av  */
 215 GV *
 216 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 217                 const svtype type, SV ***spp)
 218 {
 219     GV *gv;
 220
 221     PERL_ARGS_ASSERT_SOFTREF2XV;
 222
 223     if (PL_op->op_private & HINT_STRICT_REFS) {
 224         if (SvOK(sv))
 225             Perl_die(aTHX_ PL_no_symref_sv, sv,
 226                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 227         else
 228             Perl_die(aTHX_ PL_no_usym, what);
 229     }
 230     if (!SvOK(sv)) {
 231         if (
 232           PL_op->op_flags & OPf_REF
 233         )
 234             Perl_die(aTHX_ PL_no_usym, what);
 235         if (ckWARN(WARN_UNINITIALIZED))
 236             report_uninit(sv);
 237         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 238             (*spp)--;
 239             return NULL;
 240         }
 241         **spp = &PL_sv_undef;
 242         return NULL;
 243     }
 244     if ((PL_op->op_flags & OPf_SPECIAL) &&
 245         !(PL_op->op_flags & OPf_MOD))
 246         {
 247             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
 248                 {
 249                     **spp = &PL_sv_undef;
 250                     return NULL;
 251                 }
 252         }
 253     else {
 254         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
 255     }
 256     return gv;
 257 }
 258
 259 PP(pp_rv2sv)
 260 {
 261     dSP; dTOPss;
 262     GV *gv = NULL;
 263
 264     SvGETMAGIC(sv);
 265     if (SvROK(sv)) {
 266         if (SvAMAGIC(sv)) {
 267             sv = amagic_deref_call(sv, to_sv_amg);
 268         }
 269
 270         sv = SvRV(sv);
 271         if (SvTYPE(sv) >= SVt_PVAV)
 272             DIE(aTHX_ "Not a SCALAR reference");
 273     }
 274     else {
 275         gv = MUTABLE_GV(sv);
 276
 277         if (!isGV_with_GP(gv)) {
 278             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 279             if (!gv)
 280                 RETURN;
 281         }
 282         sv = GvSVn(gv);
 283     }
 284     if (PL_op->op_flags & OPf_MOD) {
 285         if (PL_op->op_private & OPpLVAL_INTRO) {
 286             if (cUNOP->op_first->op_type == OP_NULL)
 287                 sv = save_scalar(MUTABLE_GV(TOPs));
 288             else if (gv)
 289                 sv = save_scalar(gv);
 290             else
 291                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 292         }
 293         else if (PL_op->op_private & OPpDEREF)
 294             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
 295     }
 296     SPAGAIN; /* in case chasing soft refs reallocated the stack */
 297     SETs(sv);
 298     RETURN;
 299 }
 300
 301 PP(pp_av2arylen)
 302 {
 303     dSP;
 304     AV * const av = MUTABLE_AV(TOPs);
 305     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 306     if (lvalue) {
 307         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 308         if (!*svp) {
 309             *svp = newSV_type(SVt_PVMG);
 310             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 311         }
 312         SETs(*svp);
 313     } else {
 314         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
 315     }
 316     RETURN;
 317 }
 318
 319 PP(pp_pos)
 320 {
 321     dSP; dTOPss;
 322
 323     if (PL_op->op_flags & OPf_MOD || LVRET) {
 324         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
 325         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
 326         LvTYPE(ret) = '.';
 327         LvTARG(ret) = SvREFCNT_inc_simple(sv);
 328         SETs(ret);    /* no SvSETMAGIC */
 329     }
 330     else {
 331             const MAGIC * const mg = mg_find_mglob(sv);
 332             if (mg && mg->mg_len != -1) {
 333                 STRLEN i = mg->mg_len;
 334                 if (PL_op->op_private & OPpTRUEBOOL)
 335                     SETs(i ? &PL_sv_yes : &PL_sv_zero);
 336                 else {
 337                     dTARGET;
 338                     if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
 339                         i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
 340                     SETu(i);
 341                 }
 342                 return NORMAL;
 343             }
 344             SETs(&PL_sv_undef);
 345     }
 346     return NORMAL;
 347 }
 348
 349 PP(pp_rv2cv)
 350 {
 351     dSP;
 352     GV *gv;
 353     HV *stash_unused;
 354     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 355         ? GV_ADDMG
 356         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
 357                                                     == OPpMAY_RETURN_CONSTANT)
 358             ? GV_ADD|GV_NOEXPAND
 359             : GV_ADD;
 360     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 361     /* (But not in defined().) */
 362
 363     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 364     if (cv) NOOP;
 365     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 366         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
 367             ? MUTABLE_CV(SvRV(gv))
 368             : MUTABLE_CV(gv);
 369     }
 370     else
 371         cv = MUTABLE_CV(&PL_sv_undef);
 372     SETs(MUTABLE_SV(cv));
 373     return NORMAL;
 374 }
 375
 376 PP(pp_prototype)
 377 {
 378     dSP;
 379     CV *cv;
 380     HV *stash;
 381     GV *gv;
 382     SV *ret = &PL_sv_undef;
 383
 384     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
 385     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 386         const char * s = SvPVX_const(TOPs);
 387         if (strnEQ(s, "CORE::", 6)) {
 388             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 389             if (!code)
 390                 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
 391                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
 392             {
 393                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
 394                 if (sv) ret = sv;
 395             }
 396             goto set;
 397         }
 398     }
 399     cv = sv_2cv(TOPs, &stash, &gv, 0);
 400     if (cv && SvPOK(cv))
 401         ret = newSVpvn_flags(
 402             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
 403         );
 404   set:
 405     SETs(ret);
 406     RETURN;
 407 }
 408
 409 PP(pp_anoncode)
 410 {
 411     dSP;
 412     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 413     if (CvCLONE(cv))
 414         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 415     EXTEND(SP,1);
 416     PUSHs(MUTABLE_SV(cv));
 417     RETURN;
 418 }
 419
 420 PP(pp_srefgen)
 421 {
 422     dSP;
 423     *SP = refto(*SP);
 424     return NORMAL;
 425 }
 426
 427 PP(pp_refgen)
 428 {
 429     dSP; dMARK;
 430     if (GIMME_V != G_ARRAY) {
 431         if (++MARK <= SP)
 432             *MARK = *SP;
 433         else
 434         {
 435             MEXTEND(SP, 1);
 436             *MARK = &PL_sv_undef;
 437         }
 438         *MARK = refto(*MARK);
 439         SP = MARK;
 440         RETURN;
 441     }
 442     EXTEND_MORTAL(SP - MARK);
 443     while (++MARK <= SP)
 444         *MARK = refto(*MARK);
 445     RETURN;
 446 }
 447
 448 STATIC SV*
 449 S_refto(pTHX_ SV *sv)
 450 {
 451     SV* rv;
 452
 453     PERL_ARGS_ASSERT_REFTO;
 454
 455     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 456         if (LvTARGLEN(sv))
 457             vivify_defelem(sv);
 458         if (!(sv = LvTARG(sv)))
 459             sv = &PL_sv_undef;
 460         else
 461             SvREFCNT_inc_void_NN(sv);
 462     }
 463     else if (SvTYPE(sv) == SVt_PVAV) {
 464         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 465             av_reify(MUTABLE_AV(sv));
 466         SvTEMP_off(sv);
 467         SvREFCNT_inc_void_NN(sv);
 468     }
 469     else if (SvPADTMP(sv)) {
 470         sv = newSVsv(sv);
 471     }
 472     else {
 473         SvTEMP_off(sv);
 474         SvREFCNT_inc_void_NN(sv);
 475     }
 476     rv = sv_newmortal();
 477     sv_upgrade(rv, SVt_IV);
 478     SvRV_set(rv, sv);
 479     SvROK_on(rv);
 480     return rv;
 481 }
 482
 483 PP(pp_ref)
 484 {
 485     dSP;
 486     SV * const sv = TOPs;
 487
 488     SvGETMAGIC(sv);
 489     if (!SvROK(sv)) {
 490         SETs(&PL_sv_no);
 491         return NORMAL;
 492     }
 493
 494     /* op is in boolean context? */
 495     if (   (PL_op->op_private & OPpTRUEBOOL)
 496         || (   (PL_op->op_private & OPpMAYBE_TRUEBOOL)
 497             && block_gimme() == G_VOID))
 498     {
 499         /* refs are always true - unless it's to an object blessed into a
 500          * class with a false name, i.e. "0". So we have to check for
 501          * that remote possibility. The following is is basically an
 502          * unrolled SvTRUE(sv_reftype(rv)) */
 503         SV * const rv = SvRV(sv);
 504         if (SvOBJECT(rv)) {
 505             HV *stash = SvSTASH(rv);
 506             HEK *hek = HvNAME_HEK(stash);
 507             if (hek) {
 508                 I32 len = HEK_LEN(hek);
 509                 /* bail out and do it the hard way? */
 510                 if (UNLIKELY(
 511                        len == HEf_SVKEY
 512                     || (len == 1 && HEK_KEY(hek)[0] == '0')
 513                 ))
 514                     goto do_sv_ref;
 515             }
 516         }
 517         SETs(&PL_sv_yes);
 518         return NORMAL;
 519     }
 520
 521   do_sv_ref:
 522     {
 523         dTARGET;
 524         SETs(TARG);
 525         sv_ref(TARG, SvRV(sv), TRUE);
 526         SvSETMAGIC(TARG);
 527         return NORMAL;
 528     }
 529
 530 }
 531
 532
 533 PP(pp_bless)
 534 {
 535     dSP;
 536     HV *stash;
 537
 538     if (MAXARG == 1)
 539     {
 540       curstash:
 541         stash = CopSTASH(PL_curcop);
 542         if (SvTYPE(stash) != SVt_PVHV)
 543             Perl_croak(aTHX_ "Attempt to bless into a freed package");
 544     }
 545     else {
 546         SV * const ssv = POPs;
 547         STRLEN len;
 548         const char *ptr;
 549
 550         if (!ssv) goto curstash;
 551         SvGETMAGIC(ssv);
 552         if (SvROK(ssv)) {
 553           if (!SvAMAGIC(ssv)) {
 554            frog:
 555             Perl_croak(aTHX_ "Attempt to bless into a reference");
 556           }
 557           /* SvAMAGIC is on here, but it only means potentially overloaded,
 558              so after stringification: */
 559           ptr = SvPV_nomg_const(ssv,len);
 560           /* We need to check the flag again: */
 561           if (!SvAMAGIC(ssv)) goto frog;
 562         }
 563         else ptr = SvPV_nomg_const(ssv,len);
 564         if (len == 0)
 565             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 566                            "Explicit blessing to '' (assuming package main)");
 567         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
 568     }
 569
 570     (void)sv_bless(TOPs, stash);
 571     RETURN;
 572 }
 573
 574 PP(pp_gelem)
 575 {
 576     dSP;
 577
 578     SV *sv = POPs;
 579     STRLEN len;
 580     const char * const elem = SvPV_const(sv, len);
 581     GV * const gv = MUTABLE_GV(TOPs);
 582     SV * tmpRef = NULL;
 583
 584     sv = NULL;
 585     if (elem) {
 586         /* elem will always be NUL terminated.  */
 587         switch (*elem) {
 588         case 'A':
 589             if (memEQs(elem, len, "ARRAY"))
 590             {
 591                 tmpRef = MUTABLE_SV(GvAV(gv));
 592                 if (tmpRef && !AvREAL((const AV *)tmpRef)
 593                  && AvREIFY((const AV *)tmpRef))
 594                     av_reify(MUTABLE_AV(tmpRef));
 595             }
 596             break;
 597         case 'C':
 598             if (memEQs(elem, len, "CODE"))
 599                 tmpRef = MUTABLE_SV(GvCVu(gv));
 600             break;
 601         case 'F':
 602             if (memEQs(elem, len, "FILEHANDLE")) {
 603                 tmpRef = MUTABLE_SV(GvIOp(gv));
 604             }
 605             else
 606                 if (memEQs(elem, len, "FORMAT"))
 607                     tmpRef = MUTABLE_SV(GvFORM(gv));
 608             break;
 609         case 'G':
 610             if (memEQs(elem, len, "GLOB"))
 611                 tmpRef = MUTABLE_SV(gv);
 612             break;
 613         case 'H':
 614             if (memEQs(elem, len, "HASH"))
 615                 tmpRef = MUTABLE_SV(GvHV(gv));
 616             break;
 617         case 'I':
 618             if (memEQs(elem, len, "IO"))
 619                 tmpRef = MUTABLE_SV(GvIOp(gv));
 620             break;
 621         case 'N':
 622             if (memEQs(elem, len, "NAME"))
 623                 sv = newSVhek(GvNAME_HEK(gv));
 624             break;
 625         case 'P':
 626             if (memEQs(elem, len, "PACKAGE")) {
 627                 const HV * const stash = GvSTASH(gv);
 628                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 629                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 630             }
 631             break;
 632         case 'S':
 633             if (memEQs(elem, len, "SCALAR"))
 634                 tmpRef = GvSVn(gv);
 635             break;
 636         }
 637     }
 638     if (tmpRef)
 639         sv = newRV(tmpRef);
 640     if (sv)
 641         sv_2mortal(sv);
 642     else
 643         sv = &PL_sv_undef;
 644     SETs(sv);
 645     RETURN;
 646 }
 647
 648 /* Pattern matching */
 649
 650 PP(pp_study)
 651 {
 652     dSP; dTOPss;
 653     STRLEN len;
 654
 655     (void)SvPV(sv, len);
 656     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
 657         /* Historically, study was skipped in these cases. */
 658         SETs(&PL_sv_no);
 659         return NORMAL;
 660     }
 661
 662     /* Make study a no-op. It's no longer useful and its existence
 663        complicates matters elsewhere. */
 664     SETs(&PL_sv_yes);
 665     return NORMAL;
 666 }
 667
 668
 669 /* also used for: pp_transr() */
 670
 671 PP(pp_trans)
 672 {
 673     dSP;
 674     SV *sv;
 675
 676     if (PL_op->op_flags & OPf_STACKED)
 677         sv = POPs;
 678     else {
 679         EXTEND(SP,1);
 680         if (ARGTARG)
 681             sv = PAD_SV(ARGTARG);
 682         else {
 683             sv = DEFSV;
 684         }
 685     }
 686     if(PL_op->op_type == OP_TRANSR) {
 687         STRLEN len;
 688         const char * const pv = SvPV(sv,len);
 689         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
 690         do_trans(newsv);
 691         PUSHs(newsv);
 692     }
 693     else {
 694         I32 i = do_trans(sv);
 695         mPUSHi(i);
 696     }
 697     RETURN;
 698 }
 699
 700 /* Lvalue operators. */
 701
 702 static size_t
 703 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 704 {
 705     STRLEN len;
 706     char *s;
 707     size_t count = 0;
 708
 709     PERL_ARGS_ASSERT_DO_CHOMP;
 710
 711     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
 712         return 0;
 713     if (SvTYPE(sv) == SVt_PVAV) {
 714         I32 i;
 715         AV *const av = MUTABLE_AV(sv);
 716         const I32 max = AvFILL(av);
 717
 718         for (i = 0; i <= max; i++) {
 719             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
 720             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 721                 count += do_chomp(retval, sv, chomping);
 722         }
 723         return count;
 724     }
 725     else if (SvTYPE(sv) == SVt_PVHV) {
 726         HV* const hv = MUTABLE_HV(sv);
 727         HE* entry;
 728         (void)hv_iterinit(hv);
 729         while ((entry = hv_iternext(hv)))
 730             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
 731         return count;
 732     }
 733     else if (SvREADONLY(sv)) {
 734             Perl_croak_no_modify();
 735     }
 736
 737     s = SvPV(sv, len);
 738     if (chomping) {
 739         if (s && len) {
 740             char *temp_buffer = NULL;
 741             SV *svrecode = NULL;
 742             s += --len;
 743             if (RsPARA(PL_rs)) {
 744                 if (*s != '\n')
 745                     goto nope_free_nothing;
 746                 ++count;
 747                 while (len && s[-1] == '\n') {
 748                     --len;
 749                     --s;
 750                     ++count;
 751                 }
 752             }
 753             else {
 754                 STRLEN rslen, rs_charlen;
 755                 const char *rsptr = SvPV_const(PL_rs, rslen);
 756
 757                 rs_charlen = SvUTF8(PL_rs)
 758                     ? sv_len_utf8(PL_rs)
 759                     : rslen;
 760
 761                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
 762                     /* Assumption is that rs is shorter than the scalar.  */
 763                     if (SvUTF8(PL_rs)) {
 764                         /* RS is utf8, scalar is 8 bit.  */
 765                         bool is_utf8 = TRUE;
 766                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
 767                                                              &rslen, &is_utf8);
 768                         if (is_utf8) {
 769                             /* Cannot downgrade, therefore cannot possibly match.
 770                                At this point, temp_buffer is not alloced, and
 771                                is the buffer inside PL_rs, so dont free it.
 772                              */
 773                             assert (temp_buffer == rsptr);
 774                             goto nope_free_sv;
 775                         }
 776                         rsptr = temp_buffer;
 777                     }
 778                     else {
 779                         /* RS is 8 bit, scalar is utf8.  */
 780                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
 781                         rsptr = temp_buffer;
 782                     }
 783                 }
 784                 if (rslen == 1) {
 785                     if (*s != *rsptr)
 786                         goto nope_free_all;
 787                     ++count;
 788                 }
 789                 else {
 790                     if (len < rslen - 1)
 791                         goto nope_free_all;
 792                     len -= rslen - 1;
 793                     s -= rslen - 1;
 794                     if (memNE(s, rsptr, rslen))
 795                         goto nope_free_all;
 796                     count += rs_charlen;
 797                 }
 798             }
 799             SvPV_force_nomg_nolen(sv);
 800             SvCUR_set(sv, len);
 801             *SvEND(sv) = '\0';
 802             SvNIOK_off(sv);
 803             SvSETMAGIC(sv);
 804
 805             nope_free_all:
 806             Safefree(temp_buffer);
 807             nope_free_sv:
 808             SvREFCNT_dec(svrecode);
 809             nope_free_nothing: ;
 810         }
 811     } else {
 812         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
 813             s = SvPV_force_nomg(sv, len);
 814         if (DO_UTF8(sv)) {
 815             if (s && len) {
 816                 char * const send = s + len;
 817                 char * const start = s;
 818                 s = send - 1;
 819                 while (s > start && UTF8_IS_CONTINUATION(*s))
 820                     s--;
 821                 if (is_utf8_string((U8*)s, send - s)) {
 822                     sv_setpvn(retval, s, send - s);
 823                     *s = '\0';
 824                     SvCUR_set(sv, s - start);
 825                     SvNIOK_off(sv);
 826                     SvUTF8_on(retval);
 827                 }
 828             }
 829             else
 830                 SvPVCLEAR(retval);
 831         }
 832         else if (s && len) {
 833             s += --len;
 834             sv_setpvn(retval, s, 1);
 835             *s = '\0';
 836             SvCUR_set(sv, len);
 837             SvUTF8_off(sv);
 838             SvNIOK_off(sv);
 839         }
 840         else
 841             SvPVCLEAR(retval);
 842         SvSETMAGIC(sv);
 843     }
 844     return count;
 845 }
 846
 847
 848 /* also used for: pp_schomp() */
 849
 850 PP(pp_schop)
 851 {
 852     dSP; dTARGET;
 853     const bool chomping = PL_op->op_type == OP_SCHOMP;
 854
 855     const size_t count = do_chomp(TARG, TOPs, chomping);
 856     if (chomping)
 857         sv_setiv(TARG, count);
 858     SETTARG;
 859     return NORMAL;
 860 }
 861
 862
 863 /* also used for: pp_chomp() */
 864
 865 PP(pp_chop)
 866 {
 867     dSP; dMARK; dTARGET; dORIGMARK;
 868     const bool chomping = PL_op->op_type == OP_CHOMP;
 869     size_t count = 0;
 870
 871     while (MARK < SP)
 872         count += do_chomp(TARG, *++MARK, chomping);
 873     if (chomping)
 874         sv_setiv(TARG, count);
 875     SP = ORIGMARK;
 876     XPUSHTARG;
 877     RETURN;
 878 }
 879
 880 PP(pp_undef)
 881 {
 882     dSP;
 883     SV *sv;
 884
 885     if (!PL_op->op_private) {
 886         EXTEND(SP, 1);
 887         RETPUSHUNDEF;
 888     }
 889
 890     sv = TOPs;
 891     if (!sv)
 892     {
 893         SETs(&PL_sv_undef);
 894         return NORMAL;
 895     }
 896
 897     if (SvTHINKFIRST(sv))
 898         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
 899
 900     switch (SvTYPE(sv)) {
 901     case SVt_NULL:
 902         break;
 903     case SVt_PVAV:
 904         av_undef(MUTABLE_AV(sv));
 905         break;
 906     case SVt_PVHV:
 907         hv_undef(MUTABLE_HV(sv));
 908         break;
 909     case SVt_PVCV:
 910         if (cv_const_sv((const CV *)sv))
 911             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 912                           "Constant subroutine %" SVf " undefined",
 913                            SVfARG(CvANON((const CV *)sv)
 914                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
 915                              : sv_2mortal(newSVhek(
 916                                 CvNAMED(sv)
 917                                  ? CvNAME_HEK((CV *)sv)
 918                                  : GvENAME_HEK(CvGV((const CV *)sv))
 919                                ))
 920                            ));
 921         /* FALLTHROUGH */
 922     case SVt_PVFM:
 923             /* let user-undef'd sub keep its identity */
 924         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
 925         break;
 926     case SVt_PVGV:
 927         assert(isGV_with_GP(sv));
 928         assert(!SvFAKE(sv));
 929         {
 930             GP *gp;
 931             HV *stash;
 932
 933             /* undef *Pkg::meth_name ... */
 934             bool method_changed
 935              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
 936               && HvENAME_get(stash);
 937             /* undef *Foo:: */
 938             if((stash = GvHV((const GV *)sv))) {
 939                 if(HvENAME_get(stash))
 940                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
 941                 else stash = NULL;
 942             }
 943
 944             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
 945             gp_free(MUTABLE_GV(sv));
 946             Newxz(gp, 1, GP);
 947             GvGP_set(sv, gp_ref(gp));
 948 #ifndef PERL_DONT_CREATE_GVSV
 949             GvSV(sv) = newSV(0);
 950 #endif
 951             GvLINE(sv) = CopLINE(PL_curcop);
 952             GvEGV(sv) = MUTABLE_GV(sv);
 953             GvMULTI_on(sv);
 954
 955             if(stash)
 956                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
 957             stash = NULL;
 958             /* undef *Foo::ISA */
 959             if( strEQ(GvNAME((const GV *)sv), "ISA")
 960              && (stash = GvSTASH((const GV *)sv))
 961              && (method_changed || HvENAME(stash)) )
 962                 mro_isa_changed_in(stash);
 963             else if(method_changed)
 964                 mro_method_changed_in(
 965                  GvSTASH((const GV *)sv)
 966                 );
 967
 968             break;
 969         }
 970     default:
 971         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 972             SvPV_free(sv);
 973             SvPV_set(sv, NULL);
 974             SvLEN_set(sv, 0);
 975         }
 976         SvOK_off(sv);
 977         SvSETMAGIC(sv);
 978     }
 979
 980     SETs(&PL_sv_undef);
 981     return NORMAL;
 982 }
 983
 984
 985 /* common "slow" code for pp_postinc and pp_postdec */
 986
 987 static OP *
 988 S_postincdec_common(pTHX_ SV *sv, SV *targ)
 989 {
 990     dSP;
 991     const bool inc =
 992         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
 993
 994     if (SvROK(sv))
 995         TARG = sv_newmortal();
 996     sv_setsv(TARG, sv);
 997     if (inc)
 998         sv_inc_nomg(sv);
 999     else
1000         sv_dec_nomg(sv);
1001     SvSETMAGIC(sv);
1002     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1003     if (inc && !SvOK(TARG))
1004         sv_setiv(TARG, 0);
1005     SETTARG;
1006     return NORMAL;
1007 }
1008
1009
1010 /* also used for: pp_i_postinc() */
1011
1012 PP(pp_postinc)
1013 {
1014     dSP; dTARGET;
1015     SV *sv = TOPs;
1016
1017     /* special-case sv being a simple integer */
1018     if (LIKELY(((sv->sv_flags &
1019                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1020                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1021                 == SVf_IOK))
1022         && SvIVX(sv) != IV_MAX)
1023     {
1024         IV iv = SvIVX(sv);
1025         SvIV_set(sv,  iv + 1);
1026         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1027         SETs(TARG);
1028         return NORMAL;
1029     }
1030
1031     return S_postincdec_common(aTHX_ sv, TARG);
1032 }
1033
1034
1035 /* also used for: pp_i_postdec() */
1036
1037 PP(pp_postdec)
1038 {
1039     dSP; dTARGET;
1040     SV *sv = TOPs;
1041
1042     /* special-case sv being a simple integer */
1043     if (LIKELY(((sv->sv_flags &
1044                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1045                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1046                 == SVf_IOK))
1047         && SvIVX(sv) != IV_MIN)
1048     {
1049         IV iv = SvIVX(sv);
1050         SvIV_set(sv,  iv - 1);
1051         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1052         SETs(TARG);
1053         return NORMAL;
1054     }
1055
1056     return S_postincdec_common(aTHX_ sv, TARG);
1057 }
1058
1059
1060 /* Ordinary operators. */
1061
1062 PP(pp_pow)
1063 {
1064     dSP; dATARGET; SV *svl, *svr;
1065 #ifdef PERL_PRESERVE_IVUV
1066     bool is_int = 0;
1067 #endif
1068     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1069     svr = TOPs;
1070     svl = TOPm1s;
1071 #ifdef PERL_PRESERVE_IVUV
1072     /* For integer to integer power, we do the calculation by hand wherever
1073        we're sure it is safe; otherwise we call pow() and try to convert to
1074        integer afterwards. */
1075     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1076                 UV power;
1077                 bool baseuok;
1078                 UV baseuv;
1079
1080                 if (SvUOK(svr)) {
1081                     power = SvUVX(svr);
1082                 } else {
1083                     const IV iv = SvIVX(svr);
1084                     if (iv >= 0) {
1085                         power = iv;
1086                     } else {
1087                         goto float_it; /* Can't do negative powers this way.  */
1088                     }
1089                 }
1090
1091                 baseuok = SvUOK(svl);
1092                 if (baseuok) {
1093                     baseuv = SvUVX(svl);
1094                 } else {
1095                     const IV iv = SvIVX(svl);
1096                     if (iv >= 0) {
1097                         baseuv = iv;
1098                         baseuok = TRUE; /* effectively it's a UV now */
1099                     } else {
1100                         baseuv = -iv; /* abs, baseuok == false records sign */
1101                     }
1102                 }
1103                 /* now we have integer ** positive integer. */
1104                 is_int = 1;
1105
1106                 /* foo & (foo - 1) is zero only for a power of 2.  */
1107                 if (!(baseuv & (baseuv - 1))) {
1108                     /* We are raising power-of-2 to a positive integer.
1109                        The logic here will work for any base (even non-integer
1110                        bases) but it can be less accurate than
1111                        pow (base,power) or exp (power * log (base)) when the
1112                        intermediate values start to spill out of the mantissa.
1113                        With powers of 2 we know this can't happen.
1114                        And powers of 2 are the favourite thing for perl
1115                        programmers to notice ** not doing what they mean. */
1116                     NV result = 1.0;
1117                     NV base = baseuok ? baseuv : -(NV)baseuv;
1118
1119                     if (power & 1) {
1120                         result *= base;
1121                     }
1122                     while (power >>= 1) {
1123                         base *= base;
1124                         if (power & 1) {
1125                             result *= base;
1126                         }
1127                     }
1128                     SP--;
1129                     SETn( result );
1130                     SvIV_please_nomg(svr);
1131                     RETURN;
1132                 } else {
1133                     unsigned int highbit = 8 * sizeof(UV);
1134                     unsigned int diff = 8 * sizeof(UV);
1135                     while (diff >>= 1) {
1136                         highbit -= diff;
1137                         if (baseuv >> highbit) {
1138                             highbit += diff;
1139                         }
1140                     }
1141                     /* we now have baseuv < 2 ** highbit */
1142                     if (power * highbit <= 8 * sizeof(UV)) {
1143                         /* result will definitely fit in UV, so use UV math
1144                            on same algorithm as above */
1145                         UV result = 1;
1146                         UV base = baseuv;
1147                         const bool odd_power = cBOOL(power & 1);
1148                         if (odd_power) {
1149                             result *= base;
1150                         }
1151                         while (power >>= 1) {
1152                             base *= base;
1153                             if (power & 1) {
1154                                 result *= base;
1155                             }
1156                         }
1157                         SP--;
1158                         if (baseuok || !odd_power)
1159                             /* answer is positive */
1160                             SETu( result );
1161                         else if (result <= (UV)IV_MAX)
1162                             /* answer negative, fits in IV */
1163                             SETi( -(IV)result );
1164                         else if (result == (UV)IV_MIN)
1165                             /* 2's complement assumption: special case IV_MIN */
1166                             SETi( IV_MIN );
1167                         else
1168                             /* answer negative, doesn't fit */
1169                             SETn( -(NV)result );
1170                         RETURN;
1171                     }
1172                 }
1173     }
1174   float_it:
1175 #endif
1176     {
1177         NV right = SvNV_nomg(svr);
1178         NV left  = SvNV_nomg(svl);
1179         (void)POPs;
1180
1181 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1182     /*
1183     We are building perl with long double support and are on an AIX OS
1184     afflicted with a powl() function that wrongly returns NaNQ for any
1185     negative base.  This was reported to IBM as PMR #23047-379 on
1186     03/06/2006.  The problem exists in at least the following versions
1187     of AIX and the libm fileset, and no doubt others as well:
1188
1189         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1190         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1191         AIX 5.2.0           bos.adt.libm 5.2.0.85
1192
1193     So, until IBM fixes powl(), we provide the following workaround to
1194     handle the problem ourselves.  Our logic is as follows: for
1195     negative bases (left), we use fmod(right, 2) to check if the
1196     exponent is an odd or even integer:
1197
1198         - if odd,  powl(left, right) == -powl(-left, right)
1199         - if even, powl(left, right) ==  powl(-left, right)
1200
1201     If the exponent is not an integer, the result is rightly NaNQ, so
1202     we just return that (as NV_NAN).
1203     */
1204
1205         if (left < 0.0) {
1206             NV mod2 = Perl_fmod( right, 2.0 );
1207             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1208                 SETn( -Perl_pow( -left, right) );
1209             } else if (mod2 == 0.0) {           /* even integer */
1210                 SETn( Perl_pow( -left, right) );
1211             } else {                            /* fractional power */
1212                 SETn( NV_NAN );
1213             }
1214         } else {
1215             SETn( Perl_pow( left, right) );
1216         }
1217 #else
1218         SETn( Perl_pow( left, right) );
1219 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1220
1221 #ifdef PERL_PRESERVE_IVUV
1222         if (is_int)
1223             SvIV_please_nomg(svr);
1224 #endif
1225         RETURN;
1226     }
1227 }
1228
1229 PP(pp_multiply)
1230 {
1231     dSP; dATARGET; SV *svl, *svr;
1232     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1233     svr = TOPs;
1234     svl = TOPm1s;
1235
1236 #ifdef PERL_PRESERVE_IVUV
1237
1238     /* special-case some simple common cases */
1239     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1240         IV il, ir;
1241         U32 flags = (svl->sv_flags & svr->sv_flags);
1242         if (flags & SVf_IOK) {
1243             /* both args are simple IVs */
1244             UV topl, topr;
1245             il = SvIVX(svl);
1246             ir = SvIVX(svr);
1247           do_iv:
1248             topl = ((UV)il) >> (UVSIZE * 4 - 1);
1249             topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1250
1251             /* if both are in a range that can't under/overflow, do a
1252              * simple integer multiply: if the top halves(*) of both numbers
1253              * are 00...00  or 11...11, then it's safe.
1254              * (*) for 32-bits, the "top half" is the top 17 bits,
1255              *     for 64-bits, its 33 bits */
1256             if (!(
1257                       ((topl+1) | (topr+1))
1258                     & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1259             )) {
1260                 SP--;
1261                 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1262                 SETs(TARG);
1263                 RETURN;
1264             }
1265             goto generic;
1266         }
1267         else if (flags & SVf_NOK) {
1268             /* both args are NVs */
1269             NV nl = SvNVX(svl);
1270             NV nr = SvNVX(svr);
1271             NV result;
1272
1273             if (
1274 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1275                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1276                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1277 #else
1278                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1279 #endif
1280                 )
1281                 /* nothing was lost by converting to IVs */
1282                 goto do_iv;
1283             SP--;
1284             result = nl * nr;
1285 #  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1286             if (Perl_isinf(result)) {
1287                 Zero((U8*)&result + 8, 8, U8);
1288             }
1289 #  endif
1290             TARGn(result, 0); /* args not GMG, so can't be tainted */
1291             SETs(TARG);
1292             RETURN;
1293         }
1294     }
1295
1296   generic:
1297
1298     if (SvIV_please_nomg(svr)) {
1299         /* Unless the left argument is integer in range we are going to have to
1300            use NV maths. Hence only attempt to coerce the right argument if
1301            we know the left is integer.  */
1302         /* Left operand is defined, so is it IV? */
1303         if (SvIV_please_nomg(svl)) {
1304             bool auvok = SvUOK(svl);
1305             bool buvok = SvUOK(svr);
1306             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1307             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1308             UV alow;
1309             UV ahigh;
1310             UV blow;
1311             UV bhigh;
1312
1313             if (auvok) {
1314                 alow = SvUVX(svl);
1315             } else {
1316                 const IV aiv = SvIVX(svl);
1317                 if (aiv >= 0) {
1318                     alow = aiv;
1319                     auvok = TRUE; /* effectively it's a UV now */
1320                 } else {
1321                     /* abs, auvok == false records sign */
1322                     alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1323                 }
1324             }
1325             if (buvok) {
1326                 blow = SvUVX(svr);
1327             } else {
1328                 const IV biv = SvIVX(svr);
1329                 if (biv >= 0) {
1330                     blow = biv;
1331                     buvok = TRUE; /* effectively it's a UV now */
1332                 } else {
1333                     /* abs, buvok == false records sign */
1334                     blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1335                 }
1336             }
1337
1338             /* If this does sign extension on unsigned it's time for plan B  */
1339             ahigh = alow >> (4 * sizeof (UV));
1340             alow &= botmask;
1341             bhigh = blow >> (4 * sizeof (UV));
1342             blow &= botmask;
1343             if (ahigh && bhigh) {
1344                 NOOP;
1345                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1346                    which is overflow. Drop to NVs below.  */
1347             } else if (!ahigh && !bhigh) {
1348                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1349                    so the unsigned multiply cannot overflow.  */
1350                 const UV product = alow * blow;
1351                 if (auvok == buvok) {
1352                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1353                     SP--;
1354                     SETu( product );
1355                     RETURN;
1356                 } else if (product <= (UV)IV_MIN) {
1357                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1358                     /* -ve result, which could overflow an IV  */
1359                     SP--;
1360                     /* can't negate IV_MIN, but there are aren't two
1361                      * integers such that !ahigh && !bhigh, where the
1362                      * product equals 0x800....000 */
1363                     assert(product != (UV)IV_MIN);
1364                     SETi( -(IV)product );
1365                     RETURN;
1366                 } /* else drop to NVs below. */
1367             } else {
1368                 /* One operand is large, 1 small */
1369                 UV product_middle;
1370                 if (bhigh) {
1371                     /* swap the operands */
1372                     ahigh = bhigh;
1373                     bhigh = blow; /* bhigh now the temp var for the swap */
1374                     blow = alow;
1375                     alow = bhigh;
1376                 }
1377                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1378                    multiplies can't overflow. shift can, add can, -ve can.  */
1379                 product_middle = ahigh * blow;
1380                 if (!(product_middle & topmask)) {
1381                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1382                     UV product_low;
1383                     product_middle <<= (4 * sizeof (UV));
1384                     product_low = alow * blow;
1385
1386                     /* as for pp_add, UV + something mustn't get smaller.
1387                        IIRC ANSI mandates this wrapping *behaviour* for
1388                        unsigned whatever the actual representation*/
1389                     product_low += product_middle;
1390                     if (product_low >= product_middle) {
1391                         /* didn't overflow */
1392                         if (auvok == buvok) {
1393                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1394                             SP--;
1395                             SETu( product_low );
1396                             RETURN;
1397                         } else if (product_low <= (UV)IV_MIN) {
1398                             /* 2s complement assumption again  */
1399                             /* -ve result, which could overflow an IV  */
1400                             SP--;
1401                             SETi(product_low == (UV)IV_MIN
1402                                     ? IV_MIN : -(IV)product_low);
1403                             RETURN;
1404                         } /* else drop to NVs below. */
1405                     }
1406                 } /* product_middle too large */
1407             } /* ahigh && bhigh */
1408         } /* SvIOK(svl) */
1409     } /* SvIOK(svr) */
1410 #endif
1411     {
1412       NV right = SvNV_nomg(svr);
1413       NV left  = SvNV_nomg(svl);
1414       NV result = left * right;
1415
1416       (void)POPs;
1417 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1418       if (Perl_isinf(result)) {
1419           Zero((U8*)&result + 8, 8, U8);
1420       }
1421 #endif
1422       SETn(result);
1423       RETURN;
1424     }
1425 }
1426
1427 PP(pp_divide)
1428 {
1429     dSP; dATARGET; SV *svl, *svr;
1430     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1431     svr = TOPs;
1432     svl = TOPm1s;
1433     /* Only try to do UV divide first
1434        if ((SLOPPYDIVIDE is true) or
1435            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1436             to preserve))
1437        The assumption is that it is better to use floating point divide
1438        whenever possible, only doing integer divide first if we can't be sure.
1439        If NV_PRESERVES_UV is true then we know at compile time that no UV
1440        can be too large to preserve, so don't need to compile the code to
1441        test the size of UVs.  */
1442
1443 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
1444 #  define PERL_TRY_UV_DIVIDE
1445     /* ensure that 20./5. == 4. */
1446 #endif
1447
1448 #ifdef PERL_TRY_UV_DIVIDE
1449     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1450             bool left_non_neg = SvUOK(svl);
1451             bool right_non_neg = SvUOK(svr);
1452             UV left;
1453             UV right;
1454
1455             if (right_non_neg) {
1456                 right = SvUVX(svr);
1457             }
1458             else {
1459                 const IV biv = SvIVX(svr);
1460                 if (biv >= 0) {
1461                     right = biv;
1462                     right_non_neg = TRUE; /* effectively it's a UV now */
1463                 }
1464                 else {
1465                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1466                 }
1467             }
1468             /* historically undef()/0 gives a "Use of uninitialized value"
1469                warning before dieing, hence this test goes here.
1470                If it were immediately before the second SvIV_please, then
1471                DIE() would be invoked before left was even inspected, so
1472                no inspection would give no warning.  */
1473             if (right == 0)
1474                 DIE(aTHX_ "Illegal division by zero");
1475
1476             if (left_non_neg) {
1477                 left = SvUVX(svl);
1478             }
1479             else {
1480                 const IV aiv = SvIVX(svl);
1481                 if (aiv >= 0) {
1482                     left = aiv;
1483                     left_non_neg = TRUE; /* effectively it's a UV now */
1484                 }
1485                 else {
1486                     left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1487                 }
1488             }
1489
1490             if (left >= right
1491 #ifdef SLOPPYDIVIDE
1492                 /* For sloppy divide we always attempt integer division.  */
1493 #else
1494                 /* Otherwise we only attempt it if either or both operands
1495                    would not be preserved by an NV.  If both fit in NVs
1496                    we fall through to the NV divide code below.  However,
1497                    as left >= right to ensure integer result here, we know that
1498                    we can skip the test on the right operand - right big
1499                    enough not to be preserved can't get here unless left is
1500                    also too big.  */
1501
1502                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1503 #endif
1504                 ) {
1505                 /* Integer division can't overflow, but it can be imprecise.  */
1506                 const UV result = left / right;
1507                 if (result * right == left) {
1508                     SP--; /* result is valid */
1509                     if (left_non_neg == right_non_neg) {
1510                         /* signs identical, result is positive.  */
1511                         SETu( result );
1512                         RETURN;
1513                     }
1514                     /* 2s complement assumption */
1515                     if (result <= (UV)IV_MIN)
1516                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1517                     else {
1518                         /* It's exact but too negative for IV. */
1519                         SETn( -(NV)result );
1520                     }
1521                     RETURN;
1522                 } /* tried integer divide but it was not an integer result */
1523             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1524     } /* one operand wasn't SvIOK */
1525 #endif /* PERL_TRY_UV_DIVIDE */
1526     {
1527         NV right = SvNV_nomg(svr);
1528         NV left  = SvNV_nomg(svl);
1529         (void)POPs;(void)POPs;
1530 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1531         if (! Perl_isnan(right) && right == 0.0)
1532 #else
1533         if (right == 0.0)
1534 #endif
1535             DIE(aTHX_ "Illegal division by zero");
1536         PUSHn( left / right );
1537         RETURN;
1538     }
1539 }
1540
1541 PP(pp_modulo)
1542 {
1543     dSP; dATARGET;
1544     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1545     {
1546         UV left  = 0;
1547         UV right = 0;
1548         bool left_neg = FALSE;
1549         bool right_neg = FALSE;
1550         bool use_double = FALSE;
1551         bool dright_valid = FALSE;
1552         NV dright = 0.0;
1553         NV dleft  = 0.0;
1554         SV * const svr = TOPs;
1555         SV * const svl = TOPm1s;
1556         if (SvIV_please_nomg(svr)) {
1557             right_neg = !SvUOK(svr);
1558             if (!right_neg) {
1559                 right = SvUVX(svr);
1560             } else {
1561                 const IV biv = SvIVX(svr);
1562                 if (biv >= 0) {
1563                     right = biv;
1564                     right_neg = FALSE; /* effectively it's a UV now */
1565                 } else {
1566                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1567                 }
1568             }
1569         }
1570         else {
1571             dright = SvNV_nomg(svr);
1572             right_neg = dright < 0;
1573             if (right_neg)
1574                 dright = -dright;
1575             if (dright < UV_MAX_P1) {
1576                 right = U_V(dright);
1577                 dright_valid = TRUE; /* In case we need to use double below.  */
1578             } else {
1579                 use_double = TRUE;
1580             }
1581         }
1582
1583         /* At this point use_double is only true if right is out of range for
1584            a UV.  In range NV has been rounded down to nearest UV and
1585            use_double false.  */
1586         if (!use_double && SvIV_please_nomg(svl)) {
1587                 left_neg = !SvUOK(svl);
1588                 if (!left_neg) {
1589                     left = SvUVX(svl);
1590                 } else {
1591                     const IV aiv = SvIVX(svl);
1592                     if (aiv >= 0) {
1593                         left = aiv;
1594                         left_neg = FALSE; /* effectively it's a UV now */
1595                     } else {
1596                         left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1597                     }
1598                 }
1599         }
1600         else {
1601             dleft = SvNV_nomg(svl);
1602             left_neg = dleft < 0;
1603             if (left_neg)
1604                 dleft = -dleft;
1605
1606             /* This should be exactly the 5.6 behaviour - if left and right are
1607                both in range for UV then use U_V() rather than floor.  */
1608             if (!use_double) {
1609                 if (dleft < UV_MAX_P1) {
1610                     /* right was in range, so is dleft, so use UVs not double.
1611                      */
1612                     left = U_V(dleft);
1613                 }
1614                 /* left is out of range for UV, right was in range, so promote
1615                    right (back) to double.  */
1616                 else {
1617                     /* The +0.5 is used in 5.6 even though it is not strictly
1618                        consistent with the implicit +0 floor in the U_V()
1619                        inside the #if 1. */
1620                     dleft = Perl_floor(dleft + 0.5);
1621                     use_double = TRUE;
1622                     if (dright_valid)
1623                         dright = Perl_floor(dright + 0.5);
1624                     else
1625                         dright = right;
1626                 }
1627             }
1628         }
1629         sp -= 2;
1630         if (use_double) {
1631             NV dans;
1632
1633             if (!dright)
1634                 DIE(aTHX_ "Illegal modulus zero");
1635
1636             dans = Perl_fmod(dleft, dright);
1637             if ((left_neg != right_neg) && dans)
1638                 dans = dright - dans;
1639             if (right_neg)
1640                 dans = -dans;
1641             sv_setnv(TARG, dans);
1642         }
1643         else {
1644             UV ans;
1645
1646             if (!right)
1647                 DIE(aTHX_ "Illegal modulus zero");
1648
1649             ans = left % right;
1650             if ((left_neg != right_neg) && ans)
1651                 ans = right - ans;
1652             if (right_neg) {
1653                 /* XXX may warn: unary minus operator applied to unsigned type */
1654                 /* could change -foo to be (~foo)+1 instead     */
1655                 if (ans <= ~((UV)IV_MAX)+1)
1656                     sv_setiv(TARG, ~ans+1);
1657                 else
1658                     sv_setnv(TARG, -(NV)ans);
1659             }
1660             else
1661                 sv_setuv(TARG, ans);
1662         }
1663         PUSHTARG;
1664         RETURN;
1665     }
1666 }
1667
1668 PP(pp_repeat)
1669 {
1670     dSP; dATARGET;
1671     IV count;
1672     SV *sv;
1673     bool infnan = FALSE;
1674
1675     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1676         /* TODO: think of some way of doing list-repeat overloading ??? */
1677         sv = POPs;
1678         SvGETMAGIC(sv);
1679     }
1680     else {
1681         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1682             /* The parser saw this as a list repeat, and there
1683                are probably several items on the stack. But we're
1684                in scalar/void context, and there's no pp_list to save us
1685                now. So drop the rest of the items -- robin@kitsite.com
1686              */
1687             dMARK;
1688             if (MARK + 1 < SP) {
1689                 MARK[1] = TOPm1s;
1690                 MARK[2] = TOPs;
1691             }
1692             else {
1693                 dTOPss;
1694                 ASSUME(MARK + 1 == SP);
1695                 XPUSHs(sv);
1696                 MARK[1] = &PL_sv_undef;
1697             }
1698             SP = MARK + 2;
1699         }
1700         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1701         sv = POPs;
1702     }
1703
1704     if (SvIOKp(sv)) {
1705          if (SvUOK(sv)) {
1706               const UV uv = SvUV_nomg(sv);
1707               if (uv > IV_MAX)
1708                    count = IV_MAX; /* The best we can do? */
1709               else
1710                    count = uv;
1711          } else {
1712               count = SvIV_nomg(sv);
1713          }
1714     }
1715     else if (SvNOKp(sv)) {
1716         const NV nv = SvNV_nomg(sv);
1717         infnan = Perl_isinfnan(nv);
1718         if (UNLIKELY(infnan)) {
1719             count = 0;
1720         } else {
1721             if (nv < 0.0)
1722                 count = -1;   /* An arbitrary negative integer */
1723             else
1724                 count = (IV)nv;
1725         }
1726     }
1727     else
1728         count = SvIV_nomg(sv);
1729
1730     if (infnan) {
1731         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1732                        "Non-finite repeat count does nothing");
1733     } else if (count < 0) {
1734         count = 0;
1735         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1736                        "Negative repeat count does nothing");
1737     }
1738
1739     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1740         dMARK;
1741         const SSize_t items = SP - MARK;
1742         const U8 mod = PL_op->op_flags & OPf_MOD;
1743
1744         if (count > 1) {
1745             SSize_t max;
1746
1747             if (  items > SSize_t_MAX / count   /* max would overflow */
1748                                                 /* repeatcpy would overflow */
1749                || items > I32_MAX / (I32)sizeof(SV *)
1750             )
1751                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1752             max = items * count;
1753             MEXTEND(MARK, max);
1754
1755             while (SP > MARK) {
1756                 if (*SP) {
1757                    if (mod && SvPADTMP(*SP)) {
1758                        *SP = sv_mortalcopy(*SP);
1759                    }
1760                    SvTEMP_off((*SP));
1761                 }
1762                 SP--;
1763             }
1764             MARK++;
1765             repeatcpy((char*)(MARK + items), (char*)MARK,
1766                 items * sizeof(const SV *), count - 1);
1767             SP += max;
1768         }
1769         else if (count <= 0)
1770             SP = MARK;
1771     }
1772     else {      /* Note: mark already snarfed by pp_list */
1773         SV * const tmpstr = POPs;
1774         STRLEN len;
1775         bool isutf;
1776
1777         if (TARG != tmpstr)
1778             sv_setsv_nomg(TARG, tmpstr);
1779         SvPV_force_nomg(TARG, len);
1780         isutf = DO_UTF8(TARG);
1781         if (count != 1) {
1782             if (count < 1)
1783                 SvCUR_set(TARG, 0);
1784             else {
1785                 STRLEN max;
1786
1787                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1788                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1789                 )
1790                      Perl_croak(aTHX_ "%s",
1791                                         "Out of memory during string extend");
1792                 max = (UV)count * len + 1;
1793                 SvGROW(TARG, max);
1794
1795                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1796                 SvCUR_set(TARG, SvCUR(TARG) * count);
1797             }
1798             *SvEND(TARG) = '\0';
1799         }
1800         if (isutf)
1801             (void)SvPOK_only_UTF8(TARG);
1802         else
1803             (void)SvPOK_only(TARG);
1804
1805         PUSHTARG;
1806     }
1807     RETURN;
1808 }
1809
1810 PP(pp_subtract)
1811 {
1812     dSP; dATARGET; bool useleft; SV *svl, *svr;
1813     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1814     svr = TOPs;
1815     svl = TOPm1s;
1816
1817 #ifdef PERL_PRESERVE_IVUV
1818
1819     /* special-case some simple common cases */
1820     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1821         IV il, ir;
1822         U32 flags = (svl->sv_flags & svr->sv_flags);
1823         if (flags & SVf_IOK) {
1824             /* both args are simple IVs */
1825             UV topl, topr;
1826             il = SvIVX(svl);
1827             ir = SvIVX(svr);
1828           do_iv:
1829             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1830             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1831
1832             /* if both are in a range that can't under/overflow, do a
1833              * simple integer subtract: if the top of both numbers
1834              * are 00  or 11, then it's safe */
1835             if (!( ((topl+1) | (topr+1)) & 2)) {
1836                 SP--;
1837                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1838                 SETs(TARG);
1839                 RETURN;
1840             }
1841             goto generic;
1842         }
1843         else if (flags & SVf_NOK) {
1844             /* both args are NVs */
1845             NV nl = SvNVX(svl);
1846             NV nr = SvNVX(svr);
1847
1848             if (
1849 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1850                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1851                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1852 #else
1853                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1854 #endif
1855                 )
1856                 /* nothing was lost by converting to IVs */
1857                 goto do_iv;
1858             SP--;
1859             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1860             SETs(TARG);
1861             RETURN;
1862         }
1863     }
1864
1865   generic:
1866
1867     useleft = USE_LEFT(svl);
1868     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1869        "bad things" happen if you rely on signed integers wrapping.  */
1870     if (SvIV_please_nomg(svr)) {
1871         /* Unless the left argument is integer in range we are going to have to
1872            use NV maths. Hence only attempt to coerce the right argument if
1873            we know the left is integer.  */
1874         UV auv = 0;
1875         bool auvok = FALSE;
1876         bool a_valid = 0;
1877
1878         if (!useleft) {
1879             auv = 0;
1880             a_valid = auvok = 1;
1881             /* left operand is undef, treat as zero.  */
1882         } else {
1883             /* Left operand is defined, so is it IV? */
1884             if (SvIV_please_nomg(svl)) {
1885                 if ((auvok = SvUOK(svl)))
1886                     auv = SvUVX(svl);
1887                 else {
1888                     const IV aiv = SvIVX(svl);
1889                     if (aiv >= 0) {
1890                         auv = aiv;
1891                         auvok = 1;      /* Now acting as a sign flag.  */
1892                     } else { /* 2s complement assumption for IV_MIN */
1893                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1894                     }
1895                 }
1896                 a_valid = 1;
1897             }
1898         }
1899         if (a_valid) {
1900             bool result_good = 0;
1901             UV result;
1902             UV buv;
1903             bool buvok = SvUOK(svr);
1904
1905             if (buvok)
1906                 buv = SvUVX(svr);
1907             else {
1908                 const IV biv = SvIVX(svr);
1909                 if (biv >= 0) {
1910                     buv = biv;
1911                     buvok = 1;
1912                 } else
1913                     buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
1914             }
1915             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1916                else "IV" now, independent of how it came in.
1917                if a, b represents positive, A, B negative, a maps to -A etc
1918                a - b =>  (a - b)
1919                A - b => -(a + b)
1920                a - B =>  (a + b)
1921                A - B => -(a - b)
1922                all UV maths. negate result if A negative.
1923                subtract if signs same, add if signs differ. */
1924
1925             if (auvok ^ buvok) {
1926                 /* Signs differ.  */
1927                 result = auv + buv;
1928                 if (result >= auv)
1929                     result_good = 1;
1930             } else {
1931                 /* Signs same */
1932                 if (auv >= buv) {
1933                     result = auv - buv;
1934                     /* Must get smaller */
1935                     if (result <= auv)
1936                         result_good = 1;
1937                 } else {
1938                     result = buv - auv;
1939                     if (result <= buv) {
1940                         /* result really should be -(auv-buv). as its negation
1941                            of true value, need to swap our result flag  */
1942                         auvok = !auvok;
1943                         result_good = 1;
1944                     }
1945                 }
1946             }
1947             if (result_good) {
1948                 SP--;
1949                 if (auvok)
1950                     SETu( result );
1951                 else {
1952                     /* Negate result */
1953                     if (result <= (UV)IV_MIN)
1954                         SETi(result == (UV)IV_MIN
1955                                 ? IV_MIN : -(IV)result);
1956                     else {
1957                         /* result valid, but out of range for IV.  */
1958                         SETn( -(NV)result );
1959                     }
1960                 }
1961                 RETURN;
1962             } /* Overflow, drop through to NVs.  */
1963         }
1964     }
1965 #else
1966     useleft = USE_LEFT(svl);
1967 #endif
1968     {
1969         NV value = SvNV_nomg(svr);
1970         (void)POPs;
1971
1972         if (!useleft) {
1973             /* left operand is undef, treat as zero - value */
1974             SETn(-value);
1975             RETURN;
1976         }
1977         SETn( SvNV_nomg(svl) - value );
1978         RETURN;
1979     }
1980 }
1981
1982 #define IV_BITS (IVSIZE * 8)
1983
1984 static UV S_uv_shift(UV uv, int shift, bool left)
1985 {
1986    if (shift < 0) {
1987        shift = -shift;
1988        left = !left;
1989    }
1990    if (shift >= IV_BITS) {
1991        return 0;
1992    }
1993    return left ? uv << shift : uv >> shift;
1994 }
1995
1996 static IV S_iv_shift(IV iv, int shift, bool left)
1997 {
1998    if (shift < 0) {
1999        shift = -shift;
2000        left = !left;
2001    }
2002    if (shift >= IV_BITS) {
2003        return iv < 0 && !left ? -1 : 0;
2004    }
2005    return left ? iv << shift : iv >> shift;
2006 }
2007
2008 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2009 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2010 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2011 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2012
2013 PP(pp_left_shift)
2014 {
2015     dSP; dATARGET; SV *svl, *svr;
2016     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2017     svr = POPs;
2018     svl = TOPs;
2019     {
2020       const IV shift = SvIV_nomg(svr);
2021       if (PL_op->op_private & HINT_INTEGER) {
2022           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2023       }
2024       else {
2025           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2026       }
2027       RETURN;
2028     }
2029 }
2030
2031 PP(pp_right_shift)
2032 {
2033     dSP; dATARGET; SV *svl, *svr;
2034     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2035     svr = POPs;
2036     svl = TOPs;
2037     {
2038       const IV shift = SvIV_nomg(svr);
2039       if (PL_op->op_private & HINT_INTEGER) {
2040           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2041       }
2042       else {
2043           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2044       }
2045       RETURN;
2046     }
2047 }
2048
2049 PP(pp_lt)
2050 {
2051     dSP;
2052     SV *left, *right;
2053
2054     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2055     right = POPs;
2056     left  = TOPs;
2057     SETs(boolSV(
2058         (SvIOK_notUV(left) && SvIOK_notUV(right))
2059         ? (SvIVX(left) < SvIVX(right))
2060         : (do_ncmp(left, right) == -1)
2061     ));
2062     RETURN;
2063 }
2064
2065 PP(pp_gt)
2066 {
2067     dSP;
2068     SV *left, *right;
2069
2070     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2071     right = POPs;
2072     left  = TOPs;
2073     SETs(boolSV(
2074         (SvIOK_notUV(left) && SvIOK_notUV(right))
2075         ? (SvIVX(left) > SvIVX(right))
2076         : (do_ncmp(left, right) == 1)
2077     ));
2078     RETURN;
2079 }
2080
2081 PP(pp_le)
2082 {
2083     dSP;
2084     SV *left, *right;
2085
2086     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2087     right = POPs;
2088     left  = TOPs;
2089     SETs(boolSV(
2090         (SvIOK_notUV(left) && SvIOK_notUV(right))
2091         ? (SvIVX(left) <= SvIVX(right))
2092         : (do_ncmp(left, right) <= 0)
2093     ));
2094     RETURN;
2095 }
2096
2097 PP(pp_ge)
2098 {
2099     dSP;
2100     SV *left, *right;
2101
2102     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2103     right = POPs;
2104     left  = TOPs;
2105     SETs(boolSV(
2106         (SvIOK_notUV(left) && SvIOK_notUV(right))
2107         ? (SvIVX(left) >= SvIVX(right))
2108         : ( (do_ncmp(left, right) & 2) == 0)
2109     ));
2110     RETURN;
2111 }
2112
2113 PP(pp_ne)
2114 {
2115     dSP;
2116     SV *left, *right;
2117
2118     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2119     right = POPs;
2120     left  = TOPs;
2121     SETs(boolSV(
2122         (SvIOK_notUV(left) && SvIOK_notUV(right))
2123         ? (SvIVX(left) != SvIVX(right))
2124         : (do_ncmp(left, right) != 0)
2125     ));
2126     RETURN;
2127 }
2128
2129 /* compare left and right SVs. Returns:
2130  * -1: <
2131  *  0: ==
2132  *  1: >
2133  *  2: left or right was a NaN
2134  */
2135 I32
2136 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2137 {
2138     PERL_ARGS_ASSERT_DO_NCMP;
2139 #ifdef PERL_PRESERVE_IVUV
2140     /* Fortunately it seems NaN isn't IOK */
2141     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2142             if (!SvUOK(left)) {
2143                 const IV leftiv = SvIVX(left);
2144                 if (!SvUOK(right)) {
2145                     /* ## IV <=> IV ## */
2146                     const IV rightiv = SvIVX(right);
2147                     return (leftiv > rightiv) - (leftiv < rightiv);
2148                 }
2149                 /* ## IV <=> UV ## */
2150                 if (leftiv < 0)
2151                     /* As (b) is a UV, it's >=0, so it must be < */
2152                     return -1;
2153                 {
2154                     const UV rightuv = SvUVX(right);
2155                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2156                 }
2157             }
2158
2159             if (SvUOK(right)) {
2160                 /* ## UV <=> UV ## */
2161                 const UV leftuv = SvUVX(left);
2162                 const UV rightuv = SvUVX(right);
2163                 return (leftuv > rightuv) - (leftuv < rightuv);
2164             }
2165             /* ## UV <=> IV ## */
2166             {
2167                 const IV rightiv = SvIVX(right);
2168                 if (rightiv < 0)
2169                     /* As (a) is a UV, it's >=0, so it cannot be < */
2170                     return 1;
2171                 {
2172                     const UV leftuv = SvUVX(left);
2173                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2174                 }
2175             }
2176             NOT_REACHED; /* NOTREACHED */
2177     }
2178 #endif
2179     {
2180       NV const rnv = SvNV_nomg(right);
2181       NV const lnv = SvNV_nomg(left);
2182
2183 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2184       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2185           return 2;
2186        }
2187       return (lnv > rnv) - (lnv < rnv);
2188 #else
2189       if (lnv < rnv)
2190         return -1;
2191       if (lnv > rnv)
2192         return 1;
2193       if (lnv == rnv)
2194         return 0;
2195       return 2;
2196 #endif
2197     }
2198 }
2199
2200
2201 PP(pp_ncmp)
2202 {
2203     dSP;
2204     SV *left, *right;
2205     I32 value;
2206     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2207     right = POPs;
2208     left  = TOPs;
2209     value = do_ncmp(left, right);
2210     if (value == 2) {
2211         SETs(&PL_sv_undef);
2212     }
2213     else {
2214         dTARGET;
2215         SETi(value);
2216     }
2217     RETURN;
2218 }
2219
2220
2221 /* also used for: pp_sge() pp_sgt() pp_slt() */
2222
2223 PP(pp_sle)
2224 {
2225     dSP;
2226
2227     int amg_type = sle_amg;
2228     int multiplier = 1;
2229     int rhs = 1;
2230
2231     switch (PL_op->op_type) {
2232     case OP_SLT:
2233         amg_type = slt_amg;
2234         /* cmp < 0 */
2235         rhs = 0;
2236         break;
2237     case OP_SGT:
2238         amg_type = sgt_amg;
2239         /* cmp > 0 */
2240         multiplier = -1;
2241         rhs = 0;
2242         break;
2243     case OP_SGE:
2244         amg_type = sge_amg;
2245         /* cmp >= 0 */
2246         multiplier = -1;
2247         break;
2248     }
2249
2250     tryAMAGICbin_MG(amg_type, AMGf_set);
2251     {
2252       dPOPTOPssrl;
2253       const int cmp =
2254 #ifdef USE_LOCALE_COLLATE
2255                       (IN_LC_RUNTIME(LC_COLLATE))
2256                       ? sv_cmp_locale_flags(left, right, 0)
2257                       :
2258 #endif
2259                         sv_cmp_flags(left, right, 0);
2260       SETs(boolSV(cmp * multiplier < rhs));
2261       RETURN;
2262     }
2263 }
2264
2265 PP(pp_seq)
2266 {
2267     dSP;
2268     tryAMAGICbin_MG(seq_amg, AMGf_set);
2269     {
2270       dPOPTOPssrl;
2271       SETs(boolSV(sv_eq_flags(left, right, 0)));
2272       RETURN;
2273     }
2274 }
2275
2276 PP(pp_sne)
2277 {
2278     dSP;
2279     tryAMAGICbin_MG(sne_amg, AMGf_set);
2280     {
2281       dPOPTOPssrl;
2282       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2283       RETURN;
2284     }
2285 }
2286
2287 PP(pp_scmp)
2288 {
2289     dSP; dTARGET;
2290     tryAMAGICbin_MG(scmp_amg, 0);
2291     {
2292       dPOPTOPssrl;
2293       const int cmp =
2294 #ifdef USE_LOCALE_COLLATE
2295                       (IN_LC_RUNTIME(LC_COLLATE))
2296                       ? sv_cmp_locale_flags(left, right, 0)
2297                       :
2298 #endif
2299                         sv_cmp_flags(left, right, 0);
2300       SETi( cmp );
2301       RETURN;
2302     }
2303 }
2304
2305 PP(pp_bit_and)
2306 {
2307     dSP; dATARGET;
2308     tryAMAGICbin_MG(band_amg, AMGf_assign);
2309     {
2310       dPOPTOPssrl;
2311       if (SvNIOKp(left) || SvNIOKp(right)) {
2312         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2313         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2314         if (PL_op->op_private & HINT_INTEGER) {
2315           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2316           SETi(i);
2317         }
2318         else {
2319           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2320           SETu(u);
2321         }
2322         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2323         if (right_ro_nonnum) SvNIOK_off(right);
2324       }
2325       else {
2326         do_vop(PL_op->op_type, TARG, left, right);
2327         SETTARG;
2328       }
2329       RETURN;
2330     }
2331 }
2332
2333 PP(pp_nbit_and)
2334 {
2335     dSP;
2336     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2337     {
2338         dATARGET; dPOPTOPssrl;
2339         if (PL_op->op_private & HINT_INTEGER) {
2340           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2341           SETi(i);
2342         }
2343         else {
2344           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2345           SETu(u);
2346         }
2347     }
2348     RETURN;
2349 }
2350
2351 PP(pp_sbit_and)
2352 {
2353     dSP;
2354     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2355     {
2356         dATARGET; dPOPTOPssrl;
2357         do_vop(OP_BIT_AND, TARG, left, right);
2358         RETSETTARG;
2359     }
2360 }
2361
2362 /* also used for: pp_bit_xor() */
2363
2364 PP(pp_bit_or)
2365 {
2366     dSP; dATARGET;
2367     const int op_type = PL_op->op_type;
2368
2369     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2370     {
2371       dPOPTOPssrl;
2372       if (SvNIOKp(left) || SvNIOKp(right)) {
2373         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2374         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2375         if (PL_op->op_private & HINT_INTEGER) {
2376           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2377           const IV r = SvIV_nomg(right);
2378           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2379           SETi(result);
2380         }
2381         else {
2382           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2383           const UV r = SvUV_nomg(right);
2384           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2385           SETu(result);
2386         }
2387         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2388         if (right_ro_nonnum) SvNIOK_off(right);
2389       }
2390       else {
2391         do_vop(op_type, TARG, left, right);
2392         SETTARG;
2393       }
2394       RETURN;
2395     }
2396 }
2397
2398 /* also used for: pp_nbit_xor() */
2399
2400 PP(pp_nbit_or)
2401 {
2402     dSP;
2403     const int op_type = PL_op->op_type;
2404
2405     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2406                     AMGf_assign|AMGf_numarg);
2407     {
2408         dATARGET; dPOPTOPssrl;
2409         if (PL_op->op_private & HINT_INTEGER) {
2410           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2411           const IV r = SvIV_nomg(right);
2412           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2413           SETi(result);
2414         }
2415         else {
2416           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2417           const UV r = SvUV_nomg(right);
2418           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2419           SETu(result);
2420         }
2421     }
2422     RETURN;
2423 }
2424
2425 /* also used for: pp_sbit_xor() */
2426
2427 PP(pp_sbit_or)
2428 {
2429     dSP;
2430     const int op_type = PL_op->op_type;
2431
2432     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2433                     AMGf_assign);
2434     {
2435         dATARGET; dPOPTOPssrl;
2436         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2437                right);
2438         RETSETTARG;
2439     }
2440 }
2441
2442 PERL_STATIC_INLINE bool
2443 S_negate_string(pTHX)
2444 {
2445     dTARGET; dSP;
2446     STRLEN len;
2447     const char *s;
2448     SV * const sv = TOPs;
2449     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2450         return FALSE;
2451     s = SvPV_nomg_const(sv, len);
2452     if (isIDFIRST(*s)) {
2453         sv_setpvs(TARG, "-");
2454         sv_catsv(TARG, sv);
2455     }
2456     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2457         sv_setsv_nomg(TARG, sv);
2458         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2459     }
2460     else return FALSE;
2461     SETTARG;
2462     return TRUE;
2463 }
2464
2465 PP(pp_negate)
2466 {
2467     dSP; dTARGET;
2468     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2469     if (S_negate_string(aTHX)) return NORMAL;
2470     {
2471         SV * const sv = TOPs;
2472
2473         if (SvIOK(sv)) {
2474             /* It's publicly an integer */
2475         oops_its_an_int:
2476             if (SvIsUV(sv)) {
2477                 if (SvIVX(sv) == IV_MIN) {
2478                     /* 2s complement assumption. */
2479                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2480                                            IV_MIN */
2481                     return NORMAL;
2482                 }
2483                 else if (SvUVX(sv) <= IV_MAX) {
2484                     SETi(-SvIVX(sv));
2485                     return NORMAL;
2486                 }
2487             }
2488             else if (SvIVX(sv) != IV_MIN) {
2489                 SETi(-SvIVX(sv));
2490                 return NORMAL;
2491             }
2492 #ifdef PERL_PRESERVE_IVUV
2493             else {
2494                 SETu((UV)IV_MIN);
2495                 return NORMAL;
2496             }
2497 #endif
2498         }
2499         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2500             SETn(-SvNV_nomg(sv));
2501         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2502                   goto oops_its_an_int;
2503         else
2504             SETn(-SvNV_nomg(sv));
2505     }
2506     return NORMAL;
2507 }
2508
2509 PP(pp_not)
2510 {
2511     dSP;
2512     SV *sv;
2513
2514     tryAMAGICun_MG(not_amg, AMGf_set);
2515     sv = *PL_stack_sp;
2516     *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2517     return NORMAL;
2518 }
2519
2520 static void
2521 S_scomplement(pTHX_ SV *targ, SV *sv)
2522 {
2523         U8 *tmps;
2524         I32 anum;
2525         STRLEN len;
2526
2527         sv_copypv_nomg(TARG, sv);
2528         tmps = (U8*)SvPV_nomg(TARG, len);
2529
2530         if (SvUTF8(TARG)) {
2531             if (len && ! utf8_to_bytes(tmps, &len)) {
2532                 Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]);
2533             }
2534             SvCUR(TARG) = len;
2535             SvUTF8_off(TARG);
2536         }
2537
2538         anum = len;
2539
2540 #ifdef LIBERAL
2541         {
2542             long *tmpl;
2543             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2544                 *tmps = ~*tmps;
2545             tmpl = (long*)tmps;
2546             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2547                 *tmpl = ~*tmpl;
2548             tmps = (U8*)tmpl;
2549         }
2550 #endif
2551         for ( ; anum > 0; anum--, tmps++)
2552             *tmps = ~*tmps;
2553 }
2554
2555 PP(pp_complement)
2556 {
2557     dSP; dTARGET;
2558     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2559     {
2560       dTOPss;
2561       if (SvNIOKp(sv)) {
2562         if (PL_op->op_private & HINT_INTEGER) {
2563           const IV i = ~SvIV_nomg(sv);
2564           SETi(i);
2565         }
2566         else {
2567           const UV u = ~SvUV_nomg(sv);
2568           SETu(u);
2569         }
2570       }
2571       else {
2572         S_scomplement(aTHX_ TARG, sv);
2573         SETTARG;
2574       }
2575       return NORMAL;
2576     }
2577 }
2578
2579 PP(pp_ncomplement)
2580 {
2581     dSP;
2582     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2583     {
2584         dTARGET; dTOPss;
2585         if (PL_op->op_private & HINT_INTEGER) {
2586           const IV i = ~SvIV_nomg(sv);
2587           SETi(i);
2588         }
2589         else {
2590           const UV u = ~SvUV_nomg(sv);
2591           SETu(u);
2592         }
2593     }
2594     return NORMAL;
2595 }
2596
2597 PP(pp_scomplement)
2598 {
2599     dSP;
2600     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2601     {
2602         dTARGET; dTOPss;
2603         S_scomplement(aTHX_ TARG, sv);
2604         SETTARG;
2605         return NORMAL;
2606     }
2607 }
2608
2609 /* integer versions of some of the above */
2610
2611 PP(pp_i_multiply)
2612 {
2613     dSP; dATARGET;
2614     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2615     {
2616       dPOPTOPiirl_nomg;
2617       SETi( left * right );
2618       RETURN;
2619     }
2620 }
2621
2622 PP(pp_i_divide)
2623 {
2624     IV num;
2625     dSP; dATARGET;
2626     tryAMAGICbin_MG(div_amg, AMGf_assign);
2627     {
2628       dPOPTOPssrl;
2629       IV value = SvIV_nomg(right);
2630       if (value == 0)
2631           DIE(aTHX_ "Illegal division by zero");
2632       num = SvIV_nomg(left);
2633
2634       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2635       if (value == -1)
2636           value = - num;
2637       else
2638           value = num / value;
2639       SETi(value);
2640       RETURN;
2641     }
2642 }
2643
2644 PP(pp_i_modulo)
2645 {
2646      /* This is the vanilla old i_modulo. */
2647      dSP; dATARGET;
2648      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2649      {
2650           dPOPTOPiirl_nomg;
2651           if (!right)
2652                DIE(aTHX_ "Illegal modulus zero");
2653           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2654           if (right == -1)
2655               SETi( 0 );
2656           else
2657               SETi( left % right );
2658           RETURN;
2659      }
2660 }
2661
2662 #if defined(__GLIBC__) && IVSIZE == 8 \
2663     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2664
2665 PP(pp_i_modulo_glibc_bugfix)
2666 {
2667      /* This is the i_modulo with the workaround for the _moddi3 bug
2668       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2669       * See below for pp_i_modulo. */
2670      dSP; dATARGET;
2671      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2672      {
2673           dPOPTOPiirl_nomg;
2674           if (!right)
2675                DIE(aTHX_ "Illegal modulus zero");
2676           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2677           if (right == -1)
2678               SETi( 0 );
2679           else
2680               SETi( left % PERL_ABS(right) );
2681           RETURN;
2682      }
2683 }
2684 #endif
2685
2686 PP(pp_i_add)
2687 {
2688     dSP; dATARGET;
2689     tryAMAGICbin_MG(add_amg, AMGf_assign);
2690     {
2691       dPOPTOPiirl_ul_nomg;
2692       SETi( left + right );
2693       RETURN;
2694     }
2695 }
2696
2697 PP(pp_i_subtract)
2698 {
2699     dSP; dATARGET;
2700     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2701     {
2702       dPOPTOPiirl_ul_nomg;
2703       SETi( left - right );
2704       RETURN;
2705     }
2706 }
2707
2708 PP(pp_i_lt)
2709 {
2710     dSP;
2711     tryAMAGICbin_MG(lt_amg, AMGf_set);
2712     {
2713       dPOPTOPiirl_nomg;
2714       SETs(boolSV(left < right));
2715       RETURN;
2716     }
2717 }
2718
2719 PP(pp_i_gt)
2720 {
2721     dSP;
2722     tryAMAGICbin_MG(gt_amg, AMGf_set);
2723     {
2724       dPOPTOPiirl_nomg;
2725       SETs(boolSV(left > right));
2726       RETURN;
2727     }
2728 }
2729
2730 PP(pp_i_le)
2731 {
2732     dSP;
2733     tryAMAGICbin_MG(le_amg, AMGf_set);
2734     {
2735       dPOPTOPiirl_nomg;
2736       SETs(boolSV(left <= right));
2737       RETURN;
2738     }
2739 }
2740
2741 PP(pp_i_ge)
2742 {
2743     dSP;
2744     tryAMAGICbin_MG(ge_amg, AMGf_set);
2745     {
2746       dPOPTOPiirl_nomg;
2747       SETs(boolSV(left >= right));
2748       RETURN;
2749     }
2750 }
2751
2752 PP(pp_i_eq)
2753 {
2754     dSP;
2755     tryAMAGICbin_MG(eq_amg, AMGf_set);
2756     {
2757       dPOPTOPiirl_nomg;
2758       SETs(boolSV(left == right));
2759       RETURN;
2760     }
2761 }
2762
2763 PP(pp_i_ne)
2764 {
2765     dSP;
2766     tryAMAGICbin_MG(ne_amg, AMGf_set);
2767     {
2768       dPOPTOPiirl_nomg;
2769       SETs(boolSV(left != right));
2770       RETURN;
2771     }
2772 }
2773
2774 PP(pp_i_ncmp)
2775 {
2776     dSP; dTARGET;
2777     tryAMAGICbin_MG(ncmp_amg, 0);
2778     {
2779       dPOPTOPiirl_nomg;
2780       I32 value;
2781
2782       if (left > right)
2783         value = 1;
2784       else if (left < right)
2785         value = -1;
2786       else
2787         value = 0;
2788       SETi(value);
2789       RETURN;
2790     }
2791 }
2792
2793 PP(pp_i_negate)
2794 {
2795     dSP; dTARGET;
2796     tryAMAGICun_MG(neg_amg, 0);
2797     if (S_negate_string(aTHX)) return NORMAL;
2798     {
2799         SV * const sv = TOPs;
2800         IV const i = SvIV_nomg(sv);
2801         SETi(-i);
2802         return NORMAL;
2803     }
2804 }
2805
2806 /* High falutin' math. */
2807
2808 PP(pp_atan2)
2809 {
2810     dSP; dTARGET;
2811     tryAMAGICbin_MG(atan2_amg, 0);
2812     {
2813       dPOPTOPnnrl_nomg;
2814       SETn(Perl_atan2(left, right));
2815       RETURN;
2816     }
2817 }
2818
2819
2820 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2821
2822 PP(pp_sin)
2823 {
2824     dSP; dTARGET;
2825     int amg_type = fallback_amg;
2826     const char *neg_report = NULL;
2827     const int op_type = PL_op->op_type;
2828
2829     switch (op_type) {
2830     case OP_SIN:  amg_type = sin_amg; break;
2831     case OP_COS:  amg_type = cos_amg; break;
2832     case OP_EXP:  amg_type = exp_amg; break;
2833     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2834     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2835     }
2836
2837     assert(amg_type != fallback_amg);
2838
2839     tryAMAGICun_MG(amg_type, 0);
2840     {
2841       SV * const arg = TOPs;
2842       const NV value = SvNV_nomg(arg);
2843 #ifdef NV_NAN
2844       NV result = NV_NAN;
2845 #else
2846       NV result = 0.0;
2847 #endif
2848       if (neg_report) { /* log or sqrt */
2849           if (
2850 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2851               ! Perl_isnan(value) &&
2852 #endif
2853               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2854               SET_NUMERIC_STANDARD();
2855               /* diag_listed_as: Can't take log of %g */
2856               DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2857           }
2858       }
2859       switch (op_type) {
2860       default:
2861       case OP_SIN:  result = Perl_sin(value);  break;
2862       case OP_COS:  result = Perl_cos(value);  break;
2863       case OP_EXP:  result = Perl_exp(value);  break;
2864       case OP_LOG:  result = Perl_log(value);  break;
2865       case OP_SQRT: result = Perl_sqrt(value); break;
2866       }
2867       SETn(result);
2868       return NORMAL;
2869     }
2870 }
2871
2872 /* Support Configure command-line overrides for rand() functions.
2873    After 5.005, perhaps we should replace this by Configure support
2874    for drand48(), random(), or rand().  For 5.005, though, maintain
2875    compatibility by calling rand() but allow the user to override it.
2876    See INSTALL for details.  --Andy Dougherty  15 July 1998
2877 */
2878 /* Now it's after 5.005, and Configure supports drand48() and random(),
2879    in addition to rand().  So the overrides should not be needed any more.
2880    --Jarkko Hietaniemi  27 September 1998
2881  */
2882
2883 PP(pp_rand)
2884 {
2885     if (!PL_srand_called) {
2886         (void)seedDrand01((Rand_seed_t)seed());
2887         PL_srand_called = TRUE;
2888     }
2889     {
2890         dSP;
2891         NV value;
2892
2893         if (MAXARG < 1)
2894         {
2895             EXTEND(SP, 1);
2896             value = 1.0;
2897         }
2898         else {
2899             SV * const sv = POPs;
2900             if(!sv)
2901                 value = 1.0;
2902             else
2903                 value = SvNV(sv);
2904         }
2905     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2906 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2907         if (! Perl_isnan(value) && value == 0.0)
2908 #else
2909         if (value == 0.0)
2910 #endif
2911             value = 1.0;
2912         {
2913             dTARGET;
2914             PUSHs(TARG);
2915             PUTBACK;
2916             value *= Drand01();
2917             sv_setnv_mg(TARG, value);
2918         }
2919     }
2920     return NORMAL;
2921 }
2922
2923 PP(pp_srand)
2924 {
2925     dSP; dTARGET;
2926     UV anum;
2927
2928     if (MAXARG >= 1 && (TOPs || POPs)) {
2929         SV *top;
2930         char *pv;
2931         STRLEN len;
2932         int flags;
2933
2934         top = POPs;
2935         pv = SvPV(top, len);
2936         flags = grok_number(pv, len, &anum);
2937
2938         if (!(flags & IS_NUMBER_IN_UV)) {
2939             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2940                              "Integer overflow in srand");
2941             anum = UV_MAX;
2942         }
2943     }
2944     else {
2945         anum = seed();
2946     }
2947
2948     (void)seedDrand01((Rand_seed_t)anum);
2949     PL_srand_called = TRUE;
2950     if (anum)
2951         XPUSHu(anum);
2952     else {
2953         /* Historically srand always returned true. We can avoid breaking
2954            that like this:  */
2955         sv_setpvs(TARG, "0 but true");
2956         XPUSHTARG;
2957     }
2958     RETURN;
2959 }
2960
2961 PP(pp_int)
2962 {
2963     dSP; dTARGET;
2964     tryAMAGICun_MG(int_amg, AMGf_numeric);
2965     {
2966       SV * const sv = TOPs;
2967       const IV iv = SvIV_nomg(sv);
2968       /* XXX it's arguable that compiler casting to IV might be subtly
2969          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2970          else preferring IV has introduced a subtle behaviour change bug. OTOH
2971          relying on floating point to be accurate is a bug.  */
2972
2973       if (!SvOK(sv)) {
2974         SETu(0);
2975       }
2976       else if (SvIOK(sv)) {
2977         if (SvIsUV(sv))
2978             SETu(SvUV_nomg(sv));
2979         else
2980             SETi(iv);
2981       }
2982       else {
2983           const NV value = SvNV_nomg(sv);
2984           if (UNLIKELY(Perl_isinfnan(value)))
2985               SETn(value);
2986           else if (value >= 0.0) {
2987               if (value < (NV)UV_MAX + 0.5) {
2988                   SETu(U_V(value));
2989               } else {
2990                   SETn(Perl_floor(value));
2991               }
2992           }
2993           else {
2994               if (value > (NV)IV_MIN - 0.5) {
2995                   SETi(I_V(value));
2996               } else {
2997                   SETn(Perl_ceil(value));
2998               }
2999           }
3000       }
3001     }
3002     return NORMAL;
3003 }
3004
3005 PP(pp_abs)
3006 {
3007     dSP; dTARGET;
3008     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3009     {
3010       SV * const sv = TOPs;
3011       /* This will cache the NV value if string isn't actually integer  */
3012       const IV iv = SvIV_nomg(sv);
3013
3014       if (!SvOK(sv)) {
3015         SETu(0);
3016       }
3017       else if (SvIOK(sv)) {
3018         /* IVX is precise  */
3019         if (SvIsUV(sv)) {
3020           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3021         } else {
3022           if (iv >= 0) {
3023             SETi(iv);
3024           } else {
3025             if (iv != IV_MIN) {
3026               SETi(-iv);
3027             } else {
3028               /* 2s complement assumption. Also, not really needed as
3029                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3030               SETu((UV)IV_MIN);
3031             }
3032           }
3033         }
3034       } else{
3035         const NV value = SvNV_nomg(sv);
3036         if (value < 0.0)
3037           SETn(-value);
3038         else
3039           SETn(value);
3040       }
3041     }
3042     return NORMAL;
3043 }
3044
3045
3046 /* also used for: pp_hex() */
3047
3048 PP(pp_oct)
3049 {
3050     dSP; dTARGET;
3051     const char *tmps;
3052     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3053     STRLEN len;
3054     NV result_nv;
3055     UV result_uv;
3056     SV* const sv = TOPs;
3057
3058     tmps = (SvPV_const(sv, len));
3059     if (DO_UTF8(sv)) {
3060          /* If Unicode, try to downgrade
3061           * If not possible, croak. */
3062          SV* const tsv = sv_2mortal(newSVsv(sv));
3063
3064          SvUTF8_on(tsv);
3065          sv_utf8_downgrade(tsv, FALSE);
3066          tmps = SvPV_const(tsv, len);
3067     }
3068     if (PL_op->op_type == OP_HEX)
3069         goto hex;
3070
3071     while (*tmps && len && isSPACE(*tmps))
3072         tmps++, len--;
3073     if (*tmps == '0')
3074         tmps++, len--;
3075     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3076     hex:
3077         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3078     }
3079     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3080         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3081     else
3082         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3083
3084     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3085         SETn(result_nv);
3086     }
3087     else {
3088         SETu(result_uv);
3089     }
3090     return NORMAL;
3091 }
3092
3093 /* String stuff. */
3094
3095
3096 PP(pp_length)
3097 {
3098     dSP; dTARGET;
3099     SV * const sv = TOPs;
3100
3101     U32 in_bytes = IN_BYTES;
3102     /* Simplest case shortcut:
3103      * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3104      * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3105      * set)
3106      */
3107     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3108
3109     STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3110     SETs(TARG);
3111
3112     if (LIKELY(svflags == SVf_POK))
3113         goto simple_pv;
3114
3115     if (svflags & SVs_GMG)
3116         mg_get(sv);
3117
3118     if (SvOK(sv)) {
3119         STRLEN len;
3120         if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3121             if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3122                 goto simple_pv;
3123             if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3124                 /* no need to convert from bytes to chars */
3125                 len = SvCUR(sv);
3126                 goto return_bool;
3127             }
3128             len = sv_len_utf8_nomg(sv);
3129         }
3130         else {
3131             /* unrolled SvPV_nomg_const(sv,len) */
3132             if (SvPOK_nog(sv)) {
3133               simple_pv:
3134                 len = SvCUR(sv);
3135                 if (PL_op->op_private & OPpTRUEBOOL) {
3136                   return_bool:
3137                     SETs(len ? &PL_sv_yes : &PL_sv_zero);
3138                     return NORMAL;
3139                 }
3140             }
3141             else {
3142                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3143             }
3144         }
3145         TARGi((IV)(len), 1);
3146     }
3147     else {
3148         if (!SvPADTMP(TARG)) {
3149             /* OPpTARGET_MY: targ is var in '$lex = length()' */
3150             sv_set_undef(TARG);
3151             SvSETMAGIC(TARG);
3152         }
3153         else
3154             /* TARG is on stack at this point and is overwriten by SETs.
3155              * This branch is the odd one out, so put TARG by default on
3156              * stack earlier to let local SP go out of liveness sooner */
3157             SETs(&PL_sv_undef);
3158     }
3159     return NORMAL; /* no putback, SP didn't move in this opcode */
3160 }
3161
3162
3163 /* Returns false if substring is completely outside original string.
3164    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3165    always be true for an explicit 0.
3166 */
3167 bool
3168 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3169                                 bool pos1_is_uv, IV len_iv,
3170                                 bool len_is_uv, STRLEN *posp,
3171                                 STRLEN *lenp)
3172 {
3173     IV pos2_iv;
3174     int    pos2_is_uv;
3175
3176     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3177
3178     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3179         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3180         pos1_iv += curlen;
3181     }
3182     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3183         return FALSE;
3184
3185     if (len_iv || len_is_uv) {
3186         if (!len_is_uv && len_iv < 0) {
3187             pos2_iv = curlen + len_iv;
3188             if (curlen)
3189                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3190             else
3191                 pos2_is_uv = 0;
3192         } else {  /* len_iv >= 0 */
3193             if (!pos1_is_uv && pos1_iv < 0) {
3194                 pos2_iv = pos1_iv + len_iv;
3195                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3196             } else {
3197                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3198                     pos2_iv = curlen;
3199                 else
3200                     pos2_iv = pos1_iv+len_iv;
3201                 pos2_is_uv = 1;
3202             }
3203         }
3204     }
3205     else {
3206         pos2_iv = curlen;
3207         pos2_is_uv = 1;
3208     }
3209
3210     if (!pos2_is_uv && pos2_iv < 0) {
3211         if (!pos1_is_uv && pos1_iv < 0)
3212             return FALSE;
3213         pos2_iv = 0;
3214     }
3215     else if (!pos1_is_uv && pos1_iv < 0)
3216         pos1_iv = 0;
3217
3218     if ((UV)pos2_iv < (UV)pos1_iv)
3219         pos2_iv = pos1_iv;
3220     if ((UV)pos2_iv > curlen)
3221         pos2_iv = curlen;
3222
3223     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3224     *posp = (STRLEN)( (UV)pos1_iv );
3225     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3226
3227     return TRUE;
3228 }
3229
3230 PP(pp_substr)
3231 {
3232     dSP; dTARGET;
3233     SV *sv;
3234     STRLEN curlen;
3235     STRLEN utf8_curlen;
3236     SV *   pos_sv;
3237     IV     pos1_iv;
3238     int    pos1_is_uv;
3239     SV *   len_sv;
3240     IV     len_iv = 0;
3241     int    len_is_uv = 0;
3242     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3243     const bool rvalue = (GIMME_V != G_VOID);
3244     const char *tmps;
3245     SV *repl_sv = NULL;
3246     const char *repl = NULL;
3247     STRLEN repl_len;
3248     int num_args = PL_op->op_private & 7;
3249     bool repl_need_utf8_upgrade = FALSE;
3250
3251     if (num_args > 2) {
3252         if (num_args > 3) {
3253           if(!(repl_sv = POPs)) num_args--;
3254         }
3255         if ((len_sv = POPs)) {
3256             len_iv    = SvIV(len_sv);
3257             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3258         }
3259         else num_args--;
3260     }
3261     pos_sv     = POPs;
3262     pos1_iv    = SvIV(pos_sv);
3263     pos1_is_uv = SvIOK_UV(pos_sv);
3264     sv = POPs;
3265     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3266         assert(!repl_sv);
3267         repl_sv = POPs;
3268     }
3269     if (lvalue && !repl_sv) {
3270         SV * ret;
3271         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3272         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3273         LvTYPE(ret) = 'x';
3274         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3275         LvTARGOFF(ret) =
3276             pos1_is_uv || pos1_iv >= 0
3277                 ? (STRLEN)(UV)pos1_iv
3278                 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3279         LvTARGLEN(ret) =
3280             len_is_uv || len_iv > 0
3281                 ? (STRLEN)(UV)len_iv
3282                 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3283
3284         PUSHs(ret);    /* avoid SvSETMAGIC here */
3285         RETURN;
3286     }
3287     if (repl_sv) {
3288         repl = SvPV_const(repl_sv, repl_len);
3289         SvGETMAGIC(sv);
3290         if (SvROK(sv))
3291             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3292                             "Attempt to use reference as lvalue in substr"
3293             );
3294         tmps = SvPV_force_nomg(sv, curlen);
3295         if (DO_UTF8(repl_sv) && repl_len) {
3296             if (!DO_UTF8(sv)) {
3297                 /* Upgrade the dest, and recalculate tmps in case the buffer
3298                  * got reallocated; curlen may also have been changed */
3299                 sv_utf8_upgrade_nomg(sv);
3300                 tmps = SvPV_nomg(sv, curlen);
3301             }
3302         }
3303         else if (DO_UTF8(sv))
3304             repl_need_utf8_upgrade = TRUE;
3305     }
3306     else tmps = SvPV_const(sv, curlen);
3307     if (DO_UTF8(sv)) {
3308         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3309         if (utf8_curlen == curlen)
3310             utf8_curlen = 0;
3311         else
3312             curlen = utf8_curlen;
3313     }
3314     else
3315         utf8_curlen = 0;
3316
3317     {
3318         STRLEN pos, len, byte_len, byte_pos;
3319
3320         if (!translate_substr_offsets(
3321                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3322         )) goto bound_fail;
3323
3324         byte_len = len;
3325         byte_pos = utf8_curlen
3326             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3327
3328         tmps += byte_pos;
3329
3330         if (rvalue) {
3331             SvTAINTED_off(TARG);                        /* decontaminate */
3332             SvUTF8_off(TARG);                   /* decontaminate */
3333             sv_setpvn(TARG, tmps, byte_len);
3334 #ifdef USE_LOCALE_COLLATE
3335             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3336 #endif
3337             if (utf8_curlen)
3338                 SvUTF8_on(TARG);
3339         }
3340
3341         if (repl) {
3342             SV* repl_sv_copy = NULL;
3343
3344             if (repl_need_utf8_upgrade) {
3345                 repl_sv_copy = newSVsv(repl_sv);
3346                 sv_utf8_upgrade(repl_sv_copy);
3347                 repl = SvPV_const(repl_sv_copy, repl_len);
3348             }
3349             if (!SvOK(sv))
3350                 SvPVCLEAR(sv);
3351             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3352             SvREFCNT_dec(repl_sv_copy);
3353         }
3354     }
3355     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3356         SP++;
3357     else if (rvalue) {
3358         SvSETMAGIC(TARG);
3359         PUSHs(TARG);
3360     }
3361     RETURN;
3362
3363   bound_fail:
3364     if (repl)
3365         Perl_croak(aTHX_ "substr outside of string");
3366     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3367     RETPUSHUNDEF;
3368 }
3369
3370 PP(pp_vec)
3371 {
3372     dSP;
3373     const IV size   = POPi;
3374     SV* offsetsv   = POPs;
3375     SV * const src = POPs;
3376     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3377     SV * ret;
3378     UV   retuv;
3379     STRLEN offset = 0;
3380     char errflags = 0;
3381
3382     /* extract a STRLEN-ranged integer value from offsetsv into offset,
3383      * or flag that its out of range */
3384     {
3385         IV iv = SvIV(offsetsv);
3386
3387         /* avoid a large UV being wrapped to a negative value */
3388         if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3389             errflags = LVf_OUT_OF_RANGE;
3390         else if (iv < 0)
3391             errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3392 #if PTRSIZE < IVSIZE
3393         else if (iv > Size_t_MAX)
3394             errflags = LVf_OUT_OF_RANGE;
3395 #endif
3396         else
3397             offset = (STRLEN)iv;
3398     }
3399
3400     retuv = errflags ? 0 : do_vecget(src, offset, size);
3401
3402     if (lvalue) {                       /* it's an lvalue! */
3403         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3404         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3405         LvTYPE(ret) = 'v';
3406         LvTARG(ret) = SvREFCNT_inc_simple(src);
3407         LvTARGOFF(ret) = offset;
3408         LvTARGLEN(ret) = size;
3409         LvFLAGS(ret)   = errflags;
3410     }
3411     else {
3412         dTARGET;
3413         SvTAINTED_off(TARG);            /* decontaminate */
3414         ret = TARG;
3415     }
3416
3417     sv_setuv(ret, retuv);
3418     if (!lvalue)
3419         SvSETMAGIC(ret);
3420     PUSHs(ret);
3421     RETURN;
3422 }
3423
3424
3425 /* also used for: pp_rindex() */
3426
3427 PP(pp_index)
3428 {
3429     dSP; dTARGET;
3430     SV *big;
3431     SV *little;
3432     SV *temp = NULL;
3433     STRLEN biglen;
3434     STRLEN llen = 0;
3435     SSize_t offset = 0;
3436     SSize_t retval;
3437     const char *big_p;
3438     const char *little_p;
3439     bool big_utf8;
3440     bool little_utf8;
3441     const bool is_index = PL_op->op_type == OP_INDEX;
3442     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3443
3444     if (threeargs)
3445         offset = POPi;
3446     little = POPs;
3447     big = POPs;
3448     big_p = SvPV_const(big, biglen);
3449     little_p = SvPV_const(little, llen);
3450
3451     big_utf8 = DO_UTF8(big);
3452     little_utf8 = DO_UTF8(little);
3453     if (big_utf8 ^ little_utf8) {
3454         /* One needs to be upgraded.  */
3455         if (little_utf8) {
3456             /* Well, maybe instead we might be able to downgrade the small
3457                string?  */
3458             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3459                                                      &little_utf8);
3460             if (little_utf8) {
3461                 /* If the large string is ISO-8859-1, and it's not possible to
3462                    convert the small string to ISO-8859-1, then there is no
3463                    way that it could be found anywhere by index.  */
3464                 retval = -1;
3465                 goto push_result;
3466             }
3467
3468             /* At this point, pv is a malloc()ed string. So donate it to temp
3469                to ensure it will get free()d  */
3470             little = temp = newSV(0);
3471             sv_usepvn(temp, pv, llen);
3472             little_p = SvPVX(little);
3473         } else {
3474             temp = newSVpvn(little_p, llen);
3475
3476             sv_utf8_upgrade(temp);
3477             little = temp;
3478             little_p = SvPV_const(little, llen);
3479         }
3480     }
3481     if (SvGAMAGIC(big)) {
3482         /* Life just becomes a lot easier if I use a temporary here.
3483            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3484            will trigger magic and overloading again, as will fbm_instr()
3485         */
3486         big = newSVpvn_flags(big_p, biglen,
3487                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3488         big_p = SvPVX(big);
3489     }
3490     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3491         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3492            warn on undef, and we've already triggered a warning with the
3493            SvPV_const some lines above. We can't remove that, as we need to
3494            call some SvPV to trigger overloading early and find out if the
3495            string is UTF-8.
3496            This is all getting too messy. The API isn't quite clean enough,
3497            because data access has side effects.
3498         */
3499         little = newSVpvn_flags(little_p, llen,
3500                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3501         little_p = SvPVX(little);
3502     }
3503
3504     if (!threeargs)
3505         offset = is_index ? 0 : biglen;
3506     else {
3507         if (big_utf8 && offset > 0)
3508             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3509         if (!is_index)
3510             offset += llen;
3511     }
3512     if (offset < 0)
3513         offset = 0;
3514     else if (offset > (SSize_t)biglen)
3515         offset = biglen;
3516     if (!(little_p = is_index
3517           ? fbm_instr((unsigned char*)big_p + offset,
3518                       (unsigned char*)big_p + biglen, little, 0)
3519           : rninstr(big_p,  big_p  + offset,
3520                     little_p, little_p + llen)))
3521         retval = -1;
3522     else {
3523         retval = little_p - big_p;
3524         if (retval > 1 && big_utf8)
3525             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3526     }
3527     SvREFCNT_dec(temp);
3528
3529   push_result:
3530     /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3531     if (PL_op->op_private & OPpTRUEBOOL) {
3532         PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3533                     ? &PL_sv_yes : &PL_sv_no);
3534         if (PL_op->op_private & OPpTARGET_MY)
3535             /* $lex = (index() == -1) */
3536             sv_setsv(TARG, TOPs);
3537     }
3538     else
3539         PUSHi(retval);
3540     RETURN;
3541 }
3542
3543 PP(pp_sprintf)
3544 {
3545     dSP; dMARK; dORIGMARK; dTARGET;
3546     SvTAINTED_off(TARG);
3547     do_sprintf(TARG, SP-MARK, MARK+1);
3548     TAINT_IF(SvTAINTED(TARG));
3549     SP = ORIGMARK;
3550     PUSHTARG;
3551     RETURN;
3552 }
3553
3554 PP(pp_ord)
3555 {
3556     dSP; dTARGET;
3557
3558     SV *argsv = TOPs;
3559     STRLEN len;
3560     const U8 *s = (U8*)SvPV_const(argsv, len);
3561
3562     SETu(DO_UTF8(argsv)
3563            ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3564            : (UV)(*s));
3565
3566     return NORMAL;
3567 }
3568
3569 PP(pp_chr)
3570 {
3571     dSP; dTARGET;
3572     char *tmps;
3573     UV value;
3574     SV *top = TOPs;
3575
3576     SvGETMAGIC(top);
3577     if (UNLIKELY(SvAMAGIC(top)))
3578         top = sv_2num(top);
3579     if (UNLIKELY(isinfnansv(top)))
3580         Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3581     else {
3582         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3583             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3584                 ||
3585                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3586                  && SvNV_nomg(top) < 0.0)))
3587         {
3588             if (ckWARN(WARN_UTF8)) {
3589                 if (SvGMAGICAL(top)) {
3590                     SV *top2 = sv_newmortal();
3591                     sv_setsv_nomg(top2, top);
3592                     top = top2;
3593                 }
3594                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3595                             "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3596             }
3597             value = UNICODE_REPLACEMENT;
3598         } else {
3599             value = SvUV_nomg(top);
3600         }
3601     }
3602
3603     SvUPGRADE(TARG,SVt_PV);
3604
3605     if (value > 255 && !IN_BYTES) {
3606         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3607         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3608         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3609         *tmps = '\0';
3610         (void)SvPOK_only(TARG);
3611         SvUTF8_on(TARG);
3612         SETTARG;
3613         return NORMAL;
3614     }
3615
3616     SvGROW(TARG,2);
3617     SvCUR_set(TARG, 1);
3618     tmps = SvPVX(TARG);
3619     *tmps++ = (char)value;
3620     *tmps = '\0';
3621     (void)SvPOK_only(TARG);
3622
3623     SETTARG;
3624     return NORMAL;
3625 }
3626
3627 PP(pp_crypt)
3628 {
3629 #ifdef HAS_CRYPT
3630     dSP; dTARGET;
3631     dPOPTOPssrl;
3632     STRLEN len;
3633     const char *tmps = SvPV_const(left, len);
3634
3635     if (DO_UTF8(left)) {
3636          /* If Unicode, try to downgrade.
3637           * If not possible, croak.
3638           * Yes, we made this up.  */
3639          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3640
3641          sv_utf8_downgrade(tsv, FALSE);
3642          tmps = SvPV_const(tsv, len);
3643     }
3644 #   ifdef USE_ITHREADS
3645 #     ifdef HAS_CRYPT_R
3646     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3647       /* This should be threadsafe because in ithreads there is only
3648        * one thread per interpreter.  If this would not be true,
3649        * we would need a mutex to protect this malloc. */
3650         PL_reentrant_buffer->_crypt_struct_buffer =
3651           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3652 #if defined(__GLIBC__) || defined(__EMX__)
3653         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3654             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3655             /* work around glibc-2.2.5 bug */
3656             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3657         }
3658 #endif
3659     }
3660 #     endif /* HAS_CRYPT_R */
3661 #   endif /* USE_ITHREADS */
3662 #   ifdef FCRYPT
3663     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3664 #   else
3665     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3666 #   endif
3667     SvUTF8_off(TARG);
3668     SETTARG;
3669     RETURN;
3670 #else
3671     DIE(aTHX_
3672       "The crypt() function is unimplemented due to excessive paranoia.");
3673 #endif
3674 }
3675
3676 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3677  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3678
3679
3680 /* also used for: pp_lcfirst() */
3681
3682 PP(pp_ucfirst)
3683 {
3684     /* Actually is both lcfirst() and ucfirst().  Only the first character
3685      * changes.  This means that possibly we can change in-place, ie., just
3686      * take the source and change that one character and store it back, but not
3687      * if read-only etc, or if the length changes */
3688
3689     dSP;
3690     SV *source = TOPs;
3691     STRLEN slen; /* slen is the byte length of the whole SV. */
3692     STRLEN need;
3693     SV *dest;
3694     bool inplace;   /* ? Convert first char only, in-place */
3695     bool doing_utf8 = FALSE;               /* ? using utf8 */
3696     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3697     const int op_type = PL_op->op_type;
3698     const U8 *s;
3699     U8 *d;
3700     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3701     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3702                      * stored as UTF-8 at s. */
3703     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3704                      * lowercased) character stored in tmpbuf.  May be either
3705                      * UTF-8 or not, but in either case is the number of bytes */
3706
3707     s = (const U8*)SvPV_const(source, slen);
3708
3709     /* We may be able to get away with changing only the first character, in
3710      * place, but not if read-only, etc.  Later we may discover more reasons to
3711      * not convert in-place. */
3712     inplace = !SvREADONLY(source) && SvPADTMP(source);
3713
3714     /* First calculate what the changed first character should be.  This affects
3715      * whether we can just swap it out, leaving the rest of the string unchanged,
3716      * or even if have to convert the dest to UTF-8 when the source isn't */
3717
3718     if (! slen) {   /* If empty */
3719         need = 1; /* still need a trailing NUL */
3720         ulen = 0;
3721     }
3722     else if (DO_UTF8(source)) { /* Is the source utf8? */
3723         doing_utf8 = TRUE;
3724         ulen = UTF8SKIP(s);
3725         if (op_type == OP_UCFIRST) {
3726 #ifdef USE_LOCALE_CTYPE
3727             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3728 #else
3729             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3730 #endif
3731         }
3732         else {
3733 #ifdef USE_LOCALE_CTYPE
3734             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3735 #else
3736             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3737 #endif
3738         }
3739
3740         /* we can't do in-place if the length changes.  */
3741         if (ulen != tculen) inplace = FALSE;
3742         need = slen + 1 - ulen + tculen;
3743     }
3744     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3745             * latin1 is treated as caseless.  Note that a locale takes
3746             * precedence */
3747         ulen = 1;       /* Original character is 1 byte */
3748         tculen = 1;     /* Most characters will require one byte, but this will
3749                          * need to be overridden for the tricky ones */
3750         need = slen + 1;
3751
3752         if (op_type == OP_LCFIRST) {
3753
3754             /* lower case the first letter: no trickiness for any character */
3755 #ifdef USE_LOCALE_CTYPE
3756             if (IN_LC_RUNTIME(LC_CTYPE)) {
3757                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3758                 *tmpbuf = toLOWER_LC(*s);
3759             }
3760             else
3761 #endif
3762             {
3763                 *tmpbuf = (IN_UNI_8_BIT)
3764                           ? toLOWER_LATIN1(*s)
3765                           : toLOWER(*s);
3766             }
3767         }
3768 #ifdef USE_LOCALE_CTYPE
3769         /* is ucfirst() */
3770         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3771             if (IN_UTF8_CTYPE_LOCALE) {
3772                 goto do_uni_rules;
3773             }
3774
3775             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3776             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3777                                               locales have upper and title case
3778                                               different */
3779         }
3780 #endif
3781         else if (! IN_UNI_8_BIT) {
3782             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3783                                          * on EBCDIC machines whatever the
3784                                          * native function does */
3785         }
3786         else {
3787             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3788              * UTF-8, which we treat as not in locale), and cased latin1 */
3789             UV title_ord;
3790 #ifdef USE_LOCALE_CTYPE
3791       do_uni_rules:
3792 #endif
3793
3794             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3795             if (tculen > 1) {
3796                 assert(tculen == 2);
3797
3798                 /* If the result is an upper Latin1-range character, it can
3799                  * still be represented in one byte, which is its ordinal */
3800                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3801                     *tmpbuf = (U8) title_ord;
3802                     tculen = 1;
3803                 }
3804                 else {
3805                     /* Otherwise it became more than one ASCII character (in
3806                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3807                      * beyond Latin1, so the number of bytes changed, so can't
3808                      * replace just the first character in place. */
3809                     inplace = FALSE;
3810
3811                     /* If the result won't fit in a byte, the entire result
3812                      * will have to be in UTF-8.  Assume worst case sizing in
3813                      * conversion. (all latin1 characters occupy at most two
3814                      * bytes in utf8) */
3815                     if (title_ord > 255) {
3816                         doing_utf8 = TRUE;
3817                         convert_source_to_utf8 = TRUE;
3818                         need = slen * 2 + 1;
3819
3820                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3821                          * (both) characters whose title case is above 255 is
3822                          * 2. */
3823                         ulen = 2;
3824                     }
3825                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3826                         need = slen + 1 + 1;
3827                     }
3828                 }
3829             }
3830         } /* End of use Unicode (Latin1) semantics */
3831     } /* End of changing the case of the first character */
3832
3833     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3834      * generate the result */
3835     if (inplace) {
3836
3837         /* We can convert in place.  This means we change just the first
3838          * character without disturbing the rest; no need to grow */
3839         dest = source;
3840         s = d = (U8*)SvPV_force_nomg(source, slen);
3841     } else {
3842         dTARGET;
3843
3844         dest = TARG;
3845
3846         /* Here, we can't convert in place; we earlier calculated how much
3847          * space we will need, so grow to accommodate that */
3848         SvUPGRADE(dest, SVt_PV);
3849         d = (U8*)SvGROW(dest, need);
3850         (void)SvPOK_only(dest);
3851
3852         SETs(dest);
3853     }
3854
3855     if (doing_utf8) {
3856         if (! inplace) {
3857             if (! convert_source_to_utf8) {
3858
3859                 /* Here  both source and dest are in UTF-8, but have to create
3860                  * the entire output.  We initialize the result to be the
3861                  * title/lower cased first character, and then append the rest
3862                  * of the string. */
3863                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3864                 if (slen > ulen) {
3865                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3866                 }
3867             }
3868             else {
3869                 const U8 *const send = s + slen;
3870
3871                 /* Here the dest needs to be in UTF-8, but the source isn't,
3872                  * except we earlier UTF-8'd the first character of the source
3873                  * into tmpbuf.  First put that into dest, and then append the
3874                  * rest of the source, converting it to UTF-8 as we go. */
3875
3876                 /* Assert tculen is 2 here because the only two characters that
3877                  * get to this part of the code have 2-byte UTF-8 equivalents */
3878                 *d++ = *tmpbuf;
3879                 *d++ = *(tmpbuf + 1);
3880                 s++;    /* We have just processed the 1st char */
3881
3882                 for (; s < send; s++) {
3883                     d = uvchr_to_utf8(d, *s);
3884                 }
3885                 *d = '\0';
3886                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3887             }
3888             SvUTF8_on(dest);
3889         }
3890         else {   /* in-place UTF-8.  Just overwrite the first character */
3891             Copy(tmpbuf, d, tculen, U8);
3892             SvCUR_set(dest, need - 1);
3893         }
3894
3895     }
3896     else {  /* Neither source nor dest are in or need to be UTF-8 */
3897         if (slen) {
3898             if (inplace) {  /* in-place, only need to change the 1st char */
3899                 *d = *tmpbuf;
3900             }
3901             else {      /* Not in-place */
3902
3903                 /* Copy the case-changed character(s) from tmpbuf */
3904                 Copy(tmpbuf, d, tculen, U8);
3905                 d += tculen - 1; /* Code below expects d to point to final
3906                                   * character stored */
3907             }
3908         }
3909         else {  /* empty source */
3910             /* See bug #39028: Don't taint if empty  */
3911             *d = *s;
3912         }
3913
3914         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3915          * the destination to retain that flag */
3916         if (SvUTF8(source) && ! IN_BYTES)
3917             SvUTF8_on(dest);
3918
3919         if (!inplace) { /* Finish the rest of the string, unchanged */
3920             /* This will copy the trailing NUL  */
3921             Copy(s + 1, d + 1, slen, U8);
3922             SvCUR_set(dest, need - 1);
3923         }
3924     }
3925 #ifdef USE_LOCALE_CTYPE
3926     if (IN_LC_RUNTIME(LC_CTYPE)) {
3927         TAINT;
3928         SvTAINTED_on(dest);
3929     }
3930 #endif
3931     if (dest != source && SvTAINTED(source))
3932         SvTAINT(dest);
3933     SvSETMAGIC(dest);
3934     return NORMAL;
3935 }
3936
3937 /* There's so much setup/teardown code common between uc and lc, I wonder if
3938    it would be worth merging the two, and just having a switch outside each
3939    of the three tight loops.  There is less and less commonality though */
3940 PP(pp_uc)
3941 {
3942     dSP;
3943     SV *source = TOPs;
3944     STRLEN len;
3945     STRLEN min;
3946     SV *dest;
3947     const U8 *s;
3948     U8 *d;
3949
3950     SvGETMAGIC(source);
3951
3952     if (   SvPADTMP(source)
3953         && !SvREADONLY(source) && SvPOK(source)
3954         && !DO_UTF8(source)
3955         && (
3956 #ifdef USE_LOCALE_CTYPE
3957             (IN_LC_RUNTIME(LC_CTYPE))
3958             ? ! IN_UTF8_CTYPE_LOCALE
3959             :
3960 #endif
3961               ! IN_UNI_8_BIT))
3962     {
3963
3964         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3965          * make the loop tight, so we overwrite the source with the dest before
3966          * looking at it, and we need to look at the original source
3967          * afterwards.  There would also need to be code added to handle
3968          * switching to not in-place in midstream if we run into characters
3969          * that change the length.  Since being in locale overrides UNI_8_BIT,
3970          * that latter becomes irrelevant in the above test; instead for
3971          * locale, the size can't normally change, except if the locale is a
3972          * UTF-8 one */
3973         dest = source;
3974         s = d = (U8*)SvPV_force_nomg(source, len);
3975         min = len + 1;
3976     } else {
3977         dTARGET;
3978
3979         dest = TARG;
3980
3981         s = (const U8*)SvPV_nomg_const(source, len);
3982         min = len + 1;
3983
3984         SvUPGRADE(dest, SVt_PV);
3985         d = (U8*)SvGROW(dest, min);
3986         (void)SvPOK_only(dest);
3987
3988         SETs(dest);
3989     }
3990
3991     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3992        to check DO_UTF8 again here.  */
3993
3994     if (DO_UTF8(source)) {
3995         const U8 *const send = s + len;
3996         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3997
3998         /* All occurrences of these are to be moved to follow any other marks.
3999          * This is context-dependent.  We may not be passed enough context to
4000          * move the iota subscript beyond all of them, but we do the best we can
4001          * with what we're given.  The result is always better than if we
4002          * hadn't done this.  And, the problem would only arise if we are
4003          * passed a character without all its combining marks, which would be
4004          * the caller's mistake.  The information this is based on comes from a
4005          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4006          * itself) and so can't be checked properly to see if it ever gets
4007          * revised.  But the likelihood of it changing is remote */
4008         bool in_iota_subscript = FALSE;
4009
4010         while (s < send) {
4011             STRLEN u;
4012             STRLEN ulen;
4013             UV uv;
4014             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4015
4016                 /* A non-mark.  Time to output the iota subscript */
4017                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4018                 d += capital_iota_len;
4019                 in_iota_subscript = FALSE;
4020             }
4021
4022             /* Then handle the current character.  Get the changed case value
4023              * and copy it to the output buffer */
4024
4025             u = UTF8SKIP(s);
4026 #ifdef USE_LOCALE_CTYPE
4027             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4028 #else
4029             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4030 #endif
4031 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4032 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4033             if (uv == GREEK_CAPITAL_LETTER_IOTA
4034                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4035             {
4036                 in_iota_subscript = TRUE;
4037             }
4038             else {
4039                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4040                     /* If the eventually required minimum size outgrows the
4041                      * available space, we need to grow. */
4042                     const UV o = d - (U8*)SvPVX_const(dest);
4043
4044                     /* If someone uppercases one million U+03B0s we SvGROW()
4045                      * one million times.  Or we could try guessing how much to
4046                      * allocate without allocating too much.  Such is life.
4047                      * See corresponding comment in lc code for another option
4048                      * */
4049                     d = o + (U8*) SvGROW(dest, min);
4050                 }
4051                 Copy(tmpbuf, d, ulen, U8);
4052                 d += ulen;
4053             }
4054             s += u;
4055         }
4056         if (in_iota_subscript) {
4057             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4058             d += capital_iota_len;
4059         }
4060         SvUTF8_on(dest);
4061         *d = '\0';
4062
4063         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4064     }
4065     else {      /* Not UTF-8 */
4066         if (len) {
4067             const U8 *const send = s + len;
4068
4069             /* Use locale casing if in locale; regular style if not treating
4070              * latin1 as having case; otherwise the latin1 casing.  Do the
4071              * whole thing in a tight loop, for speed, */
4072 #ifdef USE_LOCALE_CTYPE
4073             if (IN_LC_RUNTIME(LC_CTYPE)) {
4074                 if (IN_UTF8_CTYPE_LOCALE) {
4075                     goto do_uni_rules;
4076                 }
4077                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4078                 for (; s < send; d++, s++)
4079                     *d = (U8) toUPPER_LC(*s);
4080             }
4081             else
4082 #endif
4083                  if (! IN_UNI_8_BIT) {
4084                 for (; s < send; d++, s++) {
4085                     *d = toUPPER(*s);
4086                 }
4087             }
4088             else {
4089 #ifdef USE_LOCALE_CTYPE
4090           do_uni_rules:
4091 #endif
4092                 for (; s < send; d++, s++) {
4093                     *d = toUPPER_LATIN1_MOD(*s);
4094                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4095                         continue;
4096                     }
4097
4098                     /* The mainstream case is the tight loop above.  To avoid
4099                      * extra tests in that, all three characters that require
4100                      * special handling are mapped by the MOD to the one tested
4101                      * just above.
4102                      * Use the source to distinguish between the three cases */
4103
4104 #if    UNICODE_MAJOR_VERSION > 2                                        \
4105    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4106                                   && UNICODE_DOT_DOT_VERSION >= 8)
4107                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4108
4109                         /* uc() of this requires 2 characters, but they are
4110                          * ASCII.  If not enough room, grow the string */
4111                         if (SvLEN(dest) < ++min) {
4112                             const UV o = d - (U8*)SvPVX_const(dest);
4113                             d = o + (U8*) SvGROW(dest, min);
4114                         }
4115                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4116                         continue;   /* Back to the tight loop; still in ASCII */
4117                     }
4118 #endif
4119
4120                     /* The other two special handling characters have their
4121                      * upper cases outside the latin1 range, hence need to be
4122                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4123                      * here we are somewhere in the middle of processing a
4124                      * non-UTF-8 string, and realize that we will have to convert
4125                      * the whole thing to UTF-8.  What to do?  There are
4126                      * several possibilities.  The simplest to code is to
4127                      * convert what we have so far, set a flag, and continue on
4128                      * in the loop.  The flag would be tested each time through
4129                      * the loop, and if set, the next character would be
4130                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4131                      * to slow down the mainstream case at all for this fairly
4132                      * rare case, so I didn't want to add a test that didn't
4133                      * absolutely have to be there in the loop, besides the
4134                      * possibility that it would get too complicated for
4135                      * optimizers to deal with.  Another possibility is to just
4136                      * give up, convert the source to UTF-8, and restart the
4137                      * function that way.  Another possibility is to convert
4138                      * both what has already been processed and what is yet to
4139                      * come separately to UTF-8, then jump into the loop that
4140                      * handles UTF-8.  But the most efficient time-wise of the
4141                      * ones I could think of is what follows, and turned out to
4142                      * not require much extra code.  */
4143
4144                     /* Convert what we have so far into UTF-8, telling the
4145                      * function that we know it should be converted, and to
4146                      * allow extra space for what we haven't processed yet.
4147                      * Assume the worst case space requirements for converting
4148                      * what we haven't processed so far: that it will require
4149                      * two bytes for each remaining source character, plus the
4150                      * NUL at the end.  This may cause the string pointer to
4151                      * move, so re-find it. */
4152
4153                     len = d - (U8*)SvPVX_const(dest);
4154                     SvCUR_set(dest, len);
4155                     len = sv_utf8_upgrade_flags_grow(dest,
4156                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4157                                                 (send -s) * 2 + 1);
4158                     d = (U8*)SvPVX(dest) + len;
4159
4160                     /* Now process the remainder of the source, converting to
4161                      * upper and UTF-8.  If a resulting byte is invariant in
4162                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4163                      * append it to the output. */
4164                     for (; s < send; s++) {
4165                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4166                         d += len;
4167                     }
4168
4169                     /* Here have processed the whole source; no need to continue
4170                      * with the outer loop.  Each character has been converted
4171                      * to upper case and converted to UTF-8 */
4172
4173                     break;
4174                 } /* End of processing all latin1-style chars */
4175             } /* End of processing all chars */
4176         } /* End of source is not empty */
4177
4178         if (source != dest) {
4179             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4180             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4181         }
4182     } /* End of isn't utf8 */
4183 #ifdef USE_LOCALE_CTYPE
4184     if (IN_LC_RUNTIME(LC_CTYPE)) {
4185         TAINT;
4186         SvTAINTED_on(dest);
4187     }
4188 #endif
4189     if (dest != source && SvTAINTED(source))
4190         SvTAINT(dest);
4191     SvSETMAGIC(dest);
4192     return NORMAL;
4193 }
4194
4195 PP(pp_lc)
4196 {
4197     dSP;
4198     SV *source = TOPs;
4199     STRLEN len;
4200     STRLEN min;
4201     SV *dest;
4202     const U8 *s;
4203     U8 *d;
4204
4205     SvGETMAGIC(source);
4206
4207     if (   SvPADTMP(source)
4208         && !SvREADONLY(source) && SvPOK(source)
4209         && !DO_UTF8(source)) {
4210
4211         /* We can convert in place, as lowercasing anything in the latin1 range
4212          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4213         dest = source;
4214         s = d = (U8*)SvPV_force_nomg(source, len);
4215         min = len + 1;
4216     } else {
4217         dTARGET;
4218
4219         dest = TARG;
4220
4221         s = (const U8*)SvPV_nomg_const(source, len);
4222         min = len + 1;
4223
4224         SvUPGRADE(dest, SVt_PV);
4225         d = (U8*)SvGROW(dest, min);
4226         (void)SvPOK_only(dest);
4227
4228         SETs(dest);
4229     }
4230
4231     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4232        to check DO_UTF8 again here.  */
4233
4234     if (DO_UTF8(source)) {
4235         const U8 *const send = s + len;
4236         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4237
4238         while (s < send) {
4239             const STRLEN u = UTF8SKIP(s);
4240             STRLEN ulen;
4241
4242 #ifdef USE_LOCALE_CTYPE
4243             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4244 #else
4245             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4246 #endif
4247
4248             /* Here is where we would do context-sensitive actions.  See the
4249              * commit message for 86510fb15 for why there isn't any */
4250
4251             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4252
4253                 /* If the eventually required minimum size outgrows the
4254                  * available space, we need to grow. */
4255                 const UV o = d - (U8*)SvPVX_const(dest);
4256
4257                 /* If someone lowercases one million U+0130s we SvGROW() one
4258                  * million times.  Or we could try guessing how much to
4259                  * allocate without allocating too much.  Such is life.
4260                  * Another option would be to grow an extra byte or two more
4261                  * each time we need to grow, which would cut down the million
4262                  * to 500K, with little waste */
4263                 d = o + (U8*) SvGROW(dest, min);
4264             }
4265
4266             /* Copy the newly lowercased letter to the output buffer we're
4267              * building */
4268             Copy(tmpbuf, d, ulen, U8);
4269             d += ulen;
4270             s += u;
4271         }   /* End of looping through the source string */
4272         SvUTF8_on(dest);
4273         *d = '\0';
4274         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4275     } else {    /* Not utf8 */
4276         if (len) {
4277             const U8 *const send = s + len;
4278
4279             /* Use locale casing if in locale; regular style if not treating
4280              * latin1 as having case; otherwise the latin1 casing.  Do the
4281              * whole thing in a tight loop, for speed, */
4282 #ifdef USE_LOCALE_CTYPE
4283             if (IN_LC_RUNTIME(LC_CTYPE)) {
4284                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4285                 for (; s < send; d++, s++)
4286                     *d = toLOWER_LC(*s);
4287             }
4288             else
4289 #endif
4290             if (! IN_UNI_8_BIT) {
4291                 for (; s < send; d++, s++) {
4292                     *d = toLOWER(*s);
4293                 }
4294             }
4295             else {
4296                 for (; s < send; d++, s++) {
4297                     *d = toLOWER_LATIN1(*s);
4298                 }
4299             }
4300         }
4301         if (source != dest) {
4302             *d = '\0';
4303             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4304         }
4305     }
4306 #ifdef USE_LOCALE_CTYPE
4307     if (IN_LC_RUNTIME(LC_CTYPE)) {
4308         TAINT;
4309         SvTAINTED_on(dest);
4310     }
4311 #endif
4312     if (dest != source && SvTAINTED(source))
4313         SvTAINT(dest);
4314     SvSETMAGIC(dest);
4315     return NORMAL;
4316 }
4317
4318 PP(pp_quotemeta)
4319 {
4320     dSP; dTARGET;
4321     SV * const sv = TOPs;
4322     STRLEN len;
4323     const char *s = SvPV_const(sv,len);
4324
4325     SvUTF8_off(TARG);                           /* decontaminate */
4326     if (len) {
4327         char *d;
4328         SvUPGRADE(TARG, SVt_PV);
4329         SvGROW(TARG, (len * 2) + 1);
4330         d = SvPVX(TARG);
4331         if (DO_UTF8(sv)) {
4332             while (len) {
4333                 STRLEN ulen = UTF8SKIP(s);
4334                 bool to_quote = FALSE;
4335
4336                 if (UTF8_IS_INVARIANT(*s)) {
4337                     if (_isQUOTEMETA(*s)) {
4338                         to_quote = TRUE;
4339                     }
4340                 }
4341                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4342                     if (
4343 #ifdef USE_LOCALE_CTYPE
4344                     /* In locale, we quote all non-ASCII Latin1 chars.
4345                      * Otherwise use the quoting rules */
4346
4347                     IN_LC_RUNTIME(LC_CTYPE)
4348                         ||
4349 #endif
4350                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4351                     {
4352                         to_quote = TRUE;
4353                     }
4354                 }
4355                 else if (is_QUOTEMETA_high(s)) {
4356                     to_quote = TRUE;
4357                 }
4358
4359                 if (to_quote) {
4360                     *d++ = '\\';
4361                 }
4362                 if (ulen > len)
4363                     ulen = len;
4364                 len -= ulen;
4365                 while (ulen--)
4366                     *d++ = *s++;
4367             }
4368             SvUTF8_on(TARG);
4369         }
4370         else if (IN_UNI_8_BIT) {
4371             while (len--) {
4372                 if (_isQUOTEMETA(*s))
4373                     *d++ = '\\';
4374                 *d++ = *s++;
4375             }
4376         }
4377         else {
4378             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4379              * including everything above ASCII */
4380             while (len--) {
4381                 if (!isWORDCHAR_A(*s))
4382                     *d++ = '\\';
4383                 *d++ = *s++;
4384             }
4385         }
4386         *d = '\0';
4387         SvCUR_set(TARG, d - SvPVX_const(TARG));
4388         (void)SvPOK_only_UTF8(TARG);
4389     }
4390     else
4391         sv_setpvn(TARG, s, len);
4392     SETTARG;
4393     return NORMAL;
4394 }
4395
4396 PP(pp_fc)
4397 {
4398     dTARGET;
4399     dSP;
4400     SV *source = TOPs;
4401     STRLEN len;
4402     STRLEN min;
4403     SV *dest;
4404     const U8 *s;
4405     const U8 *send;
4406     U8 *d;
4407     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4408 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4409    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4410                                       || UNICODE_DOT_DOT_VERSION > 0)
4411     const bool full_folding = TRUE; /* This variable is here so we can easily
4412                                        move to more generality later */
4413 #else
4414     const bool full_folding = FALSE;
4415 #endif
4416     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4417 #ifdef USE_LOCALE_CTYPE
4418                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4419 #endif
4420     ;
4421
4422     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4423      * You are welcome(?) -Hugmeir
4424      */
4425
4426     SvGETMAGIC(source);
4427
4428     dest = TARG;
4429
4430     if (SvOK(source)) {
4431         s = (const U8*)SvPV_nomg_const(source, len);
4432     } else {
4433         if (ckWARN(WARN_UNINITIALIZED))
4434             report_uninit(source);
4435         s = (const U8*)"";
4436         len = 0;
4437     }
4438
4439     min = len + 1;
4440
4441     SvUPGRADE(dest, SVt_PV);
4442     d = (U8*)SvGROW(dest, min);
4443     (void)SvPOK_only(dest);
4444
4445     SETs(dest);
4446
4447     send = s + len;
4448     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4449         while (s < send) {
4450             const STRLEN u = UTF8SKIP(s);
4451             STRLEN ulen;
4452
4453             _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4454
4455             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4456                 const UV o = d - (U8*)SvPVX_const(dest);
4457                 d = o + (U8*) SvGROW(dest, min);
4458             }
4459
4460             Copy(tmpbuf, d, ulen, U8);
4461             d += ulen;
4462             s += u;
4463         }
4464         SvUTF8_on(dest);
4465     } /* Unflagged string */
4466     else if (len) {
4467 #ifdef USE_LOCALE_CTYPE
4468         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4469             if (IN_UTF8_CTYPE_LOCALE) {
4470                 goto do_uni_folding;
4471             }
4472             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4473             for (; s < send; d++, s++)
4474                 *d = (U8) toFOLD_LC(*s);
4475         }
4476         else
4477 #endif
4478         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4479             for (; s < send; d++, s++)
4480                 *d = toFOLD(*s);
4481         }
4482         else {
4483 #ifdef USE_LOCALE_CTYPE
4484       do_uni_folding:
4485 #endif
4486             /* For ASCII and the Latin-1 range, there's only two troublesome
4487              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4488              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4489              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4490              * For the rest, the casefold is their lowercase.  */
4491             for (; s < send; d++, s++) {
4492                 if (*s == MICRO_SIGN) {
4493                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4494                      * which is outside of the latin-1 range. There's a couple
4495                      * of ways to deal with this -- khw discusses them in
4496                      * pp_lc/uc, so go there :) What we do here is upgrade what
4497                      * we had already casefolded, then enter an inner loop that
4498                      * appends the rest of the characters as UTF-8. */
4499                     len = d - (U8*)SvPVX_const(dest);
4500                     SvCUR_set(dest, len);
4501                     len = sv_utf8_upgrade_flags_grow(dest,
4502                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4503                                                 /* The max expansion for latin1
4504                                                  * chars is 1 byte becomes 2 */
4505                                                 (send -s) * 2 + 1);
4506                     d = (U8*)SvPVX(dest) + len;
4507
4508                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4509                     d += small_mu_len;
4510                     s++;
4511                     for (; s < send; s++) {
4512                         STRLEN ulen;
4513                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4514                         if UVCHR_IS_INVARIANT(fc) {
4515                             if (full_folding
4516                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4517                             {
4518                                 *d++ = 's';
4519                                 *d++ = 's';
4520                             }
4521                             else
4522                                 *d++ = (U8)fc;
4523                         }
4524                         else {
4525                             Copy(tmpbuf, d, ulen, U8);
4526                             d += ulen;
4527                         }
4528                     }
4529                     break;
4530                 }
4531                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4532                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4533                      * becomes "ss", which may require growing the SV. */
4534                     if (SvLEN(dest) < ++min) {
4535                         const UV o = d - (U8*)SvPVX_const(dest);
4536                         d = o + (U8*) SvGROW(dest, min);
4537                      }
4538                     *(d)++ = 's';
4539                     *d = 's';
4540                 }
4541                 else { /* If it's not one of those two, the fold is their lower
4542                           case */
4543                     *d = toLOWER_LATIN1(*s);
4544                 }
4545              }
4546         }
4547     }
4548     *d = '\0';
4549     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4550
4551 #ifdef USE_LOCALE_CTYPE
4552     if (IN_LC_RUNTIME(LC_CTYPE)) {
4553         TAINT;
4554         SvTAINTED_on(dest);
4555     }
4556 #endif
4557     if (SvTAINTED(source))
4558         SvTAINT(dest);
4559     SvSETMAGIC(dest);
4560     RETURN;
4561 }
4562
4563 /* Arrays. */
4564
4565 PP(pp_aslice)
4566 {
4567     dSP; dMARK; dORIGMARK;
4568     AV *const av = MUTABLE_AV(POPs);
4569     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4570
4571     if (SvTYPE(av) == SVt_PVAV) {
4572         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4573         bool can_preserve = FALSE;
4574
4575         if (localizing) {
4576             MAGIC *mg;
4577             HV *stash;
4578
4579             can_preserve = SvCANEXISTDELETE(av);
4580         }
4581
4582         if (lval && localizing) {
4583             SV **svp;
4584             SSize_t max = -1;
4585             for (svp = MARK + 1; svp <= SP; svp++) {
4586                 const SSize_t elem = SvIV(*svp);
4587                 if (elem > max)
4588                     max = elem;
4589             }
4590             if (max > AvMAX(av))
4591                 av_extend(av, max);
4592         }
4593
4594         while (++MARK <= SP) {
4595             SV **svp;
4596             SSize_t elem = SvIV(*MARK);
4597             bool preeminent = TRUE;
4598
4599             if (localizing && can_preserve) {
4600                 /* If we can determine whether the element exist,
4601                  * Try to preserve the existenceness of a tied array
4602                  * element by using EXISTS and DELETE if possible.
4603                  * Fallback to FETCH and STORE otherwise. */
4604                 preeminent = av_exists(av, elem);
4605             }
4606
4607             svp = av_fetch(av, elem, lval);
4608             if (lval) {
4609                 if (!svp || !*svp)
4610                     DIE(aTHX_ PL_no_aelem, elem);
4611                 if (localizing) {
4612                     if (preeminent)
4613                         save_aelem(av, elem, svp);
4614                     else
4615                         SAVEADELETE(av, elem);
4616                 }
4617             }
4618             *MARK = svp ? *svp : &PL_sv_undef;
4619         }
4620     }
4621     if (GIMME_V != G_ARRAY) {
4622         MARK = ORIGMARK;
4623         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4624         SP = MARK;
4625     }
4626     RETURN;
4627 }
4628
4629 PP(pp_kvaslice)
4630 {
4631     dSP; dMARK;
4632     AV *const av = MUTABLE_AV(POPs);
4633     I32 lval = (PL_op->op_flags & OPf_MOD);
4634     SSize_t items = SP - MARK;
4635
4636     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4637        const I32 flags = is_lvalue_sub();
4638        if (flags) {
4639            if (!(flags & OPpENTERSUB_INARGS))
4640                /* diag_listed_as: Can't modify %s in %s */
4641                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4642            lval = flags;
4643        }
4644     }
4645
4646     MEXTEND(SP,items);
4647     while (items > 1) {
4648         *(MARK+items*2-1) = *(MARK+items);
4649         items--;
4650     }
4651     items = SP-MARK;
4652     SP += items;
4653
4654     while (++MARK <= SP) {
4655         SV **svp;
4656
4657         svp = av_fetch(av, SvIV(*MARK), lval);
4658         if (lval) {
4659             if (!svp || !*svp || *svp == &PL_sv_undef) {
4660                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4661             }
4662             *MARK = sv_mortalcopy(*MARK);
4663         }
4664         *++MARK = svp ? *svp : &PL_sv_undef;
4665     }
4666     if (GIMME_V != G_ARRAY) {
4667         MARK = SP - items*2;
4668         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4669         SP = MARK;
4670     }
4671     RETURN;
4672 }
4673
4674
4675 PP(pp_aeach)
4676 {
4677     dSP;
4678     AV *array = MUTABLE_AV(POPs);
4679     const U8 gimme = GIMME_V;
4680     IV *iterp = Perl_av_iter_p(aTHX_ array);
4681     const IV current = (*iterp)++;
4682
4683     if (current > av_tindex(array)) {
4684         *iterp = 0;
4685         if (gimme == G_SCALAR)
4686             RETPUSHUNDEF;
4687         else
4688             RETURN;
4689     }
4690
4691     EXTEND(SP, 2);
4692     mPUSHi(current);
4693     if (gimme == G_ARRAY) {
4694         SV **const element = av_fetch(array, current, 0);
4695         PUSHs(element ? *element : &PL_sv_undef);
4696     }
4697     RETURN;
4698 }
4699
4700 /* also used for: pp_avalues()*/
4701 PP(pp_akeys)
4702 {
4703     dSP;
4704     AV *array = MUTABLE_AV(POPs);
4705     const U8 gimme = GIMME_V;
4706
4707     *Perl_av_iter_p(aTHX_ array) = 0;
4708
4709     if (gimme == G_SCALAR) {
4710         dTARGET;
4711         PUSHi(av_tindex(array) + 1);
4712     }
4713     else if (gimme == G_ARRAY) {
4714       if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4715         const I32 flags = is_lvalue_sub();
4716         if (flags && !(flags & OPpENTERSUB_INARGS))
4717             /* diag_listed_as: Can't modify %s in %s */
4718             Perl_croak(aTHX_
4719                       "Can't modify keys on array in list assignment");
4720       }
4721       {
4722         IV n = Perl_av_len(aTHX_ array);
4723         IV i;
4724
4725         EXTEND(SP, n + 1);
4726
4727         if (  PL_op->op_type == OP_AKEYS
4728            || (  PL_op->op_type == OP_AVHVSWITCH
4729               && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS  ))
4730         {
4731             for (i = 0;  i <= n;  i++) {
4732                 mPUSHi(i);
4733             }
4734         }
4735         else {
4736             for (i = 0;  i <= n;  i++) {
4737                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4738                 PUSHs(elem ? *elem : &PL_sv_undef);
4739             }
4740         }
4741       }
4742     }
4743     RETURN;
4744 }
4745
4746 /* Associative arrays. */
4747
4748 PP(pp_each)
4749 {
4750     dSP;
4751     HV * hash = MUTABLE_HV(POPs);
4752     HE *entry;
4753     const U8 gimme = GIMME_V;
4754
4755     entry = hv_iternext(hash);
4756
4757     EXTEND(SP, 2);
4758     if (entry) {
4759         SV* const sv = hv_iterkeysv(entry);
4760         PUSHs(sv);
4761         if (gimme == G_ARRAY) {
4762             SV *val;
4763             val = hv_iterval(hash, entry);
4764             PUSHs(val);
4765         }
4766     }
4767     else if (gimme == G_SCALAR)
4768         RETPUSHUNDEF;
4769
4770     RETURN;
4771 }
4772
4773 STATIC OP *
4774 S_do_delete_local(pTHX)
4775 {
4776     dSP;
4777     const U8 gimme = GIMME_V;
4778     const MAGIC *mg;
4779     HV *stash;
4780     const bool sliced = !!(PL_op->op_private & OPpSLICE);
4781     SV **unsliced_keysv = sliced ? NULL : sp--;
4782     SV * const osv = POPs;
4783     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4784     dORIGMARK;
4785     const bool tied = SvRMAGICAL(osv)
4786                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4787     const bool can_preserve = SvCANEXISTDELETE(osv);
4788     const U32 type = SvTYPE(osv);
4789     SV ** const end = sliced ? SP : unsliced_keysv;
4790
4791     if (type == SVt_PVHV) {                     /* hash element */
4792             HV * const hv = MUTABLE_HV(osv);
4793             while (++MARK <= end) {
4794                 SV * const keysv = *MARK;
4795                 SV *sv = NULL;
4796                 bool preeminent = TRUE;
4797                 if (can_preserve)
4798                     preeminent = hv_exists_ent(hv, keysv, 0);
4799                 if (tied) {
4800                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4801                     if (he)
4802                         sv = HeVAL(he);
4803                     else
4804                         preeminent = FALSE;
4805                 }
4806                 else {
4807                     sv = hv_delete_ent(hv, keysv, 0, 0);
4808                     if (preeminent)
4809                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4810                 }
4811                 if (preeminent) {
4812                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4813                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4814                     if (tied) {
4815                         *MARK = sv_mortalcopy(sv);
4816                         mg_clear(sv);
4817                     } else
4818                         *MARK = sv;
4819                 }
4820                 else {
4821                     SAVEHDELETE(hv, keysv);
4822                     *MARK = &PL_sv_undef;
4823                 }
4824             }
4825     }
4826     else if (type == SVt_PVAV) {                  /* array element */
4827             if (PL_op->op_flags & OPf_SPECIAL) {
4828                 AV * const av = MUTABLE_AV(osv);
4829                 while (++MARK <= end) {
4830                     SSize_t idx = SvIV(*MARK);
4831                     SV *sv = NULL;
4832                     bool preeminent = TRUE;
4833                     if (can_preserve)
4834                         preeminent = av_exists(av, idx);
4835                     if (tied) {
4836                         SV **svp = av_fetch(av, idx, 1);
4837                         if (svp)
4838                             sv = *svp;
4839                         else
4840                             preeminent = FALSE;
4841                     }
4842                     else {
4843                         sv = av_delete(av, idx, 0);
4844                         if (preeminent)
4845                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4846                     }
4847                     if (preeminent) {
4848                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4849                         if (tied) {
4850                             *MARK = sv_mortalcopy(sv);
4851                             mg_clear(sv);
4852                         } else
4853                             *MARK = sv;
4854                     }
4855                     else {
4856                         SAVEADELETE(av, idx);
4857                         *MARK = &PL_sv_undef;
4858                     }
4859                 }
4860             }
4861             else
4862                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4863     }
4864     else
4865             DIE(aTHX_ "Not a HASH reference");
4866     if (sliced) {
4867         if (gimme == G_VOID)
4868             SP = ORIGMARK;
4869         else if (gimme == G_SCALAR) {
4870             MARK = ORIGMARK;
4871             if (SP > MARK)
4872                 *++MARK = *SP;
4873             else
4874                 *++MARK = &PL_sv_undef;
4875             SP = MARK;
4876         }
4877     }
4878     else if (gimme != G_VOID)
4879         PUSHs(*unsliced_keysv);
4880
4881     RETURN;
4882 }
4883
4884 PP(pp_delete)
4885 {
4886     dSP;
4887     U8 gimme;
4888     I32 discard;
4889
4890     if (PL_op->op_private & OPpLVAL_INTRO)
4891         return do_delete_local();
4892
4893     gimme = GIMME_V;
4894     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4895
4896     if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
4897         dMARK; dORIGMARK;
4898         HV * const hv = MUTABLE_HV(POPs);
4899         const U32 hvtype = SvTYPE(hv);
4900         int skip = 0;
4901         if (PL_op->op_private & OPpKVSLICE) {
4902             SSize_t items = SP - MARK;
4903
4904             MEXTEND(SP,items);
4905             while (items > 1) {
4906                 *(MARK+items*2-1) = *(MARK+items);
4907                 items--;
4908             }
4909             items = SP - MARK;
4910             SP += items;
4911             skip = 1;
4912         }
4913         if (hvtype == SVt_PVHV) {                       /* hash element */
4914             while ((MARK += (1+skip)) <= SP) {
4915                 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
4916                 *MARK = sv ? sv : &PL_sv_undef;
4917             }
4918         }
4919         else if (hvtype == SVt_PVAV) {                  /* array element */
4920             if (PL_op->op_flags & OPf_SPECIAL) {
4921                 while ((MARK += (1+skip)) <= SP) {
4922                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
4923                     *MARK = sv ? sv : &PL_sv_undef;
4924                 }
4925             }
4926         }
4927         else
4928             DIE(aTHX_ "Not a HASH reference");
4929         if (discard)
4930             SP = ORIGMARK;
4931         else if (gimme == G_SCALAR) {
4932             MARK = ORIGMARK;
4933             if (SP > MARK)
4934                 *++MARK = *SP;
4935             else
4936                 *++MARK = &PL_sv_undef;
4937             SP = MARK;
4938         }
4939     }
4940     else {
4941         SV *keysv = POPs;
4942         HV * const hv = MUTABLE_HV(POPs);
4943         SV *sv = NULL;
4944         if (SvTYPE(hv) == SVt_PVHV)
4945             sv = hv_delete_ent(hv, keysv, discard, 0);
4946         else if (SvTYPE(hv) == SVt_PVAV) {
4947             if (PL_op->op_flags & OPf_SPECIAL)
4948                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4949             else
4950                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4951         }
4952         else
4953             DIE(aTHX_ "Not a HASH reference");
4954         if (!sv)
4955             sv = &PL_sv_undef;
4956         if (!discard)
4957             PUSHs(sv);
4958     }
4959     RETURN;
4960 }
4961
4962 PP(pp_exists)
4963 {
4964     dSP;
4965     SV *tmpsv;
4966     HV *hv;
4967
4968     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4969         GV *gv;
4970         SV * const sv = POPs;
4971         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4972         if (cv)
4973             RETPUSHYES;
4974         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4975             RETPUSHYES;
4976         RETPUSHNO;
4977     }
4978     tmpsv = POPs;
4979     hv = MUTABLE_HV(POPs);
4980     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4981         if (hv_exists_ent(hv, tmpsv, 0))
4982             RETPUSHYES;
4983     }
4984     else if (SvTYPE(hv) == SVt_PVAV) {
4985         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4986             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4987                 RETPUSHYES;
4988         }
4989     }
4990     else {
4991         DIE(aTHX_ "Not a HASH reference");
4992     }
4993     RETPUSHNO;
4994 }
4995
4996 PP(pp_hslice)
4997 {
4998     dSP; dMARK; dORIGMARK;
4999     HV * const hv = MUTABLE_HV(POPs);
5000     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5001     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5002     bool can_preserve = FALSE;
5003
5004     if (localizing) {
5005         MAGIC *mg;
5006         HV *stash;
5007
5008         if (SvCANEXISTDELETE(hv))
5009             can_preserve = TRUE;
5010     }
5011
5012     while (++MARK <= SP) {
5013         SV * const keysv = *MARK;
5014         SV **svp;
5015         HE *he;
5016         bool preeminent = TRUE;
5017
5018         if (localizing && can_preserve) {
5019             /* If we can determine whether the element exist,
5020              * try to preserve the existenceness of a tied hash
5021              * element by using EXISTS and DELETE if possible.
5022              * Fallback to FETCH and STORE otherwise. */
5023             preeminent = hv_exists_ent(hv, keysv, 0);
5024         }
5025
5026         he = hv_fetch_ent(hv, keysv, lval, 0);
5027         svp = he ? &HeVAL(he) : NULL;
5028
5029         if (lval) {
5030             if (!svp || !*svp || *svp == &PL_sv_undef) {
5031                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5032             }
5033             if (localizing) {
5034                 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5035                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5036                 else if (preeminent)
5037                     save_helem_flags(hv, keysv, svp,
5038                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5039                 else
5040                     SAVEHDELETE(hv, keysv);
5041             }
5042         }
5043         *MARK = svp && *svp ? *svp : &PL_sv_undef;
5044     }
5045     if (GIMME_V != G_ARRAY) {
5046         MARK = ORIGMARK;
5047         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5048         SP = MARK;
5049     }
5050     RETURN;
5051 }
5052
5053 PP(pp_kvhslice)
5054 {
5055     dSP; dMARK;
5056     HV * const hv = MUTABLE_HV(POPs);
5057     I32 lval = (PL_op->op_flags & OPf_MOD);
5058     SSize_t items = SP - MARK;
5059
5060     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5061        const I32 flags = is_lvalue_sub();
5062        if (flags) {
5063            if (!(flags & OPpENTERSUB_INARGS))
5064                /* diag_listed_as: Can't modify %s in %s */
5065                Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5066                                  GIMME_V == G_ARRAY ? "list" : "scalar");
5067            lval = flags;
5068        }
5069     }
5070
5071     MEXTEND(SP,items);
5072     while (items > 1) {
5073         *(MARK+items*2-1) = *(MARK+items);
5074         items--;
5075     }
5076     items = SP-MARK;
5077     SP += items;
5078
5079     while (++MARK <= SP) {
5080         SV * const keysv = *MARK;
5081         SV **svp;
5082         HE *he;
5083
5084         he = hv_fetch_ent(hv, keysv, lval, 0);
5085         svp = he ? &HeVAL(he) : NULL;
5086
5087         if (lval) {
5088             if (!svp || !*svp || *svp == &PL_sv_undef) {
5089                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5090             }
5091             *MARK = sv_mortalcopy(*MARK);
5092         }
5093         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5094     }
5095     if (GIMME_V != G_ARRAY) {
5096         MARK = SP - items*2;
5097         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5098         SP = MARK;
5099     }
5100     RETURN;
5101 }
5102
5103 /* List operators. */
5104
5105 PP(pp_list)
5106 {
5107     I32 markidx = POPMARK;
5108     if (GIMME_V != G_ARRAY) {
5109         SV **mark = PL_stack_base + markidx;
5110         dSP;
5111         EXTEND(SP, 1);          /* in case no arguments, as in @empty */
5112         if (++MARK <= SP)
5113             *MARK = *SP;                /* unwanted list, return last item */
5114         else
5115             *MARK = &PL_sv_undef;
5116         SP = MARK;
5117         PUTBACK;
5118     }
5119     return NORMAL;
5120 }
5121
5122 PP(pp_lslice)
5123 {
5124     dSP;
5125     SV ** const lastrelem = PL_stack_sp;
5126     SV ** const lastlelem = PL_stack_base + POPMARK;
5127     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5128     SV ** const firstrelem = lastlelem + 1;
5129     const U8 mod = PL_op->op_flags & OPf_MOD;
5130
5131     const I32 max = lastrelem - lastlelem;
5132     SV **lelem;
5133
5134     if (GIMME_V != G_ARRAY) {
5135         if (lastlelem < firstlelem) {
5136             EXTEND(SP, 1);
5137             *firstlelem = &PL_sv_undef;
5138         }
5139         else {
5140             I32 ix = SvIV(*lastlelem);
5141             if (ix < 0)
5142                 ix += max;
5143             if (ix < 0 || ix >= max)
5144                 *firstlelem = &PL_sv_undef;
5145             else
5146                 *firstlelem = firstrelem[ix];
5147         }
5148         SP = firstlelem;
5149         RETURN;
5150     }
5151
5152     if (max == 0) {
5153         SP = firstlelem - 1;
5154         RETURN;
5155     }
5156
5157     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5158         I32 ix = SvIV(*lelem);
5159         if (ix < 0)
5160             ix += max;
5161         if (ix < 0 || ix >= max)
5162             *lelem = &PL_sv_undef;
5163         else {
5164             if (!(*lelem = firstrelem[ix]))
5165                 *lelem = &PL_sv_undef;
5166             else if (mod && SvPADTMP(*lelem)) {
5167                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5168             }
5169         }
5170     }
5171     SP = lastlelem;
5172     RETURN;
5173 }
5174
5175 PP(pp_anonlist)
5176 {
5177     dSP; dMARK;
5178     const I32 items = SP - MARK;
5179     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5180     SP = MARK;
5181     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5182             ? newRV_noinc(av) : av);
5183     RETURN;
5184 }
5185
5186 PP(pp_anonhash)
5187 {
5188     dSP; dMARK; dORIGMARK;
5189     HV* const hv = newHV();
5190     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5191                                     ? newRV_noinc(MUTABLE_SV(hv))
5192                                     : MUTABLE_SV(hv) );
5193
5194     while (MARK < SP) {
5195         SV * const key =
5196             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5197         SV *val;
5198         if (MARK < SP)
5199         {
5200             MARK++;
5201             SvGETMAGIC(*MARK);
5202             val = newSV(0);
5203             sv_setsv_nomg(val, *MARK);
5204         }
5205         else
5206         {
5207             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5208             val = newSV(0);
5209         }
5210         (void)hv_store_ent(hv,key,val,0);
5211     }
5212     SP = ORIGMARK;
5213     XPUSHs(retval);
5214     RETURN;
5215 }
5216
5217 PP(pp_splice)
5218 {
5219     dSP; dMARK; dORIGMARK;
5220     int num_args = (SP - MARK);
5221     AV *ary = MUTABLE_AV(*++MARK);
5222     SV **src;
5223     SV **dst;
5224     SSize_t i;
5225     SSize_t offset;
5226     SSize_t length;
5227     SSize_t newlen;
5228     SSize_t after;
5229     SSize_t diff;
5230     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5231
5232     if (mg) {
5233         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5234                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5235                                     sp - mark);
5236     }
5237
5238     if (SvREADONLY(ary))
5239         Perl_croak_no_modify();
5240
5241     SP++;
5242
5243     if (++MARK < SP) {
5244         offset = i = SvIV(*MARK);
5245         if (offset < 0)
5246             offset += AvFILLp(ary) + 1;
5247         if (offset < 0)
5248             DIE(aTHX_ PL_no_aelem, i);
5249         if (++MARK < SP) {
5250             length = SvIVx(*MARK++);
5251             if (length < 0) {
5252                 length += AvFILLp(ary) - offset + 1;
5253                 if (length < 0)
5254                     length = 0;
5255             }
5256         }
5257         else
5258             length = AvMAX(ary) + 1;            /* close enough to infinity */
5259     }
5260     else {
5261         offset = 0;
5262         length = AvMAX(ary) + 1;
5263     }
5264     if (offset > AvFILLp(ary) + 1) {
5265         if (num_args > 2)
5266             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5267         offset = AvFILLp(ary) + 1;
5268     }
5269     after = AvFILLp(ary) + 1 - (offset + length);
5270     if (after < 0) {                            /* not that much array */
5271         length += after;                        /* offset+length now in array */
5272         after = 0;
5273         if (!AvALLOC(ary))
5274             av_extend(ary, 0);
5275     }
5276
5277     /* At this point, MARK .. SP-1 is our new LIST */
5278
5279     newlen = SP - MARK;
5280     diff = newlen - length;
5281     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5282         av_reify(ary);
5283
5284     /* make new elements SVs now: avoid problems if they're from the array */
5285     for (dst = MARK, i = newlen; i; i--) {
5286         SV * const h = *dst;
5287         *dst++ = newSVsv(h);
5288     }
5289
5290     if (diff < 0) {                             /* shrinking the area */
5291         SV **tmparyval = NULL;
5292         if (newlen) {
5293             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5294             Copy(MARK, tmparyval, newlen, SV*);
5295         }
5296
5297         MARK = ORIGMARK + 1;
5298         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5299             const bool real = cBOOL(AvREAL(ary));
5300             MEXTEND(MARK, length);
5301             if (real)
5302                 EXTEND_MORTAL(length);
5303             for (i = 0, dst = MARK; i < length; i++) {
5304                 if ((*dst = AvARRAY(ary)[i+offset])) {
5305                   if (real)
5306                     sv_2mortal(*dst);   /* free them eventually */
5307                 }
5308                 else
5309                     *dst = &PL_sv_undef;
5310                 dst++;
5311             }
5312             MARK += length - 1;
5313         }
5314         else {
5315             *MARK = AvARRAY(ary)[offset+length-1];
5316             if (AvREAL(ary)) {
5317                 sv_2mortal(*MARK);
5318                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5319                     SvREFCNT_dec(*dst++);       /* free them now */
5320             }
5321             if (!*MARK)
5322                 *MARK = &PL_sv_undef;
5323         }
5324         AvFILLp(ary) += diff;
5325
5326         /* pull up or down? */
5327
5328         if (offset < after) {                   /* easier to pull up */
5329             if (offset) {                       /* esp. if nothing to pull */
5330                 src = &AvARRAY(ary)[offset-1];
5331                 dst = src - diff;               /* diff is negative */
5332                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5333                     *dst-- = *src--;
5334             }
5335             dst = AvARRAY(ary);
5336             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5337             AvMAX(ary) += diff;
5338         }
5339         else {
5340             if (after) {                        /* anything to pull down? */
5341                 src = AvARRAY(ary) + offset + length;
5342                 dst = src + diff;               /* diff is negative */
5343                 Move(src, dst, after, SV*);
5344             }
5345             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5346                                                 /* avoid later double free */
5347         }
5348         i = -diff;
5349         while (i)
5350             dst[--i] = NULL;
5351
5352         if (newlen) {
5353             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5354             Safefree(tmparyval);
5355         }
5356     }
5357     else {                                      /* no, expanding (or same) */
5358         SV** tmparyval = NULL;
5359         if (length) {
5360             Newx(tmparyval, length, SV*);       /* so remember deletion */
5361             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5362         }
5363
5364         if (diff > 0) {                         /* expanding */
5365             /* push up or down? */
5366             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5367                 if (offset) {
5368                     src = AvARRAY(ary);
5369                     dst = src - diff;
5370                     Move(src, dst, offset, SV*);
5371                 }
5372                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5373                 AvMAX(ary) += diff;
5374                 AvFILLp(ary) += diff;
5375             }
5376             else {
5377                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5378                     av_extend(ary, AvFILLp(ary) + diff);
5379                 AvFILLp(ary) += diff;
5380
5381                 if (after) {
5382                     dst = AvARRAY(ary) + AvFILLp(ary);
5383                     src = dst - diff;
5384                     for (i = after; i; i--) {
5385                         *dst-- = *src--;
5386                     }
5387                 }
5388             }
5389         }
5390
5391         if (newlen) {
5392             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5393         }
5394
5395         MARK = ORIGMARK + 1;
5396         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5397             if (length) {
5398                 const bool real = cBOOL(AvREAL(ary));
5399                 if (real)
5400                     EXTEND_MORTAL(length);
5401                 for (i = 0, dst = MARK; i < length; i++) {
5402                     if ((*dst = tmparyval[i])) {
5403                       if (real)
5404                         sv_2mortal(*dst);       /* free them eventually */
5405                     }
5406                     else *dst = &PL_sv_undef;
5407                     dst++;
5408                 }
5409             }
5410             MARK += length - 1;
5411         }
5412         else if (length--) {
5413             *MARK = tmparyval[length];
5414             if (AvREAL(ary)) {
5415                 sv_2mortal(*MARK);
5416                 while (length-- > 0)
5417                     SvREFCNT_dec(tmparyval[length]);
5418             }
5419             if (!*MARK)
5420                 *MARK = &PL_sv_undef;
5421         }
5422         else
5423             *MARK = &PL_sv_undef;
5424         Safefree(tmparyval);
5425     }
5426
5427     if (SvMAGICAL(ary))
5428         mg_set(MUTABLE_SV(ary));
5429
5430     SP = MARK;
5431     RETURN;
5432 }
5433
5434 PP(pp_push)
5435 {
5436     dSP; dMARK; dORIGMARK; dTARGET;
5437     AV * const ary = MUTABLE_AV(*++MARK);
5438     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5439
5440     if (mg) {
5441         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5442         PUSHMARK(MARK);
5443         PUTBACK;
5444         ENTER_with_name("call_PUSH");
5445         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5446         LEAVE_with_name("call_PUSH");
5447         /* SPAGAIN; not needed: SP is assigned to immediately below */
5448     }
5449     else {
5450         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5451          * only need to save locally, not on the save stack */
5452         U16 old_delaymagic = PL_delaymagic;
5453
5454         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5455         PL_delaymagic = DM_DELAY;
5456         for (++MARK; MARK <= SP; MARK++) {
5457             SV *sv;
5458             if (*MARK) SvGETMAGIC(*MARK);
5459             sv = newSV(0);
5460             if (*MARK)
5461                 sv_setsv_nomg(sv, *MARK);
5462             av_store(ary, AvFILLp(ary)+1, sv);
5463         }
5464         if (PL_delaymagic & DM_ARRAY_ISA)
5465             mg_set(MUTABLE_SV(ary));
5466         PL_delaymagic = old_delaymagic;
5467     }
5468     SP = ORIGMARK;
5469     if (OP_GIMME(PL_op, 0) != G_VOID) {
5470         PUSHi( AvFILL(ary) + 1 );
5471     }
5472     RETURN;
5473 }
5474
5475 /* also used for: pp_pop()*/
5476 PP(pp_shift)
5477 {
5478     dSP;
5479     AV * const av = PL_op->op_flags & OPf_SPECIAL
5480         ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5481     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5482     EXTEND(SP, 1);
5483     assert (sv);
5484     if (AvREAL(av))
5485         (void)sv_2mortal(sv);
5486     PUSHs(sv);
5487     RETURN;
5488 }
5489
5490 PP(pp_unshift)
5491 {
5492     dSP; dMARK; dORIGMARK; dTARGET;
5493     AV *ary = MUTABLE_AV(*++MARK);
5494     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5495
5496     if (mg) {
5497         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5498         PUSHMARK(MARK);
5499         PUTBACK;
5500         ENTER_with_name("call_UNSHIFT");
5501         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5502         LEAVE_with_name("call_UNSHIFT");
5503         /* SPAGAIN; not needed: SP is assigned to immediately below */
5504     }
5505     else {
5506         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5507          * only need to save locally, not on the save stack */
5508         U16 old_delaymagic = PL_delaymagic;
5509         SSize_t i = 0;
5510
5511         av_unshift(ary, SP - MARK);
5512         PL_delaymagic = DM_DELAY;
5513         while (MARK < SP) {
5514             SV * const sv = newSVsv(*++MARK);
5515             (void)av_store(ary, i++, sv);
5516         }
5517         if (PL_delaymagic & DM_ARRAY_ISA)
5518             mg_set(MUTABLE_SV(ary));
5519         PL_delaymagic = old_delaymagic;
5520     }
5521     SP = ORIGMARK;
5522     if (OP_GIMME(PL_op, 0) != G_VOID) {
5523         PUSHi( AvFILL(ary) + 1 );
5524     }
5525     RETURN;
5526 }
5527
5528 PP(pp_reverse)
5529 {
5530     dSP; dMARK;
5531
5532     if (GIMME_V == G_ARRAY) {
5533         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5534             AV *av;
5535
5536             /* See pp_sort() */
5537             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5538             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5539             av = MUTABLE_AV((*SP));
5540             /* In-place reversing only happens in void context for the array
5541              * assignment. We don't need to push anything on the stack. */
5542             SP = MARK;
5543
5544             if (SvMAGICAL(av)) {
5545                 SSize_t i, j;
5546                 SV *tmp = sv_newmortal();
5547                 /* For SvCANEXISTDELETE */
5548                 HV *stash;
5549                 const MAGIC *mg;
5550                 bool can_preserve = SvCANEXISTDELETE(av);
5551
5552                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5553                     SV *begin, *end;
5554
5555                     if (can_preserve) {
5556                         if (!av_exists(av, i)) {
5557                             if (av_exists(av, j)) {
5558                                 SV *sv = av_delete(av, j, 0);
5559                                 begin = *av_fetch(av, i, TRUE);
5560                                 sv_setsv_mg(begin, sv);
5561                             }
5562                             continue;
5563                         }
5564                         else if (!av_exists(av, j)) {
5565                             SV *sv = av_delete(av, i, 0);
5566                             end = *av_fetch(av, j, TRUE);
5567                             sv_setsv_mg(end, sv);
5568                             continue;
5569                         }
5570                     }
5571
5572                     begin = *av_fetch(av, i, TRUE);
5573                     end   = *av_fetch(av, j, TRUE);
5574                     sv_setsv(tmp,      begin);
5575                     sv_setsv_mg(begin, end);
5576                     sv_setsv_mg(end,   tmp);
5577                 }
5578             }
5579             else {
5580                 SV **begin = AvARRAY(av);
5581
5582                 if (begin) {
5583                     SV **end   = begin + AvFILLp(av);
5584
5585                     while (begin < end) {
5586                         SV * const tmp = *begin;
5587                         *begin++ = *end;
5588                         *end--   = tmp;
5589
5590                         if (tmp && SvWEAKREF(tmp))
5591                             sv_rvunweaken(tmp);
5592                     }
5593
5594                     /* make sure we catch the middle element */
5595                     if (begin == end && *begin && SvWEAKREF(*begin))
5596                         sv_rvunweaken(*begin);
5597                 }
5598             }
5599         }
5600         else {
5601             SV **oldsp = SP;
5602             MARK++;
5603             while (MARK < SP) {
5604                 SV * const tmp = *MARK;
5605                 *MARK++ = *SP;
5606                 *SP--   = tmp;
5607             }
5608             /* safe as long as stack cannot get extended in the above */
5609             SP = oldsp;
5610         }
5611     }
5612     else {
5613         char *up;
5614         dTARGET;
5615         STRLEN len;
5616
5617         SvUTF8_off(TARG);                               /* decontaminate */
5618         if (SP - MARK > 1)
5619             do_join(TARG, &PL_sv_no, MARK, SP);
5620         else if (SP > MARK)
5621             sv_setsv(TARG, *SP);
5622         else {
5623             sv_setsv(TARG, DEFSV);
5624             EXTEND(SP, 1);
5625         }
5626
5627         up = SvPV_force(TARG, len);
5628         if (len > 1) {
5629             char *down;
5630             if (DO_UTF8(TARG)) {        /* first reverse each character */
5631                 U8* s = (U8*)SvPVX(TARG);
5632                 const U8* send = (U8*)(s + len);
5633                 while (s < send) {
5634                     if (UTF8_IS_INVARIANT(*s)) {
5635                         s++;
5636                         continue;
5637                     }
5638                     else {
5639                         if (!utf8_to_uvchr_buf(s, send, 0))
5640                             break;
5641                         up = (char*)s;
5642                         s += UTF8SKIP(s);
5643                         down = (char*)(s - 1);
5644                         /* reverse this character */
5645                         while (down > up) {
5646                             const char tmp = *up;
5647                             *up++ = *down;
5648                             *down-- = tmp;
5649                         }
5650                     }
5651                 }
5652                 up = SvPVX(TARG);
5653             }
5654             down = SvPVX(TARG) + len - 1;
5655             while (down > up) {
5656                 const char tmp = *up;
5657                 *up++ = *down;
5658                 *down-- = tmp;
5659             }
5660             (void)SvPOK_only_UTF8(TARG);
5661         }
5662         SP = MARK + 1;
5663         SETTARG;
5664     }
5665     RETURN;
5666 }
5667
5668 PP(pp_split)
5669 {
5670     dSP; dTARG;
5671     AV *ary = (   (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5672                && (PL_op->op_flags & OPf_STACKED))      /* @{expr} = split */
5673                ? (AV *)POPs : NULL;
5674     IV limit = POPi;                    /* note, negative is forever */
5675     SV * const sv = POPs;
5676     STRLEN len;
5677     const char *s = SvPV_const(sv, len);
5678     const bool do_utf8 = DO_UTF8(sv);
5679     const bool in_uni_8_bit = IN_UNI_8_BIT;
5680     const char *strend = s + len;
5681     PMOP *pm = cPMOPx(PL_op);
5682     REGEXP *rx;
5683     SV *dstr;
5684     const char *m;
5685     SSize_t iters = 0;
5686     const STRLEN slen = do_utf8
5687                         ? utf8_length((U8*)s, (U8*)strend)
5688                         : (STRLEN)(strend - s);
5689     SSize_t maxiters = slen + 10;
5690     I32 trailing_empty = 0;
5691     const char *orig;
5692     const IV origlimit = limit;
5693     I32 realarray = 0;
5694     I32 base;
5695     const U8 gimme = GIMME_V;
5696     bool gimme_scalar;
5697     I32 oldsave = PL_savestack_ix;
5698     U32 make_mortal = SVs_TEMP;
5699     bool multiline = 0;
5700     MAGIC *mg = NULL;
5701
5702     rx = PM_GETRE(pm);
5703
5704     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5705              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5706
5707     /* handle @ary = split(...) optimisation */
5708     if (PL_op->op_private & OPpSPLIT_ASSIGN) {
5709         if (!(PL_op->op_flags & OPf_STACKED)) {
5710             if (PL_op->op_private & OPpSPLIT_LEX) {
5711                 if (PL_op->op_private & OPpLVAL_INTRO)
5712                     SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5713                 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
5714             }
5715             else {
5716                 GV *gv =
5717 #ifdef USE_ITHREADS
5718                         MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5719 #else
5720                         pm->op_pmreplrootu.op_pmtargetgv;
5721 #endif
5722                 if (PL_op->op_private & OPpLVAL_INTRO)
5723                     ary = save_ary(gv);
5724                 else
5725                     ary = GvAVn(gv);
5726             }
5727             /* skip anything pushed by OPpLVAL_INTRO above */
5728             oldsave = PL_savestack_ix;
5729         }
5730
5731         realarray = 1;
5732         PUTBACK;
5733         av_extend(ary,0);
5734         (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5735         av_clear(ary);
5736         SPAGAIN;
5737         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5738             PUSHMARK(SP);
5739             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5740         }
5741         else {
5742             if (!AvREAL(ary)) {
5743                 I32 i;
5744                 AvREAL_on(ary);
5745                 AvREIFY_off(ary);
5746                 for (i = AvFILLp(ary); i >= 0; i--)
5747                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5748             }
5749             /* temporarily switch stacks */
5750             SAVESWITCHSTACK(PL_curstack, ary);
5751             make_mortal = 0;
5752         }
5753     }
5754
5755     base = SP - PL_stack_base;
5756     orig = s;
5757     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5758         if (do_utf8) {
5759             while (s < strend && isSPACE_utf8_safe(s, strend))
5760                 s += UTF8SKIP(s);
5761         }
5762         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5763             while (s < strend && isSPACE_LC(*s))
5764                 s++;
5765         }
5766         else if (in_uni_8_bit) {
5767             while (s < strend && isSPACE_L1(*s))
5768                 s++;
5769         }
5770         else {
5771             while (s < strend && isSPACE(*s))
5772                 s++;
5773         }
5774     }
5775     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5776         multiline = 1;
5777     }
5778
5779     gimme_scalar = gimme == G_SCALAR && !ary;
5780
5781     if (!limit)
5782         limit = maxiters + 2;
5783     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5784         while (--limit) {
5785             m = s;
5786             /* this one uses 'm' and is a negative test */
5787             if (do_utf8) {
5788                 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
5789                     const int t = UTF8SKIP(m);
5790                     /* isSPACE_utf8_safe returns FALSE for malform utf8 */
5791                     if (strend - m < t)
5792                         m = strend;
5793                     else
5794                         m += t;
5795                 }
5796             }
5797             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5798             {
5799                 while (m < strend && !isSPACE_LC(*m))
5800                     ++m;
5801             }
5802             else if (in_uni_8_bit) {
5803                 while (m < strend && !isSPACE_L1(*m))
5804                     ++m;
5805             } else {
5806                 while (m < strend && !isSPACE(*m))
5807                     ++m;
5808             }
5809             if (m >= strend)
5810                 break;
5811
5812             if (gimme_scalar) {
5813                 iters++;
5814                 if (m-s == 0)
5815                     trailing_empty++;
5816                 else
5817                     trailing_empty = 0;
5818             } else {
5819                 dstr = newSVpvn_flags(s, m-s,
5820                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5821                 XPUSHs(dstr);
5822             }
5823
5824             /* skip the whitespace found last */
5825             if (do_utf8)
5826                 s = m + UTF8SKIP(m);
5827             else
5828                 s = m + 1;
5829
5830             /* this one uses 's' and is a positive test */
5831             if (do_utf8) {
5832                 while (s < strend && isSPACE_utf8_safe(s, strend) )
5833                     s +=  UTF8SKIP(s);
5834             }
5835             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5836             {
5837                 while (s < strend && isSPACE_LC(*s))
5838                     ++s;
5839             }
5840             else if (in_uni_8_bit) {
5841                 while (s < strend && isSPACE_L1(*s))
5842                     ++s;
5843             } else {
5844                 while (s < strend && isSPACE(*s))
5845                     ++s;
5846             }
5847         }
5848     }
5849     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5850         while (--limit) {
5851             for (m = s; m < strend && *m != '\n'; m++)
5852                 ;
5853             m++;
5854             if (m >= strend)
5855                 break;
5856
5857             if (gimme_scalar) {
5858                 iters++;
5859                 if (m-s == 0)
5860                     trailing_empty++;
5861                 else
5862                     trailing_empty = 0;
5863             } else {
5864                 dstr = newSVpvn_flags(s, m-s,
5865                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5866                 XPUSHs(dstr);
5867             }
5868             s = m;
5869         }
5870     }
5871     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5872         /*
5873           Pre-extend the stack, either the number of bytes or
5874           characters in the string or a limited amount, triggered by:
5875
5876           my ($x, $y) = split //, $str;
5877             or
5878           split //, $str, $i;
5879         */
5880         if (!gimme_scalar) {
5881             const IV items = limit - 1;
5882             /* setting it to -1 will trigger a panic in EXTEND() */
5883             const SSize_t sslen = slen > SSize_t_MAX ?  -1 : (SSize_t)slen;
5884             if (items >=0 && items < sslen)
5885                 EXTEND(SP, items);
5886             else
5887                 EXTEND(SP, sslen);
5888         }
5889
5890         if (do_utf8) {
5891             while (--limit) {
5892                 /* keep track of how many bytes we skip over */
5893                 m = s;
5894                 s += UTF8SKIP(s);
5895                 if (gimme_scalar) {
5896                     iters++;
5897                     if (s-m == 0)
5898                         trailing_empty++;
5899                     else
5900                         trailing_empty = 0;
5901                 } else {
5902                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5903
5904                     PUSHs(dstr);
5905                 }
5906
5907                 if (s >= strend)
5908                     break;
5909             }
5910         } else {
5911             while (--limit) {
5912                 if (gimme_scalar) {
5913                     iters++;
5914                 } else {
5915                     dstr = newSVpvn(s, 1);
5916
5917
5918                     if (make_mortal)
5919                         sv_2mortal(dstr);
5920
5921                     PUSHs(dstr);
5922                 }
5923
5924                 s++;
5925
5926                 if (s >= strend)
5927                     break;
5928             }
5929         }
5930     }
5931     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5932              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5933              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5934              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5935         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5936         SV * const csv = CALLREG_INTUIT_STRING(rx);
5937
5938         len = RX_MINLENRET(rx);
5939         if (len == 1 && !RX_UTF8(rx) && !tail) {
5940             const char c = *SvPV_nolen_const(csv);
5941             while (--limit) {
5942                 for (m = s; m < strend && *m != c; m++)
5943                     ;
5944                 if (m >= strend)
5945                     break;
5946                 if (gimme_scalar) {
5947                     iters++;
5948                     if (m-s == 0)
5949                         trailing_empty++;
5950                     else
5951                         trailing_empty = 0;
5952                 } else {
5953                     dstr = newSVpvn_flags(s, m-s,
5954                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5955                     XPUSHs(dstr);
5956                 }
5957                 /* The rx->minlen is in characters but we want to step
5958                  * s ahead by bytes. */
5959                 if (do_utf8)
5960                     s = (char*)utf8_hop((U8*)m, len);
5961                 else
5962                     s = m + len; /* Fake \n at the end */
5963             }
5964         }
5965         else {
5966             while (s < strend && --limit &&
5967               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5968                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5969             {
5970                 if (gimme_scalar) {
5971                     iters++;
5972                     if (m-s == 0)
5973                         trailing_empty++;
5974                     else
5975                         trailing_empty = 0;
5976                 } else {
5977                     dstr = newSVpvn_flags(s, m-s,
5978                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5979                     XPUSHs(dstr);
5980                 }
5981                 /* The rx->minlen is in characters but we want to step
5982                  * s ahead by bytes. */
5983                 if (do_utf8)
5984                     s = (char*)utf8_hop((U8*)m, len);
5985                 else
5986                     s = m + len; /* Fake \n at the end */
5987             }
5988         }
5989     }
5990     else {
5991         maxiters += slen * RX_NPARENS(rx);
5992         while (s < strend && --limit)
5993         {
5994             I32 rex_return;
5995             PUTBACK;
5996             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5997                                      sv, NULL, 0);
5998             SPAGAIN;
5999             if (rex_return == 0)
6000                 break;
6001             TAINT_IF(RX_MATCH_TAINTED(rx));
6002             /* we never pass the REXEC_COPY_STR flag, so it should
6003              * never get copied */
6004             assert(!RX_MATCH_COPIED(rx));
6005             m = RX_OFFS(rx)[0].start + orig;
6006
6007             if (gimme_scalar) {
6008                 iters++;
6009                 if (m-s == 0)
6010                     trailing_empty++;
6011                 else
6012                     trailing_empty = 0;
6013             } else {
6014                 dstr = newSVpvn_flags(s, m-s,
6015                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6016                 XPUSHs(dstr);
6017             }
6018             if (RX_NPARENS(rx)) {
6019                 I32 i;
6020                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6021                     s = RX_OFFS(rx)[i].start + orig;
6022                     m = RX_OFFS(rx)[i].end + orig;
6023
6024                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6025                        parens that didn't match -- they should be set to
6026                        undef, not the empty string */
6027                     if (gimme_scalar) {
6028                         iters++;
6029                         if (m-s == 0)
6030                             trailing_empty++;
6031                         else
6032                             trailing_empty = 0;
6033                     } else {
6034                         if (m >= orig && s >= orig) {
6035                             dstr = newSVpvn_flags(s, m-s,
6036                                                  (do_utf8 ? SVf_UTF8 : 0)
6037                                                   | make_mortal);
6038                         }
6039                         else
6040                             dstr = &PL_sv_undef;  /* undef, not "" */
6041                         XPUSHs(dstr);
6042                     }
6043
6044                 }
6045             }
6046             s = RX_OFFS(rx)[0].end + orig;
6047         }
6048     }
6049
6050     if (!gimme_scalar) {
6051         iters = (SP - PL_stack_base) - base;
6052     }
6053     if (iters > maxiters)
6054         DIE(aTHX_ "Split loop");
6055
6056     /* keep field after final delim? */
6057     if (s < strend || (iters && origlimit)) {
6058         if (!gimme_scalar) {
6059             const STRLEN l = strend - s;
6060             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6061             XPUSHs(dstr);
6062         }
6063         iters++;
6064     }
6065     else if (!origlimit) {
6066         if (gimme_scalar) {
6067             iters -= trailing_empty;
6068         } else {
6069             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6070                 if (TOPs && !make_mortal)
6071                     sv_2mortal(TOPs);
6072                 *SP-- = NULL;
6073                 iters--;
6074             }
6075         }
6076     }
6077
6078     PUTBACK;
6079     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6080     SPAGAIN;
6081     if (realarray) {
6082         if (!mg) {
6083             if (SvSMAGICAL(ary)) {
6084                 PUTBACK;
6085                 mg_set(MUTABLE_SV(ary));
6086                 SPAGAIN;
6087             }
6088             if (gimme == G_ARRAY) {
6089                 EXTEND(SP, iters);
6090                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6091                 SP += iters;
6092                 RETURN;
6093             }
6094         }
6095         else {
6096             PUTBACK;
6097             ENTER_with_name("call_PUSH");
6098             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6099             LEAVE_with_name("call_PUSH");
6100             SPAGAIN;
6101             if (gimme == G_ARRAY) {
6102                 SSize_t i;
6103                 /* EXTEND should not be needed - we just popped them */
6104                 EXTEND(SP, iters);
6105                 for (i=0; i < iters; i++) {
6106                     SV **svp = av_fetch(ary, i, FALSE);
6107                     PUSHs((svp) ? *svp : &PL_sv_undef);
6108                 }
6109                 RETURN;
6110             }
6111         }
6112     }
6113     else {
6114         if (gimme == G_ARRAY)
6115             RETURN;
6116     }
6117
6118     GETTARGET;
6119     XPUSHi(iters);
6120     RETURN;
6121 }
6122
6123 PP(pp_once)
6124 {
6125     dSP;
6126     SV *const sv = PAD_SVl(PL_op->op_targ);
6127
6128     if (SvPADSTALE(sv)) {
6129         /* First time. */
6130         SvPADSTALE_off(sv);
6131         RETURNOP(cLOGOP->op_other);
6132     }
6133     RETURNOP(cLOGOP->op_next);
6134 }
6135
6136 PP(pp_lock)
6137 {
6138     dSP;
6139     dTOPss;
6140     SV *retsv = sv;
6141     SvLOCK(sv);
6142     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6143      || SvTYPE(retsv) == SVt_PVCV) {
6144         retsv = refto(retsv);
6145     }
6146     SETs(retsv);
6147     RETURN;
6148 }
6149
6150
6151 /* used for: pp_padany(), pp_custom(); plus any system ops
6152  * that aren't implemented on a particular platform */
6153
6154 PP(unimplemented_op)
6155 {
6156     const Optype op_type = PL_op->op_type;
6157     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6158        with out of range op numbers - it only "special" cases op_custom.
6159        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6160        if we get here for a custom op then that means that the custom op didn't
6161        have an implementation. Given that OP_NAME() looks up the custom op
6162        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6163        registers &PL_unimplemented_op as the address of their custom op.
6164        NULL doesn't generate a useful error message. "custom" does. */
6165     const char *const name = op_type >= OP_max
6166         ? "[out of range]" : PL_op_name[PL_op->op_type];
6167     if(OP_IS_SOCKET(op_type))
6168         DIE(aTHX_ PL_no_sock_func, name);
6169     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6170 }
6171
6172 static void
6173 S_maybe_unwind_defav(pTHX)
6174 {
6175     if (CX_CUR()->cx_type & CXp_HASARGS) {
6176         PERL_CONTEXT *cx = CX_CUR();
6177
6178         assert(CxHASARGS(cx));
6179         cx_popsub_args(cx);
6180         cx->cx_type &= ~CXp_HASARGS;
6181     }
6182 }
6183
6184 /* For sorting out arguments passed to a &CORE:: subroutine */
6185 PP(pp_coreargs)
6186 {
6187     dSP;
6188     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6189     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6190     AV * const at_ = GvAV(PL_defgv);
6191     SV **svp = at_ ? AvARRAY(at_) : NULL;
6192     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6193     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6194     bool seen_question = 0;
6195     const char *err = NULL;
6196     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6197
6198     /* Count how many args there are first, to get some idea how far to
6199        extend the stack. */
6200     while (oa) {
6201         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6202         maxargs++;
6203         if (oa & OA_OPTIONAL) seen_question = 1;
6204         if (!seen_question) minargs++;
6205         oa >>= 4;
6206     }
6207
6208     if(numargs < minargs) err = "Not enough";
6209     else if(numargs > maxargs) err = "Too many";
6210     if (err)
6211         /* diag_listed_as: Too many arguments for %s */
6212         Perl_croak(aTHX_
6213           "%s arguments for %s", err,
6214            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6215         );
6216
6217     /* Reset the stack pointer.  Without this, we end up returning our own
6218        arguments in list context, in addition to the values we are supposed
6219        to return.  nextstate usually does this on sub entry, but we need
6220        to run the next op with the caller's hints, so we cannot have a
6221        nextstate. */
6222     SP = PL_stack_base + CX_CUR()->blk_oldsp;
6223
6224     if(!maxargs) RETURN;
6225
6226     /* We do this here, rather than with a separate pushmark op, as it has
6227        to come in between two things this function does (stack reset and
6228        arg pushing).  This seems the easiest way to do it. */
6229     if (pushmark) {
6230         PUTBACK;
6231         (void)Perl_pp_pushmark(aTHX);
6232     }
6233
6234     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6235     PUTBACK; /* The code below can die in various places. */
6236
6237     oa = PL_opargs[opnum] >> OASHIFT;
6238     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6239         whicharg++;
6240         switch (oa & 7) {
6241         case OA_SCALAR:
6242           try_defsv:
6243             if (!numargs && defgv && whicharg == minargs + 1) {
6244                 PUSHs(DEFSV);
6245             }
6246             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6247             break;
6248         case OA_LIST:
6249             while (numargs--) {
6250                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6251                 svp++;
6252             }
6253             RETURN;
6254         case OA_AVREF:
6255             if (!numargs) {
6256                 GV *gv;
6257                 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6258                     gv = PL_argvgv;
6259                 else {
6260                     S_maybe_unwind_defav(aTHX);
6261                     gv = PL_defgv;
6262                 }
6263                 PUSHs((SV *)GvAVn(gv));
6264                 break;
6265             }
6266             if (!svp || !*svp || !SvROK(*svp)
6267              || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6268                 DIE(aTHX_
6269                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6270                  "Type of arg %d to &CORE::%s must be array reference",
6271                   whicharg, PL_op_desc[opnum]
6272                 );
6273             PUSHs(SvRV(*svp));
6274             break;
6275         case OA_HVREF:
6276             if (!svp || !*svp || !SvROK(*svp)
6277              || (  SvTYPE(SvRV(*svp)) != SVt_PVHV
6278                 && (  opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6279                    || SvTYPE(SvRV(*svp)) != SVt_PVAV  )))
6280                 DIE(aTHX_
6281                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6282                  "Type of arg %d to &CORE::%s must be hash%s reference",
6283                   whicharg, PL_op_desc[opnum],
6284                   opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6285                      ? ""
6286                      : " or array"
6287                 );
6288             PUSHs(SvRV(*svp));
6289             break;
6290         case OA_FILEREF:
6291             if (!numargs) PUSHs(NULL);
6292             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6293                 /* no magic here, as the prototype will have added an extra
6294                    refgen and we just want what was there before that */
6295                 PUSHs(SvRV(*svp));
6296             else {
6297                 const bool constr = PL_op->op_private & whicharg;
6298                 PUSHs(S_rv2gv(aTHX_
6299                     svp && *svp ? *svp : &PL_sv_undef,
6300                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6301                     !constr
6302                 ));
6303             }
6304             break;
6305         case OA_SCALARREF:
6306           if (!numargs) goto try_defsv;
6307           else {
6308             const bool wantscalar =
6309                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6310             if (!svp || !*svp || !SvROK(*svp)
6311                 /* We have to permit globrefs even for the \$ proto, as
6312                    *foo is indistinguishable from ${\*foo}, and the proto-
6313                    type permits the latter. */
6314              || SvTYPE(SvRV(*svp)) > (
6315                      wantscalar       ? SVt_PVLV
6316                    : opnum == OP_LOCK || opnum == OP_UNDEF
6317                                       ? SVt_PVCV
6318                    :                    SVt_PVHV
6319                 )
6320                )
6321                 DIE(aTHX_
6322                  "Type of arg %d to &CORE::%s must be %s",
6323                   whicharg, PL_op_name[opnum],
6324                   wantscalar
6325                     ? "scalar reference"
6326                     : opnum == OP_LOCK || opnum == OP_UNDEF
6327                        ? "reference to one of [$@%&*]"
6328                        : "reference to one of [$@%*]"
6329                 );
6330             PUSHs(SvRV(*svp));
6331             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6332                 /* Undo @_ localisation, so that sub exit does not undo
6333                    part of our undeffing. */
6334                 S_maybe_unwind_defav(aTHX);
6335             }
6336           }
6337           break;
6338         default:
6339             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6340         }
6341         oa = oa >> 4;
6342     }
6343
6344     RETURN;
6345 }
6346
6347 /* Implement CORE::keys(),values(),each().
6348  *
6349  * We won't know until run-time whether the arg is an array or hash,
6350  * so this op calls
6351  *
6352  *    pp_keys/pp_values/pp_each
6353  * or
6354  *    pp_akeys/pp_avalues/pp_aeach
6355  *
6356  * as appropriate (or whatever pp function actually implements the OP_FOO
6357  * functionality for each FOO).
6358  */
6359
6360 PP(pp_avhvswitch)
6361 {
6362     dVAR; dSP;
6363     return PL_ppaddr[
6364                 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6365                     + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6366            ](aTHX);
6367 }
6368
6369 PP(pp_runcv)
6370 {
6371     dSP;
6372     CV *cv;
6373     if (PL_op->op_private & OPpOFFBYONE) {
6374         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6375     }
6376     else cv = find_runcv(NULL);
6377     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6378     RETURN;
6379 }
6380
6381 static void
6382 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6383                             const bool can_preserve)
6384 {
6385     const SSize_t ix = SvIV(keysv);
6386     if (can_preserve ? av_exists(av, ix) : TRUE) {
6387         SV ** const svp = av_fetch(av, ix, 1);
6388         if (!svp || !*svp)
6389             Perl_croak(aTHX_ PL_no_aelem, ix);
6390         save_aelem(av, ix, svp);
6391     }
6392     else
6393         SAVEADELETE(av, ix);
6394 }
6395
6396 static void
6397 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6398                             const bool can_preserve)
6399 {
6400     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6401         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6402         SV ** const svp = he ? &HeVAL(he) : NULL;
6403         if (!svp || !*svp)
6404             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6405         save_helem_flags(hv, keysv, svp, 0);
6406     }
6407     else
6408         SAVEHDELETE(hv, keysv);
6409 }
6410
6411 static void
6412 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6413 {
6414     if (type == OPpLVREF_SV) {
6415         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6416         GvSV(gv) = 0;
6417     }
6418     else if (type == OPpLVREF_AV)
6419         /* XXX Inefficient, as it creates a new AV, which we are
6420                about to clobber.  */
6421         save_ary(gv);
6422     else {
6423         assert(type == OPpLVREF_HV);
6424         /* XXX Likewise inefficient.  */
6425         save_hash(gv);
6426     }
6427 }
6428
6429
6430 PP(pp_refassign)
6431 {
6432     dSP;
6433     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6434     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6435     dTOPss;
6436     const char *bad = NULL;
6437     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6438     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6439     switch (type) {
6440     case OPpLVREF_SV:
6441         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6442             bad = " SCALAR";
6443         break;
6444     case OPpLVREF_AV:
6445         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6446             bad = "n ARRAY";
6447         break;
6448     case OPpLVREF_HV:
6449         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6450             bad = " HASH";
6451         break;
6452     case OPpLVREF_CV:
6453         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6454             bad = " CODE";
6455     }
6456     if (bad)
6457         /* diag_listed_as: Assigned value is not %s reference */
6458         DIE(aTHX_ "Assigned value is not a%s reference", bad);
6459     {
6460     MAGIC *mg;
6461     HV *stash;
6462     switch (left ? SvTYPE(left) : 0) {
6463     case 0:
6464     {
6465         SV * const old = PAD_SV(ARGTARG);
6466         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6467         SvREFCNT_dec(old);
6468         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6469                 == OPpLVAL_INTRO)
6470             SAVECLEARSV(PAD_SVl(ARGTARG));
6471         break;
6472     }
6473     case SVt_PVGV:
6474         if (PL_op->op_private & OPpLVAL_INTRO) {
6475             S_localise_gv_slot(aTHX_ (GV *)left, type);
6476         }
6477         gv_setref(left, sv);
6478         SvSETMAGIC(left);
6479         break;
6480     case SVt_PVAV:
6481         assert(key);
6482         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6483             S_localise_aelem_lval(aTHX_ (AV *)left, key,
6484                                         SvCANEXISTDELETE(left));
6485         }
6486         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6487         break;
6488     case SVt_PVHV:
6489         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6490             assert(key);
6491             S_localise_helem_lval(aTHX_ (HV *)left, key,
6492                                         SvCANEXISTDELETE(left));
6493         }
6494         (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6495     }
6496     if (PL_op->op_flags & OPf_MOD)
6497         SETs(sv_2mortal(newSVsv(sv)));
6498     /* XXX else can weak references go stale before they are read, e.g.,
6499        in leavesub?  */
6500     RETURN;
6501     }
6502 }
6503
6504 PP(pp_lvref)
6505 {
6506     dSP;
6507     SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6508     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6509     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6510     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6511                                    &PL_vtbl_lvref, (char *)elem,
6512                                    elem ? HEf_SVKEY : (I32)ARGTARG);
6513     mg->mg_private = PL_op->op_private;
6514     if (PL_op->op_private & OPpLVREF_ITER)
6515         mg->mg_flags |= MGf_PERSIST;
6516     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6517       if (elem) {
6518         MAGIC *mg;
6519         HV *stash;
6520         assert(arg);
6521         {
6522             const bool can_preserve = SvCANEXISTDELETE(arg);
6523             if (SvTYPE(arg) == SVt_PVAV)
6524               S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6525             else
6526               S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6527         }
6528       }
6529       else if (arg) {
6530         S_localise_gv_slot(aTHX_ (GV *)arg,
6531                                  PL_op->op_private & OPpLVREF_TYPE);
6532       }
6533       else if (!(PL_op->op_private & OPpPAD_STATE))
6534         SAVECLEARSV(PAD_SVl(ARGTARG));
6535     }
6536     XPUSHs(ret);
6537     RETURN;
6538 }
6539
6540 PP(pp_lvrefslice)
6541 {
6542     dSP; dMARK;
6543     AV * const av = (AV *)POPs;
6544     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6545     bool can_preserve = FALSE;
6546
6547     if (UNLIKELY(localizing)) {
6548         MAGIC *mg;
6549         HV *stash;
6550         SV **svp;
6551
6552         can_preserve = SvCANEXISTDELETE(av);
6553
6554         if (SvTYPE(av) == SVt_PVAV) {
6555             SSize_t max = -1;
6556
6557             for (svp = MARK + 1; svp <= SP; svp++) {
6558                 const SSize_t elem = SvIV(*svp);
6559                 if (elem > max)
6560                     max = elem;
6561             }
6562             if (max > AvMAX(av))
6563                 av_extend(av, max);
6564         }
6565     }
6566
6567     while (++MARK <= SP) {
6568         SV * const elemsv = *MARK;
6569         if (SvTYPE(av) == SVt_PVAV)
6570             S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6571         else
6572             S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6573         *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6574         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6575     }
6576     RETURN;
6577 }
6578
6579 PP(pp_lvavref)
6580 {
6581     if (PL_op->op_flags & OPf_STACKED)
6582         Perl_pp_rv2av(aTHX);
6583     else
6584         Perl_pp_padav(aTHX);
6585     {
6586         dSP;
6587         dTOPss;
6588         SETs(0); /* special alias marker that aassign recognises */
6589         XPUSHs(sv);
6590         RETURN;
6591     }
6592 }
6593
6594 PP(pp_anonconst)
6595 {
6596     dSP;
6597     dTOPss;
6598     SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6599                                         ? CopSTASH(PL_curcop)
6600                                         : NULL,
6601                                       NULL, SvREFCNT_inc_simple_NN(sv))));
6602     RETURN;
6603 }
6604
6605
6606 /* process one subroutine argument - typically when the sub has a signature:
6607  * introduce PL_curpad[op_targ] and assign to it the value
6608  *  for $:   (OPf_STACKED ? *sp : $_[N])
6609  *  for @/%: @_[N..$#_]
6610  *
6611  * It's equivalent to
6612  *    my $foo = $_[N];
6613  * or
6614  *    my $foo = (value-on-stack)
6615  * or
6616  *    my @foo = @_[N..$#_]
6617  * etc
6618  */
6619
6620 PP(pp_argelem)
6621 {
6622     dTARG;
6623     SV *val;
6624     SV ** padentry;
6625     OP *o = PL_op;
6626     AV *defav = GvAV(PL_defgv); /* @_ */
6627     IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6628     IV argc;
6629
6630     /* do 'my $var, @var or %var' action */
6631     padentry = &(PAD_SVl(o->op_targ));
6632     save_clearsv(padentry);
6633     targ = *padentry;
6634
6635     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6636         if (o->op_flags & OPf_STACKED) {
6637             dSP;
6638             val = POPs;
6639             PUTBACK;
6640         }
6641         else {
6642             SV **svp;
6643             /* should already have been checked */
6644             assert(ix >= 0);
6645 #if IVSIZE > PTRSIZE
6646             assert(ix <= SSize_t_MAX);
6647 #endif
6648
6649             svp = av_fetch(defav, ix, FALSE);
6650             val = svp ? *svp : &PL_sv_undef;
6651         }
6652
6653         /* $var = $val */
6654
6655         /* cargo-culted from pp_sassign */
6656         assert(TAINTING_get || !TAINT_get);
6657         if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6658             TAINT_NOT;
6659
6660         SvSetMagicSV(targ, val);
6661         return o->op_next;
6662     }
6663
6664     /* must be AV or HV */
6665
6666     assert(!(o->op_flags & OPf_STACKED));
6667     argc = ((IV)AvFILL(defav) + 1) - ix;
6668
6669     /* This is a copy of the relevant parts of pp_aassign().
6670      */
6671     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6672         IV i;
6673
6674         if (AvFILL((AV*)targ) > -1) {
6675             /* target should usually be empty. If we get get
6676              * here, someone's been doing some weird closure tricks.
6677              * Make a copy of all args before clearing the array,
6678              * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6679              * elements. See similar code in pp_aassign.
6680              */
6681             for (i = 0; i < argc; i++) {
6682                 SV **svp = av_fetch(defav, ix + i, FALSE);
6683                 SV *newsv = newSV(0);
6684                 sv_setsv_flags(newsv,
6685                                 svp ? *svp : &PL_sv_undef,
6686                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6687                 if (!av_store(defav, ix + i, newsv))
6688                     SvREFCNT_dec_NN(newsv);
6689             }
6690             av_clear((AV*)targ);
6691         }
6692
6693         if (argc <= 0)
6694             return o->op_next;
6695
6696         av_extend((AV*)targ, argc);
6697
6698         i = 0;
6699         while (argc--) {
6700             SV *tmpsv;
6701             SV **svp = av_fetch(defav, ix + i, FALSE);
6702             SV *val = svp ? *svp : &PL_sv_undef;
6703             tmpsv = newSV(0);
6704             sv_setsv(tmpsv, val);
6705             av_store((AV*)targ, i++, tmpsv);
6706             TAINT_NOT;
6707         }
6708
6709     }
6710     else {
6711         IV i;
6712
6713         assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
6714
6715         if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
6716             /* see "target should usually be empty" comment above */
6717             for (i = 0; i < argc; i++) {
6718                 SV **svp = av_fetch(defav, ix + i, FALSE);
6719                 SV *newsv = newSV(0);
6720                 sv_setsv_flags(newsv,
6721                                 svp ? *svp : &PL_sv_undef,
6722                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6723                 if (!av_store(defav, ix + i, newsv))
6724                     SvREFCNT_dec_NN(newsv);
6725             }
6726             hv_clear((HV*)targ);
6727         }
6728
6729         if (argc <= 0)
6730             return o->op_next;
6731         assert(argc % 2 == 0);
6732
6733         i = 0;
6734         while (argc) {
6735             SV *tmpsv;
6736             SV **svp;
6737             SV *key;
6738             SV *val;
6739
6740             svp = av_fetch(defav, ix + i++, FALSE);
6741             key = svp ? *svp : &PL_sv_undef;
6742             svp = av_fetch(defav, ix + i++, FALSE);
6743             val = svp ? *svp : &PL_sv_undef;
6744
6745             argc -= 2;
6746             if (UNLIKELY(SvGMAGICAL(key)))
6747                 key = sv_mortalcopy(key);
6748             tmpsv = newSV(0);
6749             sv_setsv(tmpsv, val);
6750             hv_store_ent((HV*)targ, key, tmpsv, 0);
6751             TAINT_NOT;
6752         }
6753     }
6754
6755     return o->op_next;
6756 }
6757
6758 /* Handle a default value for one subroutine argument (typically as part
6759  * of a subroutine signature).
6760  * It's equivalent to
6761  *    @_ > op_targ ? $_[op_targ] : result_of(op_other)
6762  *
6763  * Intended to be used where op_next is an OP_ARGELEM
6764  *
6765  * We abuse the op_targ field slightly: it's an index into @_ rather than
6766  * into PL_curpad.
6767  */
6768
6769 PP(pp_argdefelem)
6770 {
6771     OP * const o = PL_op;
6772     AV *defav = GvAV(PL_defgv); /* @_ */
6773     IV ix = (IV)o->op_targ;
6774
6775     assert(ix >= 0);
6776 #if IVSIZE > PTRSIZE
6777     assert(ix <= SSize_t_MAX);
6778 #endif
6779
6780     if (AvFILL(defav) >= ix) {
6781         dSP;
6782         SV **svp = av_fetch(defav, ix, FALSE);
6783         SV  *val = svp ? *svp : &PL_sv_undef;
6784         XPUSHs(val);
6785         RETURN;
6786     }
6787     return cLOGOPo->op_other;
6788 }
6789
6790
6791 static SV *
6792 S_find_runcv_name(void)
6793 {
6794     dTHX;
6795     CV *cv;
6796     GV *gv;
6797     SV *sv;
6798
6799     cv = find_runcv(0);
6800     if (!cv)
6801         return &PL_sv_no;
6802
6803     gv = CvGV(cv);
6804     if (!gv)
6805         return &PL_sv_no;
6806
6807     sv = sv_2mortal(newSV(0));
6808     gv_fullname4(sv, gv, NULL, TRUE);
6809     return sv;
6810 }
6811
6812 /* Check a  a subs arguments - i.e. that it has the correct number of args
6813  * (and anything else we might think of in future). Typically used with
6814  * signatured subs.
6815  */
6816
6817 PP(pp_argcheck)
6818 {
6819     OP * const o       = PL_op;
6820     UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
6821     IV   params        = aux[0].iv;
6822     IV   opt_params    = aux[1].iv;
6823     char slurpy        = (char)(aux[2].iv);
6824     AV  *defav         = GvAV(PL_defgv); /* @_ */
6825     IV   argc;
6826     bool too_few;
6827
6828     assert(!SvMAGICAL(defav));
6829     argc = (AvFILLp(defav) + 1);
6830     too_few = (argc < (params - opt_params));
6831
6832     if (UNLIKELY(too_few || (!slurpy && argc > params)))
6833         /* diag_listed_as: Too few arguments for subroutine '%s' */
6834         /* diag_listed_as: Too many arguments for subroutine '%s' */
6835         Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
6836                           too_few ? "few" : "many", S_find_runcv_name());
6837
6838     if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
6839         /* diag_listed_as: Odd name/value argument for subroutine '%s' */
6840         Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
6841                           S_find_runcv_name());
6842
6843     return NORMAL;
6844 }
6845
6846 /*
6847  * ex: set ts=8 sts=4 sw=4 et:
6848  */