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