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