pp.c

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