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