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