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
2228 /* also used for: pp_bit_xor() */
2229
2230 PP(pp_bit_or)
2231 {
2232     dSP; dATARGET;
2233     const int op_type = PL_op->op_type;
2234
2235     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2236     {
2237       dPOPTOPssrl;
2238       if (SvNIOKp(left) || SvNIOKp(right)) {
2239         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2240         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2241         if (PL_op->op_private & HINT_INTEGER) {
2242           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2243           const IV r = SvIV_nomg(right);
2244           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2245           SETi(result);
2246         }
2247         else {
2248           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2249           const UV r = SvUV_nomg(right);
2250           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2251           SETu(result);
2252         }
2253         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2254         if (right_ro_nonnum) SvNIOK_off(right);
2255       }
2256       else {
2257         do_vop(op_type, TARG, left, right);
2258         SETTARG;
2259       }
2260       RETURN;
2261     }
2262 }
2263
2264 PERL_STATIC_INLINE bool
2265 S_negate_string(pTHX)
2266 {
2267     dTARGET; dSP;
2268     STRLEN len;
2269     const char *s;
2270     SV * const sv = TOPs;
2271     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2272         return FALSE;
2273     s = SvPV_nomg_const(sv, len);
2274     if (isIDFIRST(*s)) {
2275         sv_setpvs(TARG, "-");
2276         sv_catsv(TARG, sv);
2277     }
2278     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2279         sv_setsv_nomg(TARG, sv);
2280         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2281     }
2282     else return FALSE;
2283     SETTARG;
2284     return TRUE;
2285 }
2286
2287 PP(pp_negate)
2288 {
2289     dSP; dTARGET;
2290     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2291     if (S_negate_string(aTHX)) return NORMAL;
2292     {
2293         SV * const sv = TOPs;
2294
2295         if (SvIOK(sv)) {
2296             /* It's publicly an integer */
2297         oops_its_an_int:
2298             if (SvIsUV(sv)) {
2299                 if (SvIVX(sv) == IV_MIN) {
2300                     /* 2s complement assumption. */
2301                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2302                                            IV_MIN */
2303                     return NORMAL;
2304                 }
2305                 else if (SvUVX(sv) <= IV_MAX) {
2306                     SETi(-SvIVX(sv));
2307                     return NORMAL;
2308                 }
2309             }
2310             else if (SvIVX(sv) != IV_MIN) {
2311                 SETi(-SvIVX(sv));
2312                 return NORMAL;
2313             }
2314 #ifdef PERL_PRESERVE_IVUV
2315             else {
2316                 SETu((UV)IV_MIN);
2317                 return NORMAL;
2318             }
2319 #endif
2320         }
2321         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2322             SETn(-SvNV_nomg(sv));
2323         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2324                   goto oops_its_an_int;
2325         else
2326             SETn(-SvNV_nomg(sv));
2327     }
2328     return NORMAL;
2329 }
2330
2331 PP(pp_not)
2332 {
2333     dSP;
2334     tryAMAGICun_MG(not_amg, AMGf_set);
2335     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2336     return NORMAL;
2337 }
2338
2339 PP(pp_complement)
2340 {
2341     dSP; dTARGET;
2342     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2343     {
2344       dTOPss;
2345       if (SvNIOKp(sv)) {
2346         if (PL_op->op_private & HINT_INTEGER) {
2347           const IV i = ~SvIV_nomg(sv);
2348           SETi(i);
2349         }
2350         else {
2351           const UV u = ~SvUV_nomg(sv);
2352           SETu(u);
2353         }
2354       }
2355       else {
2356         U8 *tmps;
2357         I32 anum;
2358         STRLEN len;
2359
2360         sv_copypv_nomg(TARG, sv);
2361         tmps = (U8*)SvPV_nomg(TARG, len);
2362         anum = len;
2363         if (SvUTF8(TARG)) {
2364           /* Calculate exact length, let's not estimate. */
2365           STRLEN targlen = 0;
2366           STRLEN l;
2367           UV nchar = 0;
2368           UV nwide = 0;
2369           U8 * const send = tmps + len;
2370           U8 * const origtmps = tmps;
2371           const UV utf8flags = UTF8_ALLOW_ANYUV;
2372
2373           while (tmps < send) {
2374             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2375             tmps += l;
2376             targlen += UNISKIP(~c);
2377             nchar++;
2378             if (c > 0xff)
2379                 nwide++;
2380           }
2381
2382           /* Now rewind strings and write them. */
2383           tmps = origtmps;
2384
2385           if (nwide) {
2386               U8 *result;
2387               U8 *p;
2388
2389               Newx(result, targlen + 1, U8);
2390               p = result;
2391               while (tmps < send) {
2392                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2393                   tmps += l;
2394                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2395               }
2396               *p = '\0';
2397               sv_usepvn_flags(TARG, (char*)result, targlen,
2398                               SV_HAS_TRAILING_NUL);
2399               SvUTF8_on(TARG);
2400           }
2401           else {
2402               U8 *result;
2403               U8 *p;
2404
2405               Newx(result, nchar + 1, U8);
2406               p = result;
2407               while (tmps < send) {
2408                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2409                   tmps += l;
2410                   *p++ = ~c;
2411               }
2412               *p = '\0';
2413               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2414               SvUTF8_off(TARG);
2415           }
2416           SETTARG;
2417           return NORMAL;
2418         }
2419 #ifdef LIBERAL
2420         {
2421             long *tmpl;
2422             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2423                 *tmps = ~*tmps;
2424             tmpl = (long*)tmps;
2425             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2426                 *tmpl = ~*tmpl;
2427             tmps = (U8*)tmpl;
2428         }
2429 #endif
2430         for ( ; anum > 0; anum--, tmps++)
2431             *tmps = ~*tmps;
2432         SETTARG;
2433       }
2434       return NORMAL;
2435     }
2436 }
2437
2438 /* integer versions of some of the above */
2439
2440 PP(pp_i_multiply)
2441 {
2442     dSP; dATARGET;
2443     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2444     {
2445       dPOPTOPiirl_nomg;
2446       SETi( left * right );
2447       RETURN;
2448     }
2449 }
2450
2451 PP(pp_i_divide)
2452 {
2453     IV num;
2454     dSP; dATARGET;
2455     tryAMAGICbin_MG(div_amg, AMGf_assign);
2456     {
2457       dPOPTOPssrl;
2458       IV value = SvIV_nomg(right);
2459       if (value == 0)
2460           DIE(aTHX_ "Illegal division by zero");
2461       num = SvIV_nomg(left);
2462
2463       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2464       if (value == -1)
2465           value = - num;
2466       else
2467           value = num / value;
2468       SETi(value);
2469       RETURN;
2470     }
2471 }
2472
2473 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2474     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2475 STATIC
2476 PP(pp_i_modulo_0)
2477 #else
2478 PP(pp_i_modulo)
2479 #endif
2480 {
2481      /* This is the vanilla old i_modulo. */
2482      dSP; dATARGET;
2483      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2484      {
2485           dPOPTOPiirl_nomg;
2486           if (!right)
2487                DIE(aTHX_ "Illegal modulus zero");
2488           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2489           if (right == -1)
2490               SETi( 0 );
2491           else
2492               SETi( left % right );
2493           RETURN;
2494      }
2495 }
2496
2497 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2498     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2499 STATIC
2500 PP(pp_i_modulo_1)
2501
2502 {
2503      /* This is the i_modulo with the workaround for the _moddi3 bug
2504       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2505       * See below for pp_i_modulo. */
2506      dSP; dATARGET;
2507      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2508      {
2509           dPOPTOPiirl_nomg;
2510           if (!right)
2511                DIE(aTHX_ "Illegal modulus zero");
2512           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2513           if (right == -1)
2514               SETi( 0 );
2515           else
2516               SETi( left % PERL_ABS(right) );
2517           RETURN;
2518      }
2519 }
2520
2521 PP(pp_i_modulo)
2522 {
2523      dVAR; dSP; dATARGET;
2524      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2525      {
2526           dPOPTOPiirl_nomg;
2527           if (!right)
2528                DIE(aTHX_ "Illegal modulus zero");
2529           /* The assumption is to use hereafter the old vanilla version... */
2530           PL_op->op_ppaddr =
2531                PL_ppaddr[OP_I_MODULO] =
2532                    Perl_pp_i_modulo_0;
2533           /* .. but if we have glibc, we might have a buggy _moddi3
2534            * (at least glibc 2.2.5 is known to have this bug), in other
2535            * words our integer modulus with negative quad as the second
2536            * argument might be broken.  Test for this and re-patch the
2537            * opcode dispatch table if that is the case, remembering to
2538            * also apply the workaround so that this first round works
2539            * right, too.  See [perl #9402] for more information. */
2540           {
2541                IV l =   3;
2542                IV r = -10;
2543                /* Cannot do this check with inlined IV constants since
2544                 * that seems to work correctly even with the buggy glibc. */
2545                if (l % r == -3) {
2546                     /* Yikes, we have the bug.
2547                      * Patch in the workaround version. */
2548                     PL_op->op_ppaddr =
2549                          PL_ppaddr[OP_I_MODULO] =
2550                              &Perl_pp_i_modulo_1;
2551                     /* Make certain we work right this time, too. */
2552                     right = PERL_ABS(right);
2553                }
2554           }
2555           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2556           if (right == -1)
2557               SETi( 0 );
2558           else
2559               SETi( left % right );
2560           RETURN;
2561      }
2562 }
2563 #endif
2564
2565 PP(pp_i_add)
2566 {
2567     dSP; dATARGET;
2568     tryAMAGICbin_MG(add_amg, AMGf_assign);
2569     {
2570       dPOPTOPiirl_ul_nomg;
2571       SETi( left + right );
2572       RETURN;
2573     }
2574 }
2575
2576 PP(pp_i_subtract)
2577 {
2578     dSP; dATARGET;
2579     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2580     {
2581       dPOPTOPiirl_ul_nomg;
2582       SETi( left - right );
2583       RETURN;
2584     }
2585 }
2586
2587 PP(pp_i_lt)
2588 {
2589     dSP;
2590     tryAMAGICbin_MG(lt_amg, AMGf_set);
2591     {
2592       dPOPTOPiirl_nomg;
2593       SETs(boolSV(left < right));
2594       RETURN;
2595     }
2596 }
2597
2598 PP(pp_i_gt)
2599 {
2600     dSP;
2601     tryAMAGICbin_MG(gt_amg, AMGf_set);
2602     {
2603       dPOPTOPiirl_nomg;
2604       SETs(boolSV(left > right));
2605       RETURN;
2606     }
2607 }
2608
2609 PP(pp_i_le)
2610 {
2611     dSP;
2612     tryAMAGICbin_MG(le_amg, AMGf_set);
2613     {
2614       dPOPTOPiirl_nomg;
2615       SETs(boolSV(left <= right));
2616       RETURN;
2617     }
2618 }
2619
2620 PP(pp_i_ge)
2621 {
2622     dSP;
2623     tryAMAGICbin_MG(ge_amg, AMGf_set);
2624     {
2625       dPOPTOPiirl_nomg;
2626       SETs(boolSV(left >= right));
2627       RETURN;
2628     }
2629 }
2630
2631 PP(pp_i_eq)
2632 {
2633     dSP;
2634     tryAMAGICbin_MG(eq_amg, AMGf_set);
2635     {
2636       dPOPTOPiirl_nomg;
2637       SETs(boolSV(left == right));
2638       RETURN;
2639     }
2640 }
2641
2642 PP(pp_i_ne)
2643 {
2644     dSP;
2645     tryAMAGICbin_MG(ne_amg, AMGf_set);
2646     {
2647       dPOPTOPiirl_nomg;
2648       SETs(boolSV(left != right));
2649       RETURN;
2650     }
2651 }
2652
2653 PP(pp_i_ncmp)
2654 {
2655     dSP; dTARGET;
2656     tryAMAGICbin_MG(ncmp_amg, 0);
2657     {
2658       dPOPTOPiirl_nomg;
2659       I32 value;
2660
2661       if (left > right)
2662         value = 1;
2663       else if (left < right)
2664         value = -1;
2665       else
2666         value = 0;
2667       SETi(value);
2668       RETURN;
2669     }
2670 }
2671
2672 PP(pp_i_negate)
2673 {
2674     dSP; dTARGET;
2675     tryAMAGICun_MG(neg_amg, 0);
2676     if (S_negate_string(aTHX)) return NORMAL;
2677     {
2678         SV * const sv = TOPs;
2679         IV const i = SvIV_nomg(sv);
2680         SETi(-i);
2681         return NORMAL;
2682     }
2683 }
2684
2685 /* High falutin' math. */
2686
2687 PP(pp_atan2)
2688 {
2689     dSP; dTARGET;
2690     tryAMAGICbin_MG(atan2_amg, 0);
2691     {
2692       dPOPTOPnnrl_nomg;
2693       SETn(Perl_atan2(left, right));
2694       RETURN;
2695     }
2696 }
2697
2698
2699 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2700
2701 PP(pp_sin)
2702 {
2703     dSP; dTARGET;
2704     int amg_type = fallback_amg;
2705     const char *neg_report = NULL;
2706     const int op_type = PL_op->op_type;
2707
2708     switch (op_type) {
2709     case OP_SIN:  amg_type = sin_amg; break;
2710     case OP_COS:  amg_type = cos_amg; break;
2711     case OP_EXP:  amg_type = exp_amg; break;
2712     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2713     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2714     }
2715
2716     assert(amg_type != fallback_amg);
2717
2718     tryAMAGICun_MG(amg_type, 0);
2719     {
2720       SV * const arg = TOPs;
2721       const NV value = SvNV_nomg(arg);
2722       NV result = NV_NAN;
2723       if (neg_report) { /* log or sqrt */
2724           if (
2725 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2726               ! Perl_isnan(value) &&
2727 #endif
2728               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2729               SET_NUMERIC_STANDARD();
2730               /* diag_listed_as: Can't take log of %g */
2731               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2732           }
2733       }
2734       switch (op_type) {
2735       default:
2736       case OP_SIN:  result = Perl_sin(value);  break;
2737       case OP_COS:  result = Perl_cos(value);  break;
2738       case OP_EXP:  result = Perl_exp(value);  break;
2739       case OP_LOG:  result = Perl_log(value);  break;
2740       case OP_SQRT: result = Perl_sqrt(value); break;
2741       }
2742       SETn(result);
2743       return NORMAL;
2744     }
2745 }
2746
2747 /* Support Configure command-line overrides for rand() functions.
2748    After 5.005, perhaps we should replace this by Configure support
2749    for drand48(), random(), or rand().  For 5.005, though, maintain
2750    compatibility by calling rand() but allow the user to override it.
2751    See INSTALL for details.  --Andy Dougherty  15 July 1998
2752 */
2753 /* Now it's after 5.005, and Configure supports drand48() and random(),
2754    in addition to rand().  So the overrides should not be needed any more.
2755    --Jarkko Hietaniemi  27 September 1998
2756  */
2757
2758 PP(pp_rand)
2759 {
2760     if (!PL_srand_called) {
2761         (void)seedDrand01((Rand_seed_t)seed());
2762         PL_srand_called = TRUE;
2763     }
2764     {
2765         dSP;
2766         NV value;
2767
2768         if (MAXARG < 1)
2769         {
2770             EXTEND(SP, 1);
2771             value = 1.0;
2772         }
2773         else {
2774             SV * const sv = POPs;
2775             if(!sv)
2776                 value = 1.0;
2777             else
2778                 value = SvNV(sv);
2779         }
2780     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2781 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2782         if (! Perl_isnan(value) && value == 0.0)
2783 #else
2784         if (value == 0.0)
2785 #endif
2786             value = 1.0;
2787         {
2788             dTARGET;
2789             PUSHs(TARG);
2790             PUTBACK;
2791             value *= Drand01();
2792             sv_setnv_mg(TARG, value);
2793         }
2794     }
2795     return NORMAL;
2796 }
2797
2798 PP(pp_srand)
2799 {
2800     dSP; dTARGET;
2801     UV anum;
2802
2803     if (MAXARG >= 1 && (TOPs || POPs)) {
2804         SV *top;
2805         char *pv;
2806         STRLEN len;
2807         int flags;
2808
2809         top = POPs;
2810         pv = SvPV(top, len);
2811         flags = grok_number(pv, len, &anum);
2812
2813         if (!(flags & IS_NUMBER_IN_UV)) {
2814             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2815                              "Integer overflow in srand");
2816             anum = UV_MAX;
2817         }
2818     }
2819     else {
2820         anum = seed();
2821     }
2822
2823     (void)seedDrand01((Rand_seed_t)anum);
2824     PL_srand_called = TRUE;
2825     if (anum)
2826         XPUSHu(anum);
2827     else {
2828         /* Historically srand always returned true. We can avoid breaking
2829            that like this:  */
2830         sv_setpvs(TARG, "0 but true");
2831         XPUSHTARG;
2832     }
2833     RETURN;
2834 }
2835
2836 PP(pp_int)
2837 {
2838     dSP; dTARGET;
2839     tryAMAGICun_MG(int_amg, AMGf_numeric);
2840     {
2841       SV * const sv = TOPs;
2842       const IV iv = SvIV_nomg(sv);
2843       /* XXX it's arguable that compiler casting to IV might be subtly
2844          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2845          else preferring IV has introduced a subtle behaviour change bug. OTOH
2846          relying on floating point to be accurate is a bug.  */
2847
2848       if (!SvOK(sv)) {
2849         SETu(0);
2850       }
2851       else if (SvIOK(sv)) {
2852         if (SvIsUV(sv))
2853             SETu(SvUV_nomg(sv));
2854         else
2855             SETi(iv);
2856       }
2857       else {
2858           const NV value = SvNV_nomg(sv);
2859           if (UNLIKELY(Perl_isinfnan(value)))
2860               SETn(value);
2861           else if (value >= 0.0) {
2862               if (value < (NV)UV_MAX + 0.5) {
2863                   SETu(U_V(value));
2864               } else {
2865                   SETn(Perl_floor(value));
2866               }
2867           }
2868           else {
2869               if (value > (NV)IV_MIN - 0.5) {
2870                   SETi(I_V(value));
2871               } else {
2872                   SETn(Perl_ceil(value));
2873               }
2874           }
2875       }
2876     }
2877     return NORMAL;
2878 }
2879
2880 PP(pp_abs)
2881 {
2882     dSP; dTARGET;
2883     tryAMAGICun_MG(abs_amg, AMGf_numeric);
2884     {
2885       SV * const sv = TOPs;
2886       /* This will cache the NV value if string isn't actually integer  */
2887       const IV iv = SvIV_nomg(sv);
2888
2889       if (!SvOK(sv)) {
2890         SETu(0);
2891       }
2892       else if (SvIOK(sv)) {
2893         /* IVX is precise  */
2894         if (SvIsUV(sv)) {
2895           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
2896         } else {
2897           if (iv >= 0) {
2898             SETi(iv);
2899           } else {
2900             if (iv != IV_MIN) {
2901               SETi(-iv);
2902             } else {
2903               /* 2s complement assumption. Also, not really needed as
2904                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2905               SETu(IV_MIN);
2906             }
2907           }
2908         }
2909       } else{
2910         const NV value = SvNV_nomg(sv);
2911         if (value < 0.0)
2912           SETn(-value);
2913         else
2914           SETn(value);
2915       }
2916     }
2917     return NORMAL;
2918 }
2919
2920
2921 /* also used for: pp_hex() */
2922
2923 PP(pp_oct)
2924 {
2925     dSP; dTARGET;
2926     const char *tmps;
2927     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2928     STRLEN len;
2929     NV result_nv;
2930     UV result_uv;
2931     SV* const sv = TOPs;
2932
2933     tmps = (SvPV_const(sv, len));
2934     if (DO_UTF8(sv)) {
2935          /* If Unicode, try to downgrade
2936           * If not possible, croak. */
2937          SV* const tsv = sv_2mortal(newSVsv(sv));
2938
2939          SvUTF8_on(tsv);
2940          sv_utf8_downgrade(tsv, FALSE);
2941          tmps = SvPV_const(tsv, len);
2942     }
2943     if (PL_op->op_type == OP_HEX)
2944         goto hex;
2945
2946     while (*tmps && len && isSPACE(*tmps))
2947         tmps++, len--;
2948     if (*tmps == '0')
2949         tmps++, len--;
2950     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
2951     hex:
2952         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2953     }
2954     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
2955         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2956     else
2957         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2958
2959     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2960         SETn(result_nv);
2961     }
2962     else {
2963         SETu(result_uv);
2964     }
2965     return NORMAL;
2966 }
2967
2968 /* String stuff. */
2969
2970 PP(pp_length)
2971 {
2972     dSP; dTARGET;
2973     SV * const sv = TOPs;
2974
2975     U32 in_bytes = IN_BYTES;
2976     /* simplest case shortcut */
2977     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
2978     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
2979     STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
2980     SETs(TARG);
2981
2982     if(LIKELY(svflags == SVf_POK))
2983         goto simple_pv;
2984     if(svflags & SVs_GMG)
2985         mg_get(sv);
2986     if (SvOK(sv)) {
2987         if (!IN_BYTES) /* reread to avoid using an C auto/register */
2988             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
2989         else
2990         {
2991             STRLEN len;
2992             /* unrolled SvPV_nomg_const(sv,len) */
2993             if(SvPOK_nog(sv)){
2994                 simple_pv:
2995                 len = SvCUR(sv);
2996             } else  {
2997                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
2998             }
2999             sv_setiv(TARG, (IV)(len));
3000         }
3001     } else {
3002         if (!SvPADTMP(TARG)) {
3003             sv_setsv_nomg(TARG, &PL_sv_undef);
3004         } else { /* TARG is on stack at this point and is overwriten by SETs.
3005                    This branch is the odd one out, so put TARG by default on
3006                    stack earlier to let local SP go out of liveness sooner */
3007             SETs(&PL_sv_undef);
3008             goto no_set_magic;
3009         }
3010     }
3011     SvSETMAGIC(TARG);
3012     no_set_magic:
3013     return NORMAL; /* no putback, SP didn't move in this opcode */
3014 }
3015
3016 /* Returns false if substring is completely outside original string.
3017    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3018    always be true for an explicit 0.
3019 */
3020 bool
3021 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3022                                 bool pos1_is_uv, IV len_iv,
3023                                 bool len_is_uv, STRLEN *posp,
3024                                 STRLEN *lenp)
3025 {
3026     IV pos2_iv;
3027     int    pos2_is_uv;
3028
3029     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3030
3031     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3032         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3033         pos1_iv += curlen;
3034     }
3035     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3036         return FALSE;
3037
3038     if (len_iv || len_is_uv) {
3039         if (!len_is_uv && len_iv < 0) {
3040             pos2_iv = curlen + len_iv;
3041             if (curlen)
3042                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3043             else
3044                 pos2_is_uv = 0;
3045         } else {  /* len_iv >= 0 */
3046             if (!pos1_is_uv && pos1_iv < 0) {
3047                 pos2_iv = pos1_iv + len_iv;
3048                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3049             } else {
3050                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3051                     pos2_iv = curlen;
3052                 else
3053                     pos2_iv = pos1_iv+len_iv;
3054                 pos2_is_uv = 1;
3055             }
3056         }
3057     }
3058     else {
3059         pos2_iv = curlen;
3060         pos2_is_uv = 1;
3061     }
3062
3063     if (!pos2_is_uv && pos2_iv < 0) {
3064         if (!pos1_is_uv && pos1_iv < 0)
3065             return FALSE;
3066         pos2_iv = 0;
3067     }
3068     else if (!pos1_is_uv && pos1_iv < 0)
3069         pos1_iv = 0;
3070
3071     if ((UV)pos2_iv < (UV)pos1_iv)
3072         pos2_iv = pos1_iv;
3073     if ((UV)pos2_iv > curlen)
3074         pos2_iv = curlen;
3075
3076     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3077     *posp = (STRLEN)( (UV)pos1_iv );
3078     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3079
3080     return TRUE;
3081 }
3082
3083 PP(pp_substr)
3084 {
3085     dSP; dTARGET;
3086     SV *sv;
3087     STRLEN curlen;
3088     STRLEN utf8_curlen;
3089     SV *   pos_sv;
3090     IV     pos1_iv;
3091     int    pos1_is_uv;
3092     SV *   len_sv;
3093     IV     len_iv = 0;
3094     int    len_is_uv = 0;
3095     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3096     const bool rvalue = (GIMME_V != G_VOID);
3097     const char *tmps;
3098     SV *repl_sv = NULL;
3099     const char *repl = NULL;
3100     STRLEN repl_len;
3101     int num_args = PL_op->op_private & 7;
3102     bool repl_need_utf8_upgrade = FALSE;
3103
3104     if (num_args > 2) {
3105         if (num_args > 3) {
3106           if(!(repl_sv = POPs)) num_args--;
3107         }
3108         if ((len_sv = POPs)) {
3109             len_iv    = SvIV(len_sv);
3110             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3111         }
3112         else num_args--;
3113     }
3114     pos_sv     = POPs;
3115     pos1_iv    = SvIV(pos_sv);
3116     pos1_is_uv = SvIOK_UV(pos_sv);
3117     sv = POPs;
3118     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3119         assert(!repl_sv);
3120         repl_sv = POPs;
3121     }
3122     if (lvalue && !repl_sv) {
3123         SV * ret;
3124         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3125         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3126         LvTYPE(ret) = 'x';
3127         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3128         LvTARGOFF(ret) =
3129             pos1_is_uv || pos1_iv >= 0
3130                 ? (STRLEN)(UV)pos1_iv
3131                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3132         LvTARGLEN(ret) =
3133             len_is_uv || len_iv > 0
3134                 ? (STRLEN)(UV)len_iv
3135                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3136
3137         PUSHs(ret);    /* avoid SvSETMAGIC here */
3138         RETURN;
3139     }
3140     if (repl_sv) {
3141         repl = SvPV_const(repl_sv, repl_len);
3142         SvGETMAGIC(sv);
3143         if (SvROK(sv))
3144             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3145                             "Attempt to use reference as lvalue in substr"
3146             );
3147         tmps = SvPV_force_nomg(sv, curlen);
3148         if (DO_UTF8(repl_sv) && repl_len) {
3149             if (!DO_UTF8(sv)) {
3150                 sv_utf8_upgrade_nomg(sv);
3151                 curlen = SvCUR(sv);
3152             }
3153         }
3154         else if (DO_UTF8(sv))
3155             repl_need_utf8_upgrade = TRUE;
3156     }
3157     else tmps = SvPV_const(sv, curlen);
3158     if (DO_UTF8(sv)) {
3159         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3160         if (utf8_curlen == curlen)
3161             utf8_curlen = 0;
3162         else
3163             curlen = utf8_curlen;
3164     }
3165     else
3166         utf8_curlen = 0;
3167
3168     {
3169         STRLEN pos, len, byte_len, byte_pos;
3170
3171         if (!translate_substr_offsets(
3172                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3173         )) goto bound_fail;
3174
3175         byte_len = len;
3176         byte_pos = utf8_curlen
3177             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3178
3179         tmps += byte_pos;
3180
3181         if (rvalue) {
3182             SvTAINTED_off(TARG);                        /* decontaminate */
3183             SvUTF8_off(TARG);                   /* decontaminate */
3184             sv_setpvn(TARG, tmps, byte_len);
3185 #ifdef USE_LOCALE_COLLATE
3186             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3187 #endif
3188             if (utf8_curlen)
3189                 SvUTF8_on(TARG);
3190         }
3191
3192         if (repl) {
3193             SV* repl_sv_copy = NULL;
3194
3195             if (repl_need_utf8_upgrade) {
3196                 repl_sv_copy = newSVsv(repl_sv);
3197                 sv_utf8_upgrade(repl_sv_copy);
3198                 repl = SvPV_const(repl_sv_copy, repl_len);
3199             }
3200             if (!SvOK(sv))
3201                 sv_setpvs(sv, "");
3202             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3203             SvREFCNT_dec(repl_sv_copy);
3204         }
3205     }
3206     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3207         SP++;
3208     else if (rvalue) {
3209         SvSETMAGIC(TARG);
3210         PUSHs(TARG);
3211     }
3212     RETURN;
3213
3214   bound_fail:
3215     if (repl)
3216         Perl_croak(aTHX_ "substr outside of string");
3217     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3218     RETPUSHUNDEF;
3219 }
3220
3221 PP(pp_vec)
3222 {
3223     dSP;
3224     const IV size   = POPi;
3225     const IV offset = POPi;
3226     SV * const src = POPs;
3227     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3228     SV * ret;
3229
3230     if (lvalue) {                       /* it's an lvalue! */
3231         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3232         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3233         LvTYPE(ret) = 'v';
3234         LvTARG(ret) = SvREFCNT_inc_simple(src);
3235         LvTARGOFF(ret) = offset;
3236         LvTARGLEN(ret) = size;
3237     }
3238     else {
3239         dTARGET;
3240         SvTAINTED_off(TARG);            /* decontaminate */
3241         ret = TARG;
3242     }
3243
3244     sv_setuv(ret, do_vecget(src, offset, size));
3245     if (!lvalue)
3246         SvSETMAGIC(ret);
3247     PUSHs(ret);
3248     RETURN;
3249 }
3250
3251
3252 /* also used for: pp_rindex() */
3253
3254 PP(pp_index)
3255 {
3256     dSP; dTARGET;
3257     SV *big;
3258     SV *little;
3259     SV *temp = NULL;
3260     STRLEN biglen;
3261     STRLEN llen = 0;
3262     SSize_t offset = 0;
3263     SSize_t retval;
3264     const char *big_p;
3265     const char *little_p;
3266     bool big_utf8;
3267     bool little_utf8;
3268     const bool is_index = PL_op->op_type == OP_INDEX;
3269     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3270
3271     if (threeargs)
3272         offset = POPi;
3273     little = POPs;
3274     big = POPs;
3275     big_p = SvPV_const(big, biglen);
3276     little_p = SvPV_const(little, llen);
3277
3278     big_utf8 = DO_UTF8(big);
3279     little_utf8 = DO_UTF8(little);
3280     if (big_utf8 ^ little_utf8) {
3281         /* One needs to be upgraded.  */
3282         if (little_utf8 && !IN_ENCODING) {
3283             /* Well, maybe instead we might be able to downgrade the small
3284                string?  */
3285             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3286                                                      &little_utf8);
3287             if (little_utf8) {
3288                 /* If the large string is ISO-8859-1, and it's not possible to
3289                    convert the small string to ISO-8859-1, then there is no
3290                    way that it could be found anywhere by index.  */
3291                 retval = -1;
3292                 goto fail;
3293             }
3294
3295             /* At this point, pv is a malloc()ed string. So donate it to temp
3296                to ensure it will get free()d  */
3297             little = temp = newSV(0);
3298             sv_usepvn(temp, pv, llen);
3299             little_p = SvPVX(little);
3300         } else {
3301             temp = little_utf8
3302                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3303
3304             if (IN_ENCODING) {
3305                 sv_recode_to_utf8(temp, _get_encoding());
3306             } else {
3307                 sv_utf8_upgrade(temp);
3308             }
3309             if (little_utf8) {
3310                 big = temp;
3311                 big_utf8 = TRUE;
3312                 big_p = SvPV_const(big, biglen);
3313             } else {
3314                 little = temp;
3315                 little_p = SvPV_const(little, llen);
3316             }
3317         }
3318     }
3319     if (SvGAMAGIC(big)) {
3320         /* Life just becomes a lot easier if I use a temporary here.
3321            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3322            will trigger magic and overloading again, as will fbm_instr()
3323         */
3324         big = newSVpvn_flags(big_p, biglen,
3325                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3326         big_p = SvPVX(big);
3327     }
3328     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3329         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3330            warn on undef, and we've already triggered a warning with the
3331            SvPV_const some lines above. We can't remove that, as we need to
3332            call some SvPV to trigger overloading early and find out if the
3333            string is UTF-8.
3334            This is all getting to messy. The API isn't quite clean enough,
3335            because data access has side effects.
3336         */
3337         little = newSVpvn_flags(little_p, llen,
3338                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3339         little_p = SvPVX(little);
3340     }
3341
3342     if (!threeargs)
3343         offset = is_index ? 0 : biglen;
3344     else {
3345         if (big_utf8 && offset > 0)
3346             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3347         if (!is_index)
3348             offset += llen;
3349     }
3350     if (offset < 0)
3351         offset = 0;
3352     else if (offset > (SSize_t)biglen)
3353         offset = biglen;
3354     if (!(little_p = is_index
3355           ? fbm_instr((unsigned char*)big_p + offset,
3356                       (unsigned char*)big_p + biglen, little, 0)
3357           : rninstr(big_p,  big_p  + offset,
3358                     little_p, little_p + llen)))
3359         retval = -1;
3360     else {
3361         retval = little_p - big_p;
3362         if (retval > 1 && big_utf8)
3363             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3364     }
3365     SvREFCNT_dec(temp);
3366  fail:
3367     PUSHi(retval);
3368     RETURN;
3369 }
3370
3371 PP(pp_sprintf)
3372 {
3373     dSP; dMARK; dORIGMARK; dTARGET;
3374     SvTAINTED_off(TARG);
3375     do_sprintf(TARG, SP-MARK, MARK+1);
3376     TAINT_IF(SvTAINTED(TARG));
3377     SP = ORIGMARK;
3378     PUSHTARG;
3379     RETURN;
3380 }
3381
3382 PP(pp_ord)
3383 {
3384     dSP; dTARGET;
3385
3386     SV *argsv = TOPs;
3387     STRLEN len;
3388     const U8 *s = (U8*)SvPV_const(argsv, len);
3389
3390     if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3391         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3392         s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3393         len = UTF8SKIP(s);  /* Should be well-formed; so this is its length */
3394         argsv = tmpsv;
3395     }
3396
3397     SETu(DO_UTF8(argsv)
3398            ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3399            : (UV)(*s));
3400
3401     return NORMAL;
3402 }
3403
3404 PP(pp_chr)
3405 {
3406     dSP; dTARGET;
3407     char *tmps;
3408     UV value;
3409     SV *top = TOPs;
3410
3411     SvGETMAGIC(top);
3412     if (UNLIKELY(SvAMAGIC(top)))
3413         top = sv_2num(top);
3414     if (UNLIKELY(isinfnansv(top)))
3415         Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3416     else {
3417         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3418             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3419                 ||
3420                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3421                  && SvNV_nomg(top) < 0.0))) {
3422             if (ckWARN(WARN_UTF8)) {
3423                 if (SvGMAGICAL(top)) {
3424                     SV *top2 = sv_newmortal();
3425                     sv_setsv_nomg(top2, top);
3426                     top = top2;
3427                 }
3428                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3429                             "Invalid negative number (%"SVf") in chr", SVfARG(top));
3430             }
3431             value = UNICODE_REPLACEMENT;
3432         } else {
3433             value = SvUV_nomg(top);
3434         }
3435     }
3436
3437     SvUPGRADE(TARG,SVt_PV);
3438
3439     if (value > 255 && !IN_BYTES) {
3440         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3441         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3442         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3443         *tmps = '\0';
3444         (void)SvPOK_only(TARG);
3445         SvUTF8_on(TARG);
3446         SETTARG;
3447         return NORMAL;
3448     }
3449
3450     SvGROW(TARG,2);
3451     SvCUR_set(TARG, 1);
3452     tmps = SvPVX(TARG);
3453     *tmps++ = (char)value;
3454     *tmps = '\0';
3455     (void)SvPOK_only(TARG);
3456
3457     if (IN_ENCODING && !IN_BYTES) {
3458         sv_recode_to_utf8(TARG, _get_encoding());
3459         tmps = SvPVX(TARG);
3460         if (SvCUR(TARG) == 0
3461             || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3462             || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3463         {
3464             SvGROW(TARG, 2);
3465             tmps = SvPVX(TARG);
3466             SvCUR_set(TARG, 1);
3467             *tmps++ = (char)value;
3468             *tmps = '\0';
3469             SvUTF8_off(TARG);
3470         }
3471     }
3472
3473     SETTARG;
3474     return NORMAL;
3475 }
3476
3477 PP(pp_crypt)
3478 {
3479 #ifdef HAS_CRYPT
3480     dSP; dTARGET;
3481     dPOPTOPssrl;
3482     STRLEN len;
3483     const char *tmps = SvPV_const(left, len);
3484
3485     if (DO_UTF8(left)) {
3486          /* If Unicode, try to downgrade.
3487           * If not possible, croak.
3488           * Yes, we made this up.  */
3489          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3490
3491          sv_utf8_downgrade(tsv, FALSE);
3492          tmps = SvPV_const(tsv, len);
3493     }
3494 #   ifdef USE_ITHREADS
3495 #     ifdef HAS_CRYPT_R
3496     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3497       /* This should be threadsafe because in ithreads there is only
3498        * one thread per interpreter.  If this would not be true,
3499        * we would need a mutex to protect this malloc. */
3500         PL_reentrant_buffer->_crypt_struct_buffer =
3501           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3502 #if defined(__GLIBC__) || defined(__EMX__)
3503         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3504             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3505             /* work around glibc-2.2.5 bug */
3506             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3507         }
3508 #endif
3509     }
3510 #     endif /* HAS_CRYPT_R */
3511 #   endif /* USE_ITHREADS */
3512 #   ifdef FCRYPT
3513     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3514 #   else
3515     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3516 #   endif
3517     SvUTF8_off(TARG);
3518     SETTARG;
3519     RETURN;
3520 #else
3521     DIE(aTHX_
3522       "The crypt() function is unimplemented due to excessive paranoia.");
3523 #endif
3524 }
3525
3526 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3527  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3528
3529
3530 /* also used for: pp_lcfirst() */
3531
3532 PP(pp_ucfirst)
3533 {
3534     /* Actually is both lcfirst() and ucfirst().  Only the first character
3535      * changes.  This means that possibly we can change in-place, ie., just
3536      * take the source and change that one character and store it back, but not
3537      * if read-only etc, or if the length changes */
3538
3539     dSP;
3540     SV *source = TOPs;
3541     STRLEN slen; /* slen is the byte length of the whole SV. */
3542     STRLEN need;
3543     SV *dest;
3544     bool inplace;   /* ? Convert first char only, in-place */
3545     bool doing_utf8 = FALSE;               /* ? using utf8 */
3546     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3547     const int op_type = PL_op->op_type;
3548     const U8 *s;
3549     U8 *d;
3550     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3551     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3552                      * stored as UTF-8 at s. */
3553     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3554                      * lowercased) character stored in tmpbuf.  May be either
3555                      * UTF-8 or not, but in either case is the number of bytes */
3556
3557     s = (const U8*)SvPV_const(source, slen);
3558
3559     /* We may be able to get away with changing only the first character, in
3560      * place, but not if read-only, etc.  Later we may discover more reasons to
3561      * not convert in-place. */
3562     inplace = !SvREADONLY(source)
3563            && (  SvPADTMP(source)
3564               || (  SvTEMP(source) && !SvSMAGICAL(source)
3565                  && SvREFCNT(source) == 1));
3566
3567     /* First calculate what the changed first character should be.  This affects
3568      * whether we can just swap it out, leaving the rest of the string unchanged,
3569      * or even if have to convert the dest to UTF-8 when the source isn't */
3570
3571     if (! slen) {   /* If empty */
3572         need = 1; /* still need a trailing NUL */
3573         ulen = 0;
3574     }
3575     else if (DO_UTF8(source)) { /* Is the source utf8? */
3576         doing_utf8 = TRUE;
3577         ulen = UTF8SKIP(s);
3578         if (op_type == OP_UCFIRST) {
3579 #ifdef USE_LOCALE_CTYPE
3580             _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3581 #else
3582             _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3583 #endif
3584         }
3585         else {
3586 #ifdef USE_LOCALE_CTYPE
3587             _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3588 #else
3589             _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3590 #endif
3591         }
3592
3593         /* we can't do in-place if the length changes.  */
3594         if (ulen != tculen) inplace = FALSE;
3595         need = slen + 1 - ulen + tculen;
3596     }
3597     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3598             * latin1 is treated as caseless.  Note that a locale takes
3599             * precedence */
3600         ulen = 1;       /* Original character is 1 byte */
3601         tculen = 1;     /* Most characters will require one byte, but this will
3602                          * need to be overridden for the tricky ones */
3603         need = slen + 1;
3604
3605         if (op_type == OP_LCFIRST) {
3606
3607             /* lower case the first letter: no trickiness for any character */
3608 #ifdef USE_LOCALE_CTYPE
3609             if (IN_LC_RUNTIME(LC_CTYPE)) {
3610                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3611                 *tmpbuf = toLOWER_LC(*s);
3612             }
3613             else
3614 #endif
3615             {
3616                 *tmpbuf = (IN_UNI_8_BIT)
3617                           ? toLOWER_LATIN1(*s)
3618                           : toLOWER(*s);
3619             }
3620         }
3621 #ifdef USE_LOCALE_CTYPE
3622         /* is ucfirst() */
3623         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3624             if (IN_UTF8_CTYPE_LOCALE) {
3625                 goto do_uni_rules;
3626             }
3627
3628             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3629             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3630                                               locales have upper and title case
3631                                               different */
3632         }
3633 #endif
3634         else if (! IN_UNI_8_BIT) {
3635             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3636                                          * on EBCDIC machines whatever the
3637                                          * native function does */
3638         }
3639         else {
3640             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3641              * UTF-8, which we treat as not in locale), and cased latin1 */
3642             UV title_ord;
3643 #ifdef USE_LOCALE_CTYPE
3644       do_uni_rules:
3645 #endif
3646
3647             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3648             if (tculen > 1) {
3649                 assert(tculen == 2);
3650
3651                 /* If the result is an upper Latin1-range character, it can
3652                  * still be represented in one byte, which is its ordinal */
3653                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3654                     *tmpbuf = (U8) title_ord;
3655                     tculen = 1;
3656                 }
3657                 else {
3658                     /* Otherwise it became more than one ASCII character (in
3659                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3660                      * beyond Latin1, so the number of bytes changed, so can't
3661                      * replace just the first character in place. */
3662                     inplace = FALSE;
3663
3664                     /* If the result won't fit in a byte, the entire result
3665                      * will have to be in UTF-8.  Assume worst case sizing in
3666                      * conversion. (all latin1 characters occupy at most two
3667                      * bytes in utf8) */
3668                     if (title_ord > 255) {
3669                         doing_utf8 = TRUE;
3670                         convert_source_to_utf8 = TRUE;
3671                         need = slen * 2 + 1;
3672
3673                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3674                          * (both) characters whose title case is above 255 is
3675                          * 2. */
3676                         ulen = 2;
3677                     }
3678                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3679                         need = slen + 1 + 1;
3680                     }
3681                 }
3682             }
3683         } /* End of use Unicode (Latin1) semantics */
3684     } /* End of changing the case of the first character */
3685
3686     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3687      * generate the result */
3688     if (inplace) {
3689
3690         /* We can convert in place.  This means we change just the first
3691          * character without disturbing the rest; no need to grow */
3692         dest = source;
3693         s = d = (U8*)SvPV_force_nomg(source, slen);
3694     } else {
3695         dTARGET;
3696
3697         dest = TARG;
3698
3699         /* Here, we can't convert in place; we earlier calculated how much
3700          * space we will need, so grow to accommodate that */
3701         SvUPGRADE(dest, SVt_PV);
3702         d = (U8*)SvGROW(dest, need);
3703         (void)SvPOK_only(dest);
3704
3705         SETs(dest);
3706     }
3707
3708     if (doing_utf8) {
3709         if (! inplace) {
3710             if (! convert_source_to_utf8) {
3711
3712                 /* Here  both source and dest are in UTF-8, but have to create
3713                  * the entire output.  We initialize the result to be the
3714                  * title/lower cased first character, and then append the rest
3715                  * of the string. */
3716                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3717                 if (slen > ulen) {
3718                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3719                 }
3720             }
3721             else {
3722                 const U8 *const send = s + slen;
3723
3724                 /* Here the dest needs to be in UTF-8, but the source isn't,
3725                  * except we earlier UTF-8'd the first character of the source
3726                  * into tmpbuf.  First put that into dest, and then append the
3727                  * rest of the source, converting it to UTF-8 as we go. */
3728
3729                 /* Assert tculen is 2 here because the only two characters that
3730                  * get to this part of the code have 2-byte UTF-8 equivalents */
3731                 *d++ = *tmpbuf;
3732                 *d++ = *(tmpbuf + 1);
3733                 s++;    /* We have just processed the 1st char */
3734
3735                 for (; s < send; s++) {
3736                     d = uvchr_to_utf8(d, *s);
3737                 }
3738                 *d = '\0';
3739                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3740             }
3741             SvUTF8_on(dest);
3742         }
3743         else {   /* in-place UTF-8.  Just overwrite the first character */
3744             Copy(tmpbuf, d, tculen, U8);
3745             SvCUR_set(dest, need - 1);
3746         }
3747
3748     }
3749     else {  /* Neither source nor dest are in or need to be UTF-8 */
3750         if (slen) {
3751             if (inplace) {  /* in-place, only need to change the 1st char */
3752                 *d = *tmpbuf;
3753             }
3754             else {      /* Not in-place */
3755
3756                 /* Copy the case-changed character(s) from tmpbuf */
3757                 Copy(tmpbuf, d, tculen, U8);
3758                 d += tculen - 1; /* Code below expects d to point to final
3759                                   * character stored */
3760             }
3761         }
3762         else {  /* empty source */
3763             /* See bug #39028: Don't taint if empty  */
3764             *d = *s;
3765         }
3766
3767         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3768          * the destination to retain that flag */
3769         if (SvUTF8(source) && ! IN_BYTES)
3770             SvUTF8_on(dest);
3771
3772         if (!inplace) { /* Finish the rest of the string, unchanged */
3773             /* This will copy the trailing NUL  */
3774             Copy(s + 1, d + 1, slen, U8);
3775             SvCUR_set(dest, need - 1);
3776         }
3777     }
3778 #ifdef USE_LOCALE_CTYPE
3779     if (IN_LC_RUNTIME(LC_CTYPE)) {
3780         TAINT;
3781         SvTAINTED_on(dest);
3782     }
3783 #endif
3784     if (dest != source && SvTAINTED(source))
3785         SvTAINT(dest);
3786     SvSETMAGIC(dest);
3787     return NORMAL;
3788 }
3789
3790 /* There's so much setup/teardown code common between uc and lc, I wonder if
3791    it would be worth merging the two, and just having a switch outside each
3792    of the three tight loops.  There is less and less commonality though */
3793 PP(pp_uc)
3794 {
3795     dSP;
3796     SV *source = TOPs;
3797     STRLEN len;
3798     STRLEN min;
3799     SV *dest;
3800     const U8 *s;
3801     U8 *d;
3802
3803     SvGETMAGIC(source);
3804
3805     if ((SvPADTMP(source)
3806          ||
3807         (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3808         && !SvREADONLY(source) && SvPOK(source)
3809         && !DO_UTF8(source)
3810         && (
3811 #ifdef USE_LOCALE_CTYPE
3812             (IN_LC_RUNTIME(LC_CTYPE))
3813             ? ! IN_UTF8_CTYPE_LOCALE
3814             :
3815 #endif
3816               ! IN_UNI_8_BIT))
3817     {
3818
3819         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3820          * make the loop tight, so we overwrite the source with the dest before
3821          * looking at it, and we need to look at the original source
3822          * afterwards.  There would also need to be code added to handle
3823          * switching to not in-place in midstream if we run into characters
3824          * that change the length.  Since being in locale overrides UNI_8_BIT,
3825          * that latter becomes irrelevant in the above test; instead for
3826          * locale, the size can't normally change, except if the locale is a
3827          * UTF-8 one */
3828         dest = source;
3829         s = d = (U8*)SvPV_force_nomg(source, len);
3830         min = len + 1;
3831     } else {
3832         dTARGET;
3833
3834         dest = TARG;
3835
3836         s = (const U8*)SvPV_nomg_const(source, len);
3837         min = len + 1;
3838
3839         SvUPGRADE(dest, SVt_PV);
3840         d = (U8*)SvGROW(dest, min);
3841         (void)SvPOK_only(dest);
3842
3843         SETs(dest);
3844     }
3845
3846     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3847        to check DO_UTF8 again here.  */
3848
3849     if (DO_UTF8(source)) {
3850         const U8 *const send = s + len;
3851         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3852
3853         /* All occurrences of these are to be moved to follow any other marks.
3854          * This is context-dependent.  We may not be passed enough context to
3855          * move the iota subscript beyond all of them, but we do the best we can
3856          * with what we're given.  The result is always better than if we
3857          * hadn't done this.  And, the problem would only arise if we are
3858          * passed a character without all its combining marks, which would be
3859          * the caller's mistake.  The information this is based on comes from a
3860          * comment in Unicode SpecialCasing.txt, (and the Standard's text
3861          * itself) and so can't be checked properly to see if it ever gets
3862          * revised.  But the likelihood of it changing is remote */
3863         bool in_iota_subscript = FALSE;
3864
3865         while (s < send) {
3866             STRLEN u;
3867             STRLEN ulen;
3868             UV uv;
3869             if (in_iota_subscript && ! _is_utf8_mark(s)) {
3870
3871                 /* A non-mark.  Time to output the iota subscript */
3872                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3873                 d += capital_iota_len;
3874                 in_iota_subscript = FALSE;
3875             }
3876
3877             /* Then handle the current character.  Get the changed case value
3878              * and copy it to the output buffer */
3879
3880             u = UTF8SKIP(s);
3881 #ifdef USE_LOCALE_CTYPE
3882             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
3883 #else
3884             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
3885 #endif
3886 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3887 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3888             if (uv == GREEK_CAPITAL_LETTER_IOTA
3889                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3890             {
3891                 in_iota_subscript = TRUE;
3892             }
3893             else {
3894                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3895                     /* If the eventually required minimum size outgrows the
3896                      * available space, we need to grow. */
3897                     const UV o = d - (U8*)SvPVX_const(dest);
3898
3899                     /* If someone uppercases one million U+03B0s we SvGROW()
3900                      * one million times.  Or we could try guessing how much to
3901                      * allocate without allocating too much.  Such is life.
3902                      * See corresponding comment in lc code for another option
3903                      * */
3904                     SvGROW(dest, min);
3905                     d = (U8*)SvPVX(dest) + o;
3906                 }
3907                 Copy(tmpbuf, d, ulen, U8);
3908                 d += ulen;
3909             }
3910             s += u;
3911         }
3912         if (in_iota_subscript) {
3913             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3914             d += capital_iota_len;
3915         }
3916         SvUTF8_on(dest);
3917         *d = '\0';
3918
3919         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3920     }
3921     else {      /* Not UTF-8 */
3922         if (len) {
3923             const U8 *const send = s + len;
3924
3925             /* Use locale casing if in locale; regular style if not treating
3926              * latin1 as having case; otherwise the latin1 casing.  Do the
3927              * whole thing in a tight loop, for speed, */
3928 #ifdef USE_LOCALE_CTYPE
3929             if (IN_LC_RUNTIME(LC_CTYPE)) {
3930                 if (IN_UTF8_CTYPE_LOCALE) {
3931                     goto do_uni_rules;
3932                 }
3933                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3934                 for (; s < send; d++, s++)
3935                     *d = (U8) toUPPER_LC(*s);
3936             }
3937             else
3938 #endif
3939                  if (! IN_UNI_8_BIT) {
3940                 for (; s < send; d++, s++) {
3941                     *d = toUPPER(*s);
3942                 }
3943             }
3944             else {
3945 #ifdef USE_LOCALE_CTYPE
3946           do_uni_rules:
3947 #endif
3948                 for (; s < send; d++, s++) {
3949                     *d = toUPPER_LATIN1_MOD(*s);
3950                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3951                         continue;
3952                     }
3953
3954                     /* The mainstream case is the tight loop above.  To avoid
3955                      * extra tests in that, all three characters that require
3956                      * special handling are mapped by the MOD to the one tested
3957                      * just above.
3958                      * Use the source to distinguish between the three cases */
3959
3960                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3961
3962                         /* uc() of this requires 2 characters, but they are
3963                          * ASCII.  If not enough room, grow the string */
3964                         if (SvLEN(dest) < ++min) {
3965                             const UV o = d - (U8*)SvPVX_const(dest);
3966                             SvGROW(dest, min);
3967                             d = (U8*)SvPVX(dest) + o;
3968                         }
3969                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3970                         continue;   /* Back to the tight loop; still in ASCII */
3971                     }
3972
3973                     /* The other two special handling characters have their
3974                      * upper cases outside the latin1 range, hence need to be
3975                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
3976                      * here we are somewhere in the middle of processing a
3977                      * non-UTF-8 string, and realize that we will have to convert
3978                      * the whole thing to UTF-8.  What to do?  There are
3979                      * several possibilities.  The simplest to code is to
3980                      * convert what we have so far, set a flag, and continue on
3981                      * in the loop.  The flag would be tested each time through
3982                      * the loop, and if set, the next character would be
3983                      * converted to UTF-8 and stored.  But, I (khw) didn't want
3984                      * to slow down the mainstream case at all for this fairly
3985                      * rare case, so I didn't want to add a test that didn't
3986                      * absolutely have to be there in the loop, besides the
3987                      * possibility that it would get too complicated for
3988                      * optimizers to deal with.  Another possibility is to just
3989                      * give up, convert the source to UTF-8, and restart the
3990                      * function that way.  Another possibility is to convert
3991                      * both what has already been processed and what is yet to
3992                      * come separately to UTF-8, then jump into the loop that
3993                      * handles UTF-8.  But the most efficient time-wise of the
3994                      * ones I could think of is what follows, and turned out to
3995                      * not require much extra code.  */
3996
3997                     /* Convert what we have so far into UTF-8, telling the
3998                      * function that we know it should be converted, and to
3999                      * allow extra space for what we haven't processed yet.
4000                      * Assume the worst case space requirements for converting
4001                      * what we haven't processed so far: that it will require
4002                      * two bytes for each remaining source character, plus the
4003                      * NUL at the end.  This may cause the string pointer to
4004                      * move, so re-find it. */
4005
4006                     len = d - (U8*)SvPVX_const(dest);
4007                     SvCUR_set(dest, len);
4008                     len = sv_utf8_upgrade_flags_grow(dest,
4009                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4010                                                 (send -s) * 2 + 1);
4011                     d = (U8*)SvPVX(dest) + len;
4012
4013                     /* Now process the remainder of the source, converting to
4014                      * upper and UTF-8.  If a resulting byte is invariant in
4015                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4016                      * append it to the output. */
4017                     for (; s < send; s++) {
4018                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4019                         d += len;
4020                     }
4021
4022                     /* Here have processed the whole source; no need to continue
4023                      * with the outer loop.  Each character has been converted
4024                      * to upper case and converted to UTF-8 */
4025
4026                     break;
4027                 } /* End of processing all latin1-style chars */
4028             } /* End of processing all chars */
4029         } /* End of source is not empty */
4030
4031         if (source != dest) {
4032             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4033             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4034         }
4035     } /* End of isn't utf8 */
4036 #ifdef USE_LOCALE_CTYPE
4037     if (IN_LC_RUNTIME(LC_CTYPE)) {
4038         TAINT;
4039         SvTAINTED_on(dest);
4040     }
4041 #endif
4042     if (dest != source && SvTAINTED(source))
4043         SvTAINT(dest);
4044     SvSETMAGIC(dest);
4045     return NORMAL;
4046 }
4047
4048 PP(pp_lc)
4049 {
4050     dSP;
4051     SV *source = TOPs;
4052     STRLEN len;
4053     STRLEN min;
4054     SV *dest;
4055     const U8 *s;
4056     U8 *d;
4057
4058     SvGETMAGIC(source);
4059
4060     if (   (  SvPADTMP(source)
4061            || (  SvTEMP(source) && !SvSMAGICAL(source)
4062               && SvREFCNT(source) == 1  )
4063            )
4064         && !SvREADONLY(source) && SvPOK(source)
4065         && !DO_UTF8(source)) {
4066
4067         /* We can convert in place, as lowercasing anything in the latin1 range
4068          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4069         dest = source;
4070         s = d = (U8*)SvPV_force_nomg(source, len);
4071         min = len + 1;
4072     } else {
4073         dTARGET;
4074
4075         dest = TARG;
4076
4077         s = (const U8*)SvPV_nomg_const(source, len);
4078         min = len + 1;
4079
4080         SvUPGRADE(dest, SVt_PV);
4081         d = (U8*)SvGROW(dest, min);
4082         (void)SvPOK_only(dest);
4083
4084         SETs(dest);
4085     }
4086
4087     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4088        to check DO_UTF8 again here.  */
4089
4090     if (DO_UTF8(source)) {
4091         const U8 *const send = s + len;
4092         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4093
4094         while (s < send) {
4095             const STRLEN u = UTF8SKIP(s);
4096             STRLEN ulen;
4097
4098 #ifdef USE_LOCALE_CTYPE
4099             _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4100 #else
4101             _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4102 #endif
4103
4104             /* Here is where we would do context-sensitive actions.  See the
4105              * commit message for 86510fb15 for why there isn't any */
4106
4107             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4108
4109                 /* If the eventually required minimum size outgrows the
4110                  * available space, we need to grow. */
4111                 const UV o = d - (U8*)SvPVX_const(dest);
4112
4113                 /* If someone lowercases one million U+0130s we SvGROW() one
4114                  * million times.  Or we could try guessing how much to
4115                  * allocate without allocating too much.  Such is life.
4116                  * Another option would be to grow an extra byte or two more
4117                  * each time we need to grow, which would cut down the million
4118                  * to 500K, with little waste */
4119                 SvGROW(dest, min);
4120                 d = (U8*)SvPVX(dest) + o;
4121             }
4122
4123             /* Copy the newly lowercased letter to the output buffer we're
4124              * building */
4125             Copy(tmpbuf, d, ulen, U8);
4126             d += ulen;
4127             s += u;
4128         }   /* End of looping through the source string */
4129         SvUTF8_on(dest);
4130         *d = '\0';
4131         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4132     } else {    /* Not utf8 */
4133         if (len) {
4134             const U8 *const send = s + len;
4135
4136             /* Use locale casing if in locale; regular style if not treating
4137              * latin1 as having case; otherwise the latin1 casing.  Do the
4138              * whole thing in a tight loop, for speed, */
4139 #ifdef USE_LOCALE_CTYPE
4140             if (IN_LC_RUNTIME(LC_CTYPE)) {
4141                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4142                 for (; s < send; d++, s++)
4143                     *d = toLOWER_LC(*s);
4144             }
4145             else
4146 #endif
4147             if (! IN_UNI_8_BIT) {
4148                 for (; s < send; d++, s++) {
4149                     *d = toLOWER(*s);
4150                 }
4151             }
4152             else {
4153                 for (; s < send; d++, s++) {
4154                     *d = toLOWER_LATIN1(*s);
4155                 }
4156             }
4157         }
4158         if (source != dest) {
4159             *d = '\0';
4160             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4161         }
4162     }
4163 #ifdef USE_LOCALE_CTYPE
4164     if (IN_LC_RUNTIME(LC_CTYPE)) {
4165         TAINT;
4166         SvTAINTED_on(dest);
4167     }
4168 #endif
4169     if (dest != source && SvTAINTED(source))
4170         SvTAINT(dest);
4171     SvSETMAGIC(dest);
4172     return NORMAL;
4173 }
4174
4175 PP(pp_quotemeta)
4176 {
4177     dSP; dTARGET;
4178     SV * const sv = TOPs;
4179     STRLEN len;
4180     const char *s = SvPV_const(sv,len);
4181
4182     SvUTF8_off(TARG);                           /* decontaminate */
4183     if (len) {
4184         char *d;
4185         SvUPGRADE(TARG, SVt_PV);
4186         SvGROW(TARG, (len * 2) + 1);
4187         d = SvPVX(TARG);
4188         if (DO_UTF8(sv)) {
4189             while (len) {
4190                 STRLEN ulen = UTF8SKIP(s);
4191                 bool to_quote = FALSE;
4192
4193                 if (UTF8_IS_INVARIANT(*s)) {
4194                     if (_isQUOTEMETA(*s)) {
4195                         to_quote = TRUE;
4196                     }
4197                 }
4198                 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4199                     if (
4200 #ifdef USE_LOCALE_CTYPE
4201                     /* In locale, we quote all non-ASCII Latin1 chars.
4202                      * Otherwise use the quoting rules */
4203
4204                     IN_LC_RUNTIME(LC_CTYPE)
4205                         ||
4206 #endif
4207                         _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
4208                     {
4209                         to_quote = TRUE;
4210                     }
4211                 }
4212                 else if (is_QUOTEMETA_high(s)) {
4213                     to_quote = TRUE;
4214                 }
4215
4216                 if (to_quote) {
4217                     *d++ = '\\';
4218                 }
4219                 if (ulen > len)
4220                     ulen = len;
4221                 len -= ulen;
4222                 while (ulen--)
4223                     *d++ = *s++;
4224             }
4225             SvUTF8_on(TARG);
4226         }
4227         else if (IN_UNI_8_BIT) {
4228             while (len--) {
4229                 if (_isQUOTEMETA(*s))
4230                     *d++ = '\\';
4231                 *d++ = *s++;
4232             }
4233         }
4234         else {
4235             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4236              * including everything above ASCII */
4237             while (len--) {
4238                 if (!isWORDCHAR_A(*s))
4239                     *d++ = '\\';
4240                 *d++ = *s++;
4241             }
4242         }
4243         *d = '\0';
4244         SvCUR_set(TARG, d - SvPVX_const(TARG));
4245         (void)SvPOK_only_UTF8(TARG);
4246     }
4247     else
4248         sv_setpvn(TARG, s, len);
4249     SETTARG;
4250     return NORMAL;
4251 }
4252
4253 PP(pp_fc)
4254 {
4255     dTARGET;
4256     dSP;
4257     SV *source = TOPs;
4258     STRLEN len;
4259     STRLEN min;
4260     SV *dest;
4261     const U8 *s;
4262     const U8 *send;
4263     U8 *d;
4264     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4265     const bool full_folding = TRUE; /* This variable is here so we can easily
4266                                        move to more generality later */
4267     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4268 #ifdef USE_LOCALE_CTYPE
4269                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4270 #endif
4271     ;
4272
4273     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4274      * You are welcome(?) -Hugmeir
4275      */
4276
4277     SvGETMAGIC(source);
4278
4279     dest = TARG;
4280
4281     if (SvOK(source)) {
4282         s = (const U8*)SvPV_nomg_const(source, len);
4283     } else {
4284         if (ckWARN(WARN_UNINITIALIZED))
4285             report_uninit(source);
4286         s = (const U8*)"";
4287         len = 0;
4288     }
4289
4290     min = len + 1;
4291
4292     SvUPGRADE(dest, SVt_PV);
4293     d = (U8*)SvGROW(dest, min);
4294     (void)SvPOK_only(dest);
4295
4296     SETs(dest);
4297
4298     send = s + len;
4299     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4300         while (s < send) {
4301             const STRLEN u = UTF8SKIP(s);
4302             STRLEN ulen;
4303
4304             _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4305
4306             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4307                 const UV o = d - (U8*)SvPVX_const(dest);
4308                 SvGROW(dest, min);
4309                 d = (U8*)SvPVX(dest) + o;
4310             }
4311
4312             Copy(tmpbuf, d, ulen, U8);
4313             d += ulen;
4314             s += u;
4315         }
4316         SvUTF8_on(dest);
4317     } /* Unflagged string */
4318     else if (len) {
4319 #ifdef USE_LOCALE_CTYPE
4320         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4321             if (IN_UTF8_CTYPE_LOCALE) {
4322                 goto do_uni_folding;
4323             }
4324             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4325             for (; s < send; d++, s++)
4326                 *d = (U8) toFOLD_LC(*s);
4327         }
4328         else
4329 #endif
4330         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4331             for (; s < send; d++, s++)
4332                 *d = toFOLD(*s);
4333         }
4334         else {
4335 #ifdef USE_LOCALE_CTYPE
4336       do_uni_folding:
4337 #endif
4338             /* For ASCII and the Latin-1 range, there's only two troublesome
4339              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4340              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4341              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4342              * For the rest, the casefold is their lowercase.  */
4343             for (; s < send; d++, s++) {
4344                 if (*s == MICRO_SIGN) {
4345                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4346                      * which is outside of the latin-1 range. There's a couple
4347                      * of ways to deal with this -- khw discusses them in
4348                      * pp_lc/uc, so go there :) What we do here is upgrade what
4349                      * we had already casefolded, then enter an inner loop that
4350                      * appends the rest of the characters as UTF-8. */
4351                     len = d - (U8*)SvPVX_const(dest);
4352                     SvCUR_set(dest, len);
4353                     len = sv_utf8_upgrade_flags_grow(dest,
4354                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4355                                                 /* The max expansion for latin1
4356                                                  * chars is 1 byte becomes 2 */
4357                                                 (send -s) * 2 + 1);
4358                     d = (U8*)SvPVX(dest) + len;
4359
4360                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4361                     d += small_mu_len;
4362                     s++;
4363                     for (; s < send; s++) {
4364                         STRLEN ulen;
4365                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4366                         if UVCHR_IS_INVARIANT(fc) {
4367                             if (full_folding
4368                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4369                             {
4370                                 *d++ = 's';
4371                                 *d++ = 's';
4372                             }
4373                             else
4374                                 *d++ = (U8)fc;
4375                         }
4376                         else {
4377                             Copy(tmpbuf, d, ulen, U8);
4378                             d += ulen;
4379                         }
4380                     }
4381                     break;
4382                 }
4383                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4384                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4385                      * becomes "ss", which may require growing the SV. */
4386                     if (SvLEN(dest) < ++min) {
4387                         const UV o = d - (U8*)SvPVX_const(dest);
4388                         SvGROW(dest, min);
4389                         d = (U8*)SvPVX(dest) + o;
4390                      }
4391                     *(d)++ = 's';
4392                     *d = 's';
4393                 }
4394                 else { /* If it's not one of those two, the fold is their lower
4395                           case */
4396                     *d = toLOWER_LATIN1(*s);
4397                 }
4398              }
4399         }
4400     }
4401     *d = '\0';
4402     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4403
4404 #ifdef USE_LOCALE_CTYPE
4405     if (IN_LC_RUNTIME(LC_CTYPE)) {
4406         TAINT;
4407         SvTAINTED_on(dest);
4408     }
4409 #endif
4410     if (SvTAINTED(source))
4411         SvTAINT(dest);
4412     SvSETMAGIC(dest);
4413     RETURN;
4414 }
4415
4416 /* Arrays. */
4417
4418 PP(pp_aslice)
4419 {
4420     dSP; dMARK; dORIGMARK;
4421     AV *const av = MUTABLE_AV(POPs);
4422     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4423
4424     if (SvTYPE(av) == SVt_PVAV) {
4425         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4426         bool can_preserve = FALSE;
4427
4428         if (localizing) {
4429             MAGIC *mg;
4430             HV *stash;
4431
4432             can_preserve = SvCANEXISTDELETE(av);
4433         }
4434
4435         if (lval && localizing) {
4436             SV **svp;
4437             SSize_t max = -1;
4438             for (svp = MARK + 1; svp <= SP; svp++) {
4439                 const SSize_t elem = SvIV(*svp);
4440                 if (elem > max)
4441                     max = elem;
4442             }
4443             if (max > AvMAX(av))
4444                 av_extend(av, max);
4445         }
4446
4447         while (++MARK <= SP) {
4448             SV **svp;
4449             SSize_t elem = SvIV(*MARK);
4450             bool preeminent = TRUE;
4451
4452             if (localizing && can_preserve) {
4453                 /* If we can determine whether the element exist,
4454                  * Try to preserve the existenceness of a tied array
4455                  * element by using EXISTS and DELETE if possible.
4456                  * Fallback to FETCH and STORE otherwise. */
4457                 preeminent = av_exists(av, elem);
4458             }
4459
4460             svp = av_fetch(av, elem, lval);
4461             if (lval) {
4462                 if (!svp || !*svp)
4463                     DIE(aTHX_ PL_no_aelem, elem);
4464                 if (localizing) {
4465                     if (preeminent)
4466                         save_aelem(av, elem, svp);
4467                     else
4468                         SAVEADELETE(av, elem);
4469                 }
4470             }
4471             *MARK = svp ? *svp : &PL_sv_undef;
4472         }
4473     }
4474     if (GIMME_V != G_ARRAY) {
4475         MARK = ORIGMARK;
4476         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4477         SP = MARK;
4478     }
4479     RETURN;
4480 }
4481
4482 PP(pp_kvaslice)
4483 {
4484     dSP; dMARK;
4485     AV *const av = MUTABLE_AV(POPs);
4486     I32 lval = (PL_op->op_flags & OPf_MOD);
4487     SSize_t items = SP - MARK;
4488
4489     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4490        const I32 flags = is_lvalue_sub();
4491        if (flags) {
4492            if (!(flags & OPpENTERSUB_INARGS))
4493                /* diag_listed_as: Can't modify %s in %s */
4494                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4495            lval = flags;
4496        }
4497     }
4498
4499     MEXTEND(SP,items);
4500     while (items > 1) {
4501         *(MARK+items*2-1) = *(MARK+items);
4502         items--;
4503     }
4504     items = SP-MARK;
4505     SP += items;
4506
4507     while (++MARK <= SP) {
4508         SV **svp;
4509
4510         svp = av_fetch(av, SvIV(*MARK), lval);
4511         if (lval) {
4512             if (!svp || !*svp || *svp == &PL_sv_undef) {
4513                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4514             }
4515             *MARK = sv_mortalcopy(*MARK);
4516         }
4517         *++MARK = svp ? *svp : &PL_sv_undef;
4518     }
4519     if (GIMME_V != G_ARRAY) {
4520         MARK = SP - items*2;
4521         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4522         SP = MARK;
4523     }
4524     RETURN;
4525 }
4526
4527
4528 /* Smart dereferencing for keys, values and each */
4529
4530 /* also used for: pp_reach() pp_rvalues() */
4531
4532 PP(pp_rkeys)
4533 {
4534     dSP;
4535     dPOPss;
4536
4537     SvGETMAGIC(sv);
4538
4539     if (
4540          !SvROK(sv)
4541       || (sv = SvRV(sv),
4542             (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4543           || SvOBJECT(sv)
4544          )
4545     ) {
4546         DIE(aTHX_
4547            "Type of argument to %s must be unblessed hashref or arrayref",
4548             PL_op_desc[PL_op->op_type] );
4549     }
4550
4551     if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4552         DIE(aTHX_
4553            "Can't modify %s in %s",
4554             PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4555         );
4556
4557     /* Delegate to correct function for op type */
4558     PUSHs(sv);
4559     if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4560         return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4561     }
4562     else {
4563         return (SvTYPE(sv) == SVt_PVHV)
4564                ? Perl_pp_each(aTHX)
4565                : Perl_pp_aeach(aTHX);
4566     }
4567 }
4568
4569 PP(pp_aeach)
4570 {
4571     dSP;
4572     AV *array = MUTABLE_AV(POPs);
4573     const I32 gimme = GIMME_V;
4574     IV *iterp = Perl_av_iter_p(aTHX_ array);
4575     const IV current = (*iterp)++;
4576
4577     if (current > av_tindex(array)) {
4578         *iterp = 0;
4579         if (gimme == G_SCALAR)
4580             RETPUSHUNDEF;
4581         else
4582             RETURN;
4583     }
4584
4585     EXTEND(SP, 2);
4586     mPUSHi(current);
4587     if (gimme == G_ARRAY) {
4588         SV **const element = av_fetch(array, current, 0);
4589         PUSHs(element ? *element : &PL_sv_undef);
4590     }
4591     RETURN;
4592 }
4593
4594 /* also used for: pp_avalues()*/
4595 PP(pp_akeys)
4596 {
4597     dSP;
4598     AV *array = MUTABLE_AV(POPs);
4599     const I32 gimme = GIMME_V;
4600
4601     *Perl_av_iter_p(aTHX_ array) = 0;
4602
4603     if (gimme == G_SCALAR) {
4604         dTARGET;
4605         PUSHi(av_tindex(array) + 1);
4606     }
4607     else if (gimme == G_ARRAY) {
4608         IV n = Perl_av_len(aTHX_ array);
4609         IV i;
4610
4611         EXTEND(SP, n + 1);
4612
4613         if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4614             for (i = 0;  i <= n;  i++) {
4615                 mPUSHi(i);
4616             }
4617         }
4618         else {
4619             for (i = 0;  i <= n;  i++) {
4620                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4621                 PUSHs(elem ? *elem : &PL_sv_undef);
4622             }
4623         }
4624     }
4625     RETURN;
4626 }
4627
4628 /* Associative arrays. */
4629
4630 PP(pp_each)
4631 {
4632     dSP;
4633     HV * hash = MUTABLE_HV(POPs);
4634     HE *entry;
4635     const I32 gimme = GIMME_V;
4636
4637     entry = hv_iternext(hash);
4638
4639     EXTEND(SP, 2);
4640     if (entry) {
4641         SV* const sv = hv_iterkeysv(entry);
4642         PUSHs(sv);
4643         if (gimme == G_ARRAY) {
4644             SV *val;
4645             val = hv_iterval(hash, entry);
4646             PUSHs(val);
4647         }
4648     }
4649     else if (gimme == G_SCALAR)
4650         RETPUSHUNDEF;
4651
4652     RETURN;
4653 }
4654
4655 STATIC OP *
4656 S_do_delete_local(pTHX)
4657 {
4658     dSP;
4659     const I32 gimme = GIMME_V;
4660     const MAGIC *mg;
4661     HV *stash;
4662     const bool sliced = !!(PL_op->op_private & OPpSLICE);
4663     SV **unsliced_keysv = sliced ? NULL : sp--;
4664     SV * const osv = POPs;
4665     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4666     dORIGMARK;
4667     const bool tied = SvRMAGICAL(osv)
4668                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4669     const bool can_preserve = SvCANEXISTDELETE(osv);
4670     const U32 type = SvTYPE(osv);
4671     SV ** const end = sliced ? SP : unsliced_keysv;
4672
4673     if (type == SVt_PVHV) {                     /* hash element */
4674             HV * const hv = MUTABLE_HV(osv);
4675             while (++MARK <= end) {
4676                 SV * const keysv = *MARK;
4677                 SV *sv = NULL;
4678                 bool preeminent = TRUE;
4679                 if (can_preserve)
4680                     preeminent = hv_exists_ent(hv, keysv, 0);
4681                 if (tied) {
4682                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4683                     if (he)
4684                         sv = HeVAL(he);
4685                     else
4686                         preeminent = FALSE;
4687                 }
4688                 else {
4689                     sv = hv_delete_ent(hv, keysv, 0, 0);
4690                     if (preeminent)
4691                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4692                 }
4693                 if (preeminent) {
4694                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4695                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4696                     if (tied) {
4697                         *MARK = sv_mortalcopy(sv);
4698                         mg_clear(sv);
4699                     } else
4700                         *MARK = sv;
4701                 }
4702                 else {
4703                     SAVEHDELETE(hv, keysv);
4704                     *MARK = &PL_sv_undef;
4705                 }
4706             }
4707     }
4708     else if (type == SVt_PVAV) {                  /* array element */
4709             if (PL_op->op_flags & OPf_SPECIAL) {
4710                 AV * const av = MUTABLE_AV(osv);
4711                 while (++MARK <= end) {
4712                     SSize_t idx = SvIV(*MARK);
4713                     SV *sv = NULL;
4714                     bool preeminent = TRUE;
4715                     if (can_preserve)
4716                         preeminent = av_exists(av, idx);
4717                     if (tied) {
4718                         SV **svp = av_fetch(av, idx, 1);
4719                         if (svp)
4720                             sv = *svp;
4721                         else
4722                             preeminent = FALSE;
4723                     }
4724                     else {
4725                         sv = av_delete(av, idx, 0);
4726                         if (preeminent)
4727                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4728                     }
4729                     if (preeminent) {
4730                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4731                         if (tied) {
4732                             *MARK = sv_mortalcopy(sv);
4733                             mg_clear(sv);
4734                         } else
4735                             *MARK = sv;
4736                     }
4737                     else {
4738                         SAVEADELETE(av, idx);
4739                         *MARK = &PL_sv_undef;
4740                     }
4741                 }
4742             }
4743             else
4744                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4745     }
4746     else
4747             DIE(aTHX_ "Not a HASH reference");
4748     if (sliced) {
4749         if (gimme == G_VOID)
4750             SP = ORIGMARK;
4751         else if (gimme == G_SCALAR) {
4752             MARK = ORIGMARK;
4753             if (SP > MARK)
4754                 *++MARK = *SP;
4755             else
4756                 *++MARK = &PL_sv_undef;
4757             SP = MARK;
4758         }
4759     }
4760     else if (gimme != G_VOID)
4761         PUSHs(*unsliced_keysv);
4762
4763     RETURN;
4764 }
4765
4766 PP(pp_delete)
4767 {
4768     dSP;
4769     I32 gimme;
4770     I32 discard;
4771
4772     if (PL_op->op_private & OPpLVAL_INTRO)
4773         return do_delete_local();
4774
4775     gimme = GIMME_V;
4776     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4777
4778     if (PL_op->op_private & OPpSLICE) {
4779         dMARK; dORIGMARK;
4780         HV * const hv = MUTABLE_HV(POPs);
4781         const U32 hvtype = SvTYPE(hv);
4782         if (hvtype == SVt_PVHV) {                       /* hash element */
4783             while (++MARK <= SP) {
4784                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4785                 *MARK = sv ? sv : &PL_sv_undef;
4786             }
4787         }
4788         else if (hvtype == SVt_PVAV) {                  /* array element */
4789             if (PL_op->op_flags & OPf_SPECIAL) {
4790                 while (++MARK <= SP) {
4791                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4792                     *MARK = sv ? sv : &PL_sv_undef;
4793                 }
4794             }
4795         }
4796         else
4797             DIE(aTHX_ "Not a HASH reference");
4798         if (discard)
4799             SP = ORIGMARK;
4800         else if (gimme == G_SCALAR) {
4801             MARK = ORIGMARK;
4802             if (SP > MARK)
4803                 *++MARK = *SP;
4804             else
4805                 *++MARK = &PL_sv_undef;
4806             SP = MARK;
4807         }
4808     }
4809     else {
4810         SV *keysv = POPs;
4811         HV * const hv = MUTABLE_HV(POPs);
4812         SV *sv = NULL;
4813         if (SvTYPE(hv) == SVt_PVHV)
4814             sv = hv_delete_ent(hv, keysv, discard, 0);
4815         else if (SvTYPE(hv) == SVt_PVAV) {
4816             if (PL_op->op_flags & OPf_SPECIAL)
4817                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4818             else
4819                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4820         }
4821         else
4822             DIE(aTHX_ "Not a HASH reference");
4823         if (!sv)
4824             sv = &PL_sv_undef;
4825         if (!discard)
4826             PUSHs(sv);
4827     }
4828     RETURN;
4829 }
4830
4831 PP(pp_exists)
4832 {
4833     dSP;
4834     SV *tmpsv;
4835     HV *hv;
4836
4837     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4838         GV *gv;
4839         SV * const sv = POPs;
4840         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4841         if (cv)
4842             RETPUSHYES;
4843         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4844             RETPUSHYES;
4845         RETPUSHNO;
4846     }
4847     tmpsv = POPs;
4848     hv = MUTABLE_HV(POPs);
4849     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4850         if (hv_exists_ent(hv, tmpsv, 0))
4851             RETPUSHYES;
4852     }
4853     else if (SvTYPE(hv) == SVt_PVAV) {
4854         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4855             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4856                 RETPUSHYES;
4857         }
4858     }
4859     else {
4860         DIE(aTHX_ "Not a HASH reference");
4861     }
4862     RETPUSHNO;
4863 }
4864
4865 PP(pp_hslice)
4866 {
4867     dSP; dMARK; dORIGMARK;
4868     HV * const hv = MUTABLE_HV(POPs);
4869     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4870     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4871     bool can_preserve = FALSE;
4872
4873     if (localizing) {
4874         MAGIC *mg;
4875         HV *stash;
4876
4877         if (SvCANEXISTDELETE(hv))
4878             can_preserve = TRUE;
4879     }
4880
4881     while (++MARK <= SP) {
4882         SV * const keysv = *MARK;
4883         SV **svp;
4884         HE *he;
4885         bool preeminent = TRUE;
4886
4887         if (localizing && can_preserve) {
4888             /* If we can determine whether the element exist,
4889              * try to preserve the existenceness of a tied hash
4890              * element by using EXISTS and DELETE if possible.
4891              * Fallback to FETCH and STORE otherwise. */
4892             preeminent = hv_exists_ent(hv, keysv, 0);
4893         }
4894
4895         he = hv_fetch_ent(hv, keysv, lval, 0);
4896         svp = he ? &HeVAL(he) : NULL;
4897
4898         if (lval) {
4899             if (!svp || !*svp || *svp == &PL_sv_undef) {
4900                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4901             }
4902             if (localizing) {
4903                 if (HvNAME_get(hv) && isGV(*svp))
4904                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4905                 else if (preeminent)
4906                     save_helem_flags(hv, keysv, svp,
4907                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4908                 else
4909                     SAVEHDELETE(hv, keysv);
4910             }
4911         }
4912         *MARK = svp && *svp ? *svp : &PL_sv_undef;
4913     }
4914     if (GIMME_V != G_ARRAY) {
4915         MARK = ORIGMARK;
4916         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4917         SP = MARK;
4918     }
4919     RETURN;
4920 }
4921
4922 PP(pp_kvhslice)
4923 {
4924     dSP; dMARK;
4925     HV * const hv = MUTABLE_HV(POPs);
4926     I32 lval = (PL_op->op_flags & OPf_MOD);
4927     SSize_t items = SP - MARK;
4928
4929     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4930        const I32 flags = is_lvalue_sub();
4931        if (flags) {
4932            if (!(flags & OPpENTERSUB_INARGS))
4933                /* diag_listed_as: Can't modify %s in %s */
4934                Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4935            lval = flags;
4936        }
4937     }
4938
4939     MEXTEND(SP,items);
4940     while (items > 1) {
4941         *(MARK+items*2-1) = *(MARK+items);
4942         items--;
4943     }
4944     items = SP-MARK;
4945     SP += items;
4946
4947     while (++MARK <= SP) {
4948         SV * const keysv = *MARK;
4949         SV **svp;
4950         HE *he;
4951
4952         he = hv_fetch_ent(hv, keysv, lval, 0);
4953         svp = he ? &HeVAL(he) : NULL;
4954
4955         if (lval) {
4956             if (!svp || !*svp || *svp == &PL_sv_undef) {
4957                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4958             }
4959             *MARK = sv_mortalcopy(*MARK);
4960         }
4961         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4962     }
4963     if (GIMME_V != G_ARRAY) {
4964         MARK = SP - items*2;
4965         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4966         SP = MARK;
4967     }
4968     RETURN;
4969 }
4970
4971 /* List operators. */
4972
4973 PP(pp_list)
4974 {
4975     I32 markidx = POPMARK;
4976     if (GIMME_V != G_ARRAY) {
4977         SV **mark = PL_stack_base + markidx;
4978         dSP;
4979         if (++MARK <= SP)
4980             *MARK = *SP;                /* unwanted list, return last item */
4981         else
4982             *MARK = &PL_sv_undef;
4983         SP = MARK;
4984         PUTBACK;
4985     }
4986     return NORMAL;
4987 }
4988
4989 PP(pp_lslice)
4990 {
4991     dSP;
4992     SV ** const lastrelem = PL_stack_sp;
4993     SV ** const lastlelem = PL_stack_base + POPMARK;
4994     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4995     SV ** const firstrelem = lastlelem + 1;
4996     const U8 mod = PL_op->op_flags & OPf_MOD;
4997
4998     const I32 max = lastrelem - lastlelem;
4999     SV **lelem;
5000
5001     if (GIMME_V != G_ARRAY) {
5002         I32 ix = SvIV(*lastlelem);
5003         if (ix < 0)
5004             ix += max;
5005         if (ix < 0 || ix >= max)
5006             *firstlelem = &PL_sv_undef;
5007         else
5008             *firstlelem = firstrelem[ix];
5009         SP = firstlelem;
5010         RETURN;
5011     }
5012
5013     if (max == 0) {
5014         SP = firstlelem - 1;
5015         RETURN;
5016     }
5017
5018     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5019         I32 ix = SvIV(*lelem);
5020         if (ix < 0)
5021             ix += max;
5022         if (ix < 0 || ix >= max)
5023             *lelem = &PL_sv_undef;
5024         else {
5025             if (!(*lelem = firstrelem[ix]))
5026                 *lelem = &PL_sv_undef;
5027             else if (mod && SvPADTMP(*lelem)) {
5028                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5029             }
5030         }
5031     }
5032     SP = lastlelem;
5033     RETURN;
5034 }
5035
5036 PP(pp_anonlist)
5037 {
5038     dSP; dMARK;
5039     const I32 items = SP - MARK;
5040     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5041     SP = MARK;
5042     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5043             ? newRV_noinc(av) : av);
5044     RETURN;
5045 }
5046
5047 PP(pp_anonhash)
5048 {
5049     dSP; dMARK; dORIGMARK;
5050     HV* const hv = newHV();
5051     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5052                                     ? newRV_noinc(MUTABLE_SV(hv))
5053                                     : MUTABLE_SV(hv) );
5054
5055     while (MARK < SP) {
5056         SV * const key =
5057             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5058         SV *val;
5059         if (MARK < SP)
5060         {
5061             MARK++;
5062             SvGETMAGIC(*MARK);
5063             val = newSV(0);
5064             sv_setsv_nomg(val, *MARK);
5065         }
5066         else
5067         {
5068             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5069             val = newSV(0);
5070         }
5071         (void)hv_store_ent(hv,key,val,0);
5072     }
5073     SP = ORIGMARK;
5074     XPUSHs(retval);
5075     RETURN;
5076 }
5077
5078 static AV *
5079 S_deref_plain_array(pTHX_ AV *ary)
5080 {
5081     if (SvTYPE(ary) == SVt_PVAV) return ary;
5082     SvGETMAGIC((SV *)ary);
5083     if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5084         Perl_die(aTHX_ "Not an ARRAY reference");
5085     else if (SvOBJECT(SvRV(ary)))
5086         Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5087     return (AV *)SvRV(ary);
5088 }
5089
5090 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5091 # define DEREF_PLAIN_ARRAY(ary)       \
5092    ({                                  \
5093      AV *aRrRay = ary;                  \
5094      SvTYPE(aRrRay) == SVt_PVAV          \
5095       ? aRrRay                            \
5096       : S_deref_plain_array(aTHX_ aRrRay); \
5097    })
5098 #else
5099 # define DEREF_PLAIN_ARRAY(ary)            \
5100    (                                        \
5101      PL_Sv = (SV *)(ary),                    \
5102      SvTYPE(PL_Sv) == SVt_PVAV                \
5103       ? (AV *)PL_Sv                            \
5104       : S_deref_plain_array(aTHX_ (AV *)PL_Sv)  \
5105    )
5106 #endif
5107
5108 PP(pp_splice)
5109 {
5110     dSP; dMARK; dORIGMARK;
5111     int num_args = (SP - MARK);
5112     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5113     SV **src;
5114     SV **dst;
5115     SSize_t i;
5116     SSize_t offset;
5117     SSize_t length;
5118     SSize_t newlen;
5119     SSize_t after;
5120     SSize_t diff;
5121     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5122
5123     if (mg) {
5124         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5125                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5126                                     sp - mark);
5127     }
5128
5129     SP++;
5130
5131     if (++MARK < SP) {
5132         offset = i = SvIV(*MARK);
5133         if (offset < 0)
5134             offset += AvFILLp(ary) + 1;
5135         if (offset < 0)
5136             DIE(aTHX_ PL_no_aelem, i);
5137         if (++MARK < SP) {
5138             length = SvIVx(*MARK++);
5139             if (length < 0) {
5140                 length += AvFILLp(ary) - offset + 1;
5141                 if (length < 0)
5142                     length = 0;
5143             }
5144         }
5145         else
5146             length = AvMAX(ary) + 1;            /* close enough to infinity */
5147     }
5148     else {
5149         offset = 0;
5150         length = AvMAX(ary) + 1;
5151     }
5152     if (offset > AvFILLp(ary) + 1) {
5153         if (num_args > 2)
5154             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5155         offset = AvFILLp(ary) + 1;
5156     }
5157     after = AvFILLp(ary) + 1 - (offset + length);
5158     if (after < 0) {                            /* not that much array */
5159         length += after;                        /* offset+length now in array */
5160         after = 0;
5161         if (!AvALLOC(ary))
5162             av_extend(ary, 0);
5163     }
5164
5165     /* At this point, MARK .. SP-1 is our new LIST */
5166
5167     newlen = SP - MARK;
5168     diff = newlen - length;
5169     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5170         av_reify(ary);
5171
5172     /* make new elements SVs now: avoid problems if they're from the array */
5173     for (dst = MARK, i = newlen; i; i--) {
5174         SV * const h = *dst;
5175         *dst++ = newSVsv(h);
5176     }
5177
5178     if (diff < 0) {                             /* shrinking the area */
5179         SV **tmparyval = NULL;
5180         if (newlen) {
5181             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5182             Copy(MARK, tmparyval, newlen, SV*);
5183         }
5184
5185         MARK = ORIGMARK + 1;
5186         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5187             const bool real = cBOOL(AvREAL(ary));
5188             MEXTEND(MARK, length);
5189             if (real)
5190                 EXTEND_MORTAL(length);
5191             for (i = 0, dst = MARK; i < length; i++) {
5192                 if ((*dst = AvARRAY(ary)[i+offset])) {
5193                   if (real)
5194                     sv_2mortal(*dst);   /* free them eventually */
5195                 }
5196                 else
5197                     *dst = &PL_sv_undef;
5198                 dst++;
5199             }
5200             MARK += length - 1;
5201         }
5202         else {
5203             *MARK = AvARRAY(ary)[offset+length-1];
5204             if (AvREAL(ary)) {
5205                 sv_2mortal(*MARK);
5206                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5207                     SvREFCNT_dec(*dst++);       /* free them now */
5208             }
5209         }
5210         AvFILLp(ary) += diff;
5211
5212         /* pull up or down? */
5213
5214         if (offset < after) {                   /* easier to pull up */
5215             if (offset) {                       /* esp. if nothing to pull */
5216                 src = &AvARRAY(ary)[offset-1];
5217                 dst = src - diff;               /* diff is negative */
5218                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5219                     *dst-- = *src--;
5220             }
5221             dst = AvARRAY(ary);
5222             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5223             AvMAX(ary) += diff;
5224         }
5225         else {
5226             if (after) {                        /* anything to pull down? */
5227                 src = AvARRAY(ary) + offset + length;
5228                 dst = src + diff;               /* diff is negative */
5229                 Move(src, dst, after, SV*);
5230             }
5231             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5232                                                 /* avoid later double free */
5233         }
5234         i = -diff;
5235         while (i)
5236             dst[--i] = NULL;
5237
5238         if (newlen) {
5239             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5240             Safefree(tmparyval);
5241         }
5242     }
5243     else {                                      /* no, expanding (or same) */
5244         SV** tmparyval = NULL;
5245         if (length) {
5246             Newx(tmparyval, length, SV*);       /* so remember deletion */
5247             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5248         }
5249
5250         if (diff > 0) {                         /* expanding */
5251             /* push up or down? */
5252             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5253                 if (offset) {
5254                     src = AvARRAY(ary);
5255                     dst = src - diff;
5256                     Move(src, dst, offset, SV*);
5257                 }
5258                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5259                 AvMAX(ary) += diff;
5260                 AvFILLp(ary) += diff;
5261             }
5262             else {
5263                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5264                     av_extend(ary, AvFILLp(ary) + diff);
5265                 AvFILLp(ary) += diff;
5266
5267                 if (after) {
5268                     dst = AvARRAY(ary) + AvFILLp(ary);
5269                     src = dst - diff;
5270                     for (i = after; i; i--) {
5271                         *dst-- = *src--;
5272                     }
5273                 }
5274             }
5275         }
5276
5277         if (newlen) {
5278             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5279         }
5280
5281         MARK = ORIGMARK + 1;
5282         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5283             if (length) {
5284                 const bool real = cBOOL(AvREAL(ary));
5285                 if (real)
5286                     EXTEND_MORTAL(length);
5287                 for (i = 0, dst = MARK; i < length; i++) {
5288                     if ((*dst = tmparyval[i])) {
5289                       if (real)
5290                         sv_2mortal(*dst);       /* free them eventually */
5291                     }
5292                     else *dst = &PL_sv_undef;
5293                     dst++;
5294                 }
5295             }
5296             MARK += length - 1;
5297         }
5298         else if (length--) {
5299             *MARK = tmparyval[length];
5300             if (AvREAL(ary)) {
5301                 sv_2mortal(*MARK);
5302                 while (length-- > 0)
5303                     SvREFCNT_dec(tmparyval[length]);
5304             }
5305         }
5306         else
5307             *MARK = &PL_sv_undef;
5308         Safefree(tmparyval);
5309     }
5310
5311     if (SvMAGICAL(ary))
5312         mg_set(MUTABLE_SV(ary));
5313
5314     SP = MARK;
5315     RETURN;
5316 }
5317
5318 PP(pp_push)
5319 {
5320     dSP; dMARK; dORIGMARK; dTARGET;
5321     AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5322     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5323
5324     if (mg) {
5325         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5326         PUSHMARK(MARK);
5327         PUTBACK;
5328         ENTER_with_name("call_PUSH");
5329         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5330         LEAVE_with_name("call_PUSH");
5331         SPAGAIN;
5332     }
5333     else {
5334         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5335         PL_delaymagic = DM_DELAY;
5336         for (++MARK; MARK <= SP; MARK++) {
5337             SV *sv;
5338             if (*MARK) SvGETMAGIC(*MARK);
5339             sv = newSV(0);
5340             if (*MARK)
5341                 sv_setsv_nomg(sv, *MARK);
5342             av_store(ary, AvFILLp(ary)+1, sv);
5343         }
5344         if (PL_delaymagic & DM_ARRAY_ISA)
5345             mg_set(MUTABLE_SV(ary));
5346
5347         PL_delaymagic = 0;
5348     }
5349     SP = ORIGMARK;
5350     if (OP_GIMME(PL_op, 0) != G_VOID) {
5351         PUSHi( AvFILL(ary) + 1 );
5352     }
5353     RETURN;
5354 }
5355
5356 /* also used for: pp_pop()*/
5357 PP(pp_shift)
5358 {
5359     dSP;
5360     AV * const av = PL_op->op_flags & OPf_SPECIAL
5361         ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5362     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5363     EXTEND(SP, 1);
5364     assert (sv);
5365     if (AvREAL(av))
5366         (void)sv_2mortal(sv);
5367     PUSHs(sv);
5368     RETURN;
5369 }
5370
5371 PP(pp_unshift)
5372 {
5373     dSP; dMARK; dORIGMARK; dTARGET;
5374     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5375     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5376
5377     if (mg) {
5378         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5379         PUSHMARK(MARK);
5380         PUTBACK;
5381         ENTER_with_name("call_UNSHIFT");
5382         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5383         LEAVE_with_name("call_UNSHIFT");
5384         SPAGAIN;
5385     }
5386     else {
5387         SSize_t i = 0;
5388         av_unshift(ary, SP - MARK);
5389         while (MARK < SP) {
5390             SV * const sv = newSVsv(*++MARK);
5391             (void)av_store(ary, i++, sv);
5392         }
5393     }
5394     SP = ORIGMARK;
5395     if (OP_GIMME(PL_op, 0) != G_VOID) {
5396         PUSHi( AvFILL(ary) + 1 );
5397     }
5398     RETURN;
5399 }
5400
5401 PP(pp_reverse)
5402 {
5403     dSP; dMARK;
5404
5405     if (GIMME_V == G_ARRAY) {
5406         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5407             AV *av;
5408
5409             /* See pp_sort() */
5410             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5411             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5412             av = MUTABLE_AV((*SP));
5413             /* In-place reversing only happens in void context for the array
5414              * assignment. We don't need to push anything on the stack. */
5415             SP = MARK;
5416
5417             if (SvMAGICAL(av)) {
5418                 SSize_t i, j;
5419                 SV *tmp = sv_newmortal();
5420                 /* For SvCANEXISTDELETE */
5421                 HV *stash;
5422                 const MAGIC *mg;
5423                 bool can_preserve = SvCANEXISTDELETE(av);
5424
5425                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5426                     SV *begin, *end;
5427
5428                     if (can_preserve) {
5429                         if (!av_exists(av, i)) {
5430                             if (av_exists(av, j)) {
5431                                 SV *sv = av_delete(av, j, 0);
5432                                 begin = *av_fetch(av, i, TRUE);
5433                                 sv_setsv_mg(begin, sv);
5434                             }
5435                             continue;
5436                         }
5437                         else if (!av_exists(av, j)) {
5438                             SV *sv = av_delete(av, i, 0);
5439                             end = *av_fetch(av, j, TRUE);
5440                             sv_setsv_mg(end, sv);
5441                             continue;
5442                         }
5443                     }
5444
5445                     begin = *av_fetch(av, i, TRUE);
5446                     end   = *av_fetch(av, j, TRUE);
5447                     sv_setsv(tmp,      begin);
5448                     sv_setsv_mg(begin, end);
5449                     sv_setsv_mg(end,   tmp);
5450                 }
5451             }
5452             else {
5453                 SV **begin = AvARRAY(av);
5454
5455                 if (begin) {
5456                     SV **end   = begin + AvFILLp(av);
5457
5458                     while (begin < end) {
5459                         SV * const tmp = *begin;
5460                         *begin++ = *end;
5461                         *end--   = tmp;
5462                     }
5463                 }
5464             }
5465         }
5466         else {
5467             SV **oldsp = SP;
5468             MARK++;
5469             while (MARK < SP) {
5470                 SV * const tmp = *MARK;
5471                 *MARK++ = *SP;
5472                 *SP--   = tmp;
5473             }
5474             /* safe as long as stack cannot get extended in the above */
5475             SP = oldsp;
5476         }
5477     }
5478     else {
5479         char *up;
5480         char *down;
5481         I32 tmp;
5482         dTARGET;
5483         STRLEN len;
5484
5485         SvUTF8_off(TARG);                               /* decontaminate */
5486         if (SP - MARK > 1)
5487             do_join(TARG, &PL_sv_no, MARK, SP);
5488         else {
5489             sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5490         }
5491
5492         up = SvPV_force(TARG, len);
5493         if (len > 1) {
5494             if (DO_UTF8(TARG)) {        /* first reverse each character */
5495                 U8* s = (U8*)SvPVX(TARG);
5496                 const U8* send = (U8*)(s + len);
5497                 while (s < send) {
5498                     if (UTF8_IS_INVARIANT(*s)) {
5499                         s++;
5500                         continue;
5501                     }
5502                     else {
5503                         if (!utf8_to_uvchr_buf(s, send, 0))
5504                             break;
5505                         up = (char*)s;
5506                         s += UTF8SKIP(s);
5507                         down = (char*)(s - 1);
5508                         /* reverse this character */
5509                         while (down > up) {
5510                             tmp = *up;
5511                             *up++ = *down;
5512                             *down-- = (char)tmp;
5513                         }
5514                     }
5515                 }
5516                 up = SvPVX(TARG);
5517             }
5518             down = SvPVX(TARG) + len - 1;
5519             while (down > up) {
5520                 tmp = *up;
5521                 *up++ = *down;
5522                 *down-- = (char)tmp;
5523             }
5524             (void)SvPOK_only_UTF8(TARG);
5525         }
5526         SP = MARK + 1;
5527         SETTARG;
5528     }
5529     RETURN;
5530 }
5531
5532 PP(pp_split)
5533 {
5534     dSP; dTARG;
5535     AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5536     IV limit = POPi;                    /* note, negative is forever */
5537     SV * const sv = POPs;
5538     STRLEN len;
5539     const char *s = SvPV_const(sv, len);
5540     const bool do_utf8 = DO_UTF8(sv);
5541     const char *strend = s + len;
5542     PMOP *pm;
5543     REGEXP *rx;
5544     SV *dstr;
5545     const char *m;
5546     SSize_t iters = 0;
5547     const STRLEN slen = do_utf8
5548                         ? utf8_length((U8*)s, (U8*)strend)
5549                         : (STRLEN)(strend - s);
5550     SSize_t maxiters = slen + 10;
5551     I32 trailing_empty = 0;
5552     const char *orig;
5553     const I32 origlimit = limit;
5554     I32 realarray = 0;
5555     I32 base;
5556     const I32 gimme = GIMME_V;
5557     bool gimme_scalar;
5558     const I32 oldsave = PL_savestack_ix;
5559     U32 make_mortal = SVs_TEMP;
5560     bool multiline = 0;
5561     MAGIC *mg = NULL;
5562
5563 #ifdef DEBUGGING
5564     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5565 #else
5566     pm = (PMOP*)POPs;
5567 #endif
5568     if (!pm)
5569         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5570     rx = PM_GETRE(pm);
5571
5572     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5573              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5574
5575 #ifdef USE_ITHREADS
5576     if (pm->op_pmreplrootu.op_pmtargetoff) {
5577         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5578         goto have_av;
5579     }
5580 #else
5581     if (pm->op_pmreplrootu.op_pmtargetgv) {
5582         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5583         goto have_av;
5584     }
5585 #endif
5586     else if (pm->op_targ)
5587         ary = (AV *)PAD_SVl(pm->op_targ);
5588     if (ary) {
5589         have_av:
5590         realarray = 1;
5591         PUTBACK;
5592         av_extend(ary,0);
5593         (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5594         av_clear(ary);
5595         SPAGAIN;
5596         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5597             PUSHMARK(SP);
5598             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5599         }
5600         else {
5601             if (!AvREAL(ary)) {
5602                 I32 i;
5603                 AvREAL_on(ary);
5604                 AvREIFY_off(ary);
5605                 for (i = AvFILLp(ary); i >= 0; i--)
5606                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5607             }
5608             /* temporarily switch stacks */
5609             SAVESWITCHSTACK(PL_curstack, ary);
5610             make_mortal = 0;
5611         }
5612     }
5613     base = SP - PL_stack_base;
5614     orig = s;
5615     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5616         if (do_utf8) {
5617             while (isSPACE_utf8(s))
5618                 s += UTF8SKIP(s);
5619         }
5620         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5621             while (isSPACE_LC(*s))
5622                 s++;
5623         }
5624         else {
5625             while (isSPACE(*s))
5626                 s++;
5627         }
5628     }
5629     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5630         multiline = 1;
5631     }
5632
5633     gimme_scalar = gimme == G_SCALAR && !ary;
5634
5635     if (!limit)
5636         limit = maxiters + 2;
5637     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5638         while (--limit) {
5639             m = s;
5640             /* this one uses 'm' and is a negative test */
5641             if (do_utf8) {
5642                 while (m < strend && ! isSPACE_utf8(m) ) {
5643                     const int t = UTF8SKIP(m);
5644                     /* isSPACE_utf8 returns FALSE for malform utf8 */
5645                     if (strend - m < t)
5646                         m = strend;
5647                     else
5648                         m += t;
5649                 }
5650             }
5651             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5652             {
5653                 while (m < strend && !isSPACE_LC(*m))
5654                     ++m;
5655             } else {
5656                 while (m < strend && !isSPACE(*m))
5657                     ++m;
5658             }
5659             if (m >= strend)
5660                 break;
5661
5662             if (gimme_scalar) {
5663                 iters++;
5664                 if (m-s == 0)
5665                     trailing_empty++;
5666                 else
5667                     trailing_empty = 0;
5668             } else {
5669                 dstr = newSVpvn_flags(s, m-s,
5670                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5671                 XPUSHs(dstr);
5672             }
5673
5674             /* skip the whitespace found last */
5675             if (do_utf8)
5676                 s = m + UTF8SKIP(m);
5677             else
5678                 s = m + 1;
5679
5680             /* this one uses 's' and is a positive test */
5681             if (do_utf8) {
5682                 while (s < strend && isSPACE_utf8(s) )
5683                     s +=  UTF8SKIP(s);
5684             }
5685             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5686             {
5687                 while (s < strend && isSPACE_LC(*s))
5688                     ++s;
5689             } else {
5690                 while (s < strend && isSPACE(*s))
5691                     ++s;
5692             }
5693         }
5694     }
5695     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5696         while (--limit) {
5697             for (m = s; m < strend && *m != '\n'; m++)
5698                 ;
5699             m++;
5700             if (m >= strend)
5701                 break;
5702
5703             if (gimme_scalar) {
5704                 iters++;
5705                 if (m-s == 0)
5706                     trailing_empty++;
5707                 else
5708                     trailing_empty = 0;
5709             } else {
5710                 dstr = newSVpvn_flags(s, m-s,
5711                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5712                 XPUSHs(dstr);
5713             }
5714             s = m;
5715         }
5716     }
5717     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5718         /*
5719           Pre-extend the stack, either the number of bytes or
5720           characters in the string or a limited amount, triggered by:
5721
5722           my ($x, $y) = split //, $str;
5723             or
5724           split //, $str, $i;
5725         */
5726         if (!gimme_scalar) {
5727             const U32 items = limit - 1;
5728             if (items < slen)
5729                 EXTEND(SP, items);
5730             else
5731                 EXTEND(SP, slen);
5732         }
5733
5734         if (do_utf8) {
5735             while (--limit) {
5736                 /* keep track of how many bytes we skip over */
5737                 m = s;
5738                 s += UTF8SKIP(s);
5739                 if (gimme_scalar) {
5740                     iters++;
5741                     if (s-m == 0)
5742                         trailing_empty++;
5743                     else
5744                         trailing_empty = 0;
5745                 } else {
5746                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5747
5748                     PUSHs(dstr);
5749                 }
5750
5751                 if (s >= strend)
5752                     break;
5753             }
5754         } else {
5755             while (--limit) {
5756                 if (gimme_scalar) {
5757                     iters++;
5758                 } else {
5759                     dstr = newSVpvn(s, 1);
5760
5761
5762                     if (make_mortal)
5763                         sv_2mortal(dstr);
5764
5765                     PUSHs(dstr);
5766                 }
5767
5768                 s++;
5769
5770                 if (s >= strend)
5771                     break;
5772             }
5773         }
5774     }
5775     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5776              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5777              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5778              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5779         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5780         SV * const csv = CALLREG_INTUIT_STRING(rx);
5781
5782         len = RX_MINLENRET(rx);
5783         if (len == 1 && !RX_UTF8(rx) && !tail) {
5784             const char c = *SvPV_nolen_const(csv);
5785             while (--limit) {
5786                 for (m = s; m < strend && *m != c; m++)
5787                     ;
5788                 if (m >= strend)
5789                     break;
5790                 if (gimme_scalar) {
5791                     iters++;
5792                     if (m-s == 0)
5793                         trailing_empty++;
5794                     else
5795                         trailing_empty = 0;
5796                 } else {
5797                     dstr = newSVpvn_flags(s, m-s,
5798                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5799                     XPUSHs(dstr);
5800                 }
5801                 /* The rx->minlen is in characters but we want to step
5802                  * s ahead by bytes. */
5803                 if (do_utf8)
5804                     s = (char*)utf8_hop((U8*)m, len);
5805                 else
5806                     s = m + len; /* Fake \n at the end */
5807             }
5808         }
5809         else {
5810             while (s < strend && --limit &&
5811               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5812                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5813             {
5814                 if (gimme_scalar) {
5815                     iters++;
5816                     if (m-s == 0)
5817                         trailing_empty++;
5818                     else
5819                         trailing_empty = 0;
5820                 } else {
5821                     dstr = newSVpvn_flags(s, m-s,
5822                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5823                     XPUSHs(dstr);
5824                 }
5825                 /* The rx->minlen is in characters but we want to step
5826                  * s ahead by bytes. */
5827                 if (do_utf8)
5828                     s = (char*)utf8_hop((U8*)m, len);
5829                 else
5830                     s = m + len; /* Fake \n at the end */
5831             }
5832         }
5833     }
5834     else {
5835         maxiters += slen * RX_NPARENS(rx);
5836         while (s < strend && --limit)
5837         {
5838             I32 rex_return;
5839             PUTBACK;
5840             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5841                                      sv, NULL, 0);
5842             SPAGAIN;
5843             if (rex_return == 0)
5844                 break;
5845             TAINT_IF(RX_MATCH_TAINTED(rx));
5846             /* we never pass the REXEC_COPY_STR flag, so it should
5847              * never get copied */
5848             assert(!RX_MATCH_COPIED(rx));
5849             m = RX_OFFS(rx)[0].start + orig;
5850
5851             if (gimme_scalar) {
5852                 iters++;
5853                 if (m-s == 0)
5854                     trailing_empty++;
5855                 else
5856                     trailing_empty = 0;
5857             } else {
5858                 dstr = newSVpvn_flags(s, m-s,
5859                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5860                 XPUSHs(dstr);
5861             }
5862             if (RX_NPARENS(rx)) {
5863                 I32 i;
5864                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5865                     s = RX_OFFS(rx)[i].start + orig;
5866                     m = RX_OFFS(rx)[i].end + orig;
5867
5868                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5869                        parens that didn't match -- they should be set to
5870                        undef, not the empty string */
5871                     if (gimme_scalar) {
5872                         iters++;
5873                         if (m-s == 0)
5874                             trailing_empty++;
5875                         else
5876                             trailing_empty = 0;
5877                     } else {
5878                         if (m >= orig && s >= orig) {
5879                             dstr = newSVpvn_flags(s, m-s,
5880                                                  (do_utf8 ? SVf_UTF8 : 0)
5881                                                   | make_mortal);
5882                         }
5883                         else
5884                             dstr = &PL_sv_undef;  /* undef, not "" */
5885                         XPUSHs(dstr);
5886                     }
5887
5888                 }
5889             }
5890             s = RX_OFFS(rx)[0].end + orig;
5891         }
5892     }
5893
5894     if (!gimme_scalar) {
5895         iters = (SP - PL_stack_base) - base;
5896     }
5897     if (iters > maxiters)
5898         DIE(aTHX_ "Split loop");
5899
5900     /* keep field after final delim? */
5901     if (s < strend || (iters && origlimit)) {
5902         if (!gimme_scalar) {
5903             const STRLEN l = strend - s;
5904             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5905             XPUSHs(dstr);
5906         }
5907         iters++;
5908     }
5909     else if (!origlimit) {
5910         if (gimme_scalar) {
5911             iters -= trailing_empty;
5912         } else {
5913             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5914                 if (TOPs && !make_mortal)
5915                     sv_2mortal(TOPs);
5916                 *SP-- = &PL_sv_undef;
5917                 iters--;
5918             }
5919         }
5920     }
5921
5922     PUTBACK;
5923     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5924     SPAGAIN;
5925     if (realarray) {
5926         if (!mg) {
5927             if (SvSMAGICAL(ary)) {
5928                 PUTBACK;
5929                 mg_set(MUTABLE_SV(ary));
5930                 SPAGAIN;
5931             }
5932             if (gimme == G_ARRAY) {
5933                 EXTEND(SP, iters);
5934                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5935                 SP += iters;
5936                 RETURN;
5937             }
5938         }
5939         else {
5940             PUTBACK;
5941             ENTER_with_name("call_PUSH");
5942             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5943             LEAVE_with_name("call_PUSH");
5944             SPAGAIN;
5945             if (gimme == G_ARRAY) {
5946                 SSize_t i;
5947                 /* EXTEND should not be needed - we just popped them */
5948                 EXTEND(SP, iters);
5949                 for (i=0; i < iters; i++) {
5950                     SV **svp = av_fetch(ary, i, FALSE);
5951                     PUSHs((svp) ? *svp : &PL_sv_undef);
5952                 }
5953                 RETURN;
5954             }
5955         }
5956     }
5957     else {
5958         if (gimme == G_ARRAY)
5959             RETURN;
5960     }
5961
5962     GETTARGET;
5963     PUSHi(iters);
5964     RETURN;
5965 }
5966
5967 PP(pp_once)
5968 {
5969     dSP;
5970     SV *const sv = PAD_SVl(PL_op->op_targ);
5971
5972     if (SvPADSTALE(sv)) {
5973         /* First time. */
5974         SvPADSTALE_off(sv);
5975         RETURNOP(cLOGOP->op_other);
5976     }
5977     RETURNOP(cLOGOP->op_next);
5978 }
5979
5980 PP(pp_lock)
5981 {
5982     dSP;
5983     dTOPss;
5984     SV *retsv = sv;
5985     SvLOCK(sv);
5986     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5987      || SvTYPE(retsv) == SVt_PVCV) {
5988         retsv = refto(retsv);
5989     }
5990     SETs(retsv);
5991     RETURN;
5992 }
5993
5994
5995 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
5996  * that aren't implemented on a particular platform */
5997
5998 PP(unimplemented_op)
5999 {
6000     const Optype op_type = PL_op->op_type;
6001     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6002        with out of range op numbers - it only "special" cases op_custom.
6003        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6004        if we get here for a custom op then that means that the custom op didn't
6005        have an implementation. Given that OP_NAME() looks up the custom op
6006        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6007        registers &PL_unimplemented_op as the address of their custom op.
6008        NULL doesn't generate a useful error message. "custom" does. */
6009     const char *const name = op_type >= OP_max
6010         ? "[out of range]" : PL_op_name[PL_op->op_type];
6011     if(OP_IS_SOCKET(op_type))
6012         DIE(aTHX_ PL_no_sock_func, name);
6013     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6014 }
6015
6016 /* For sorting out arguments passed to a &CORE:: subroutine */
6017 PP(pp_coreargs)
6018 {
6019     dSP;
6020     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6021     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6022     AV * const at_ = GvAV(PL_defgv);
6023     SV **svp = at_ ? AvARRAY(at_) : NULL;
6024     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6025     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6026     bool seen_question = 0;
6027     const char *err = NULL;
6028     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6029
6030     /* Count how many args there are first, to get some idea how far to
6031        extend the stack. */
6032     while (oa) {
6033         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6034         maxargs++;
6035         if (oa & OA_OPTIONAL) seen_question = 1;
6036         if (!seen_question) minargs++;
6037         oa >>= 4;
6038     }
6039
6040     if(numargs < minargs) err = "Not enough";
6041     else if(numargs > maxargs) err = "Too many";
6042     if (err)
6043         /* diag_listed_as: Too many arguments for %s */
6044         Perl_croak(aTHX_
6045           "%s arguments for %s", err,
6046            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6047         );
6048
6049     /* Reset the stack pointer.  Without this, we end up returning our own
6050        arguments in list context, in addition to the values we are supposed
6051        to return.  nextstate usually does this on sub entry, but we need
6052        to run the next op with the caller's hints, so we cannot have a
6053        nextstate. */
6054     SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6055
6056     if(!maxargs) RETURN;
6057
6058     /* We do this here, rather than with a separate pushmark op, as it has
6059        to come in between two things this function does (stack reset and
6060        arg pushing).  This seems the easiest way to do it. */
6061     if (pushmark) {
6062         PUTBACK;
6063         (void)Perl_pp_pushmark(aTHX);
6064     }
6065
6066     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6067     PUTBACK; /* The code below can die in various places. */
6068
6069     oa = PL_opargs[opnum] >> OASHIFT;
6070     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6071         whicharg++;
6072         switch (oa & 7) {
6073         case OA_SCALAR:
6074           try_defsv:
6075             if (!numargs && defgv && whicharg == minargs + 1) {
6076                 PUSHs(find_rundefsv2(
6077                     find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
6078                     cxstack[cxstack_ix].blk_oldcop->cop_seq
6079                 ));
6080             }
6081             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6082             break;
6083         case OA_LIST:
6084             while (numargs--) {
6085                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6086                 svp++;
6087             }
6088             RETURN;
6089         case OA_HVREF:
6090             if (!svp || !*svp || !SvROK(*svp)
6091              || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6092                 DIE(aTHX_
6093                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6094                  "Type of arg %d to &CORE::%s must be hash reference",
6095                   whicharg, OP_DESC(PL_op->op_next)
6096                 );
6097             PUSHs(SvRV(*svp));
6098             break;
6099         case OA_FILEREF:
6100             if (!numargs) PUSHs(NULL);
6101             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6102                 /* no magic here, as the prototype will have added an extra
6103                    refgen and we just want what was there before that */
6104                 PUSHs(SvRV(*svp));
6105             else {
6106                 const bool constr = PL_op->op_private & whicharg;
6107                 PUSHs(S_rv2gv(aTHX_
6108                     svp && *svp ? *svp : &PL_sv_undef,
6109                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6110                     !constr
6111                 ));
6112             }
6113             break;
6114         case OA_SCALARREF:
6115           if (!numargs) goto try_defsv;
6116           else {
6117             const bool wantscalar =
6118                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6119             if (!svp || !*svp || !SvROK(*svp)
6120                 /* We have to permit globrefs even for the \$ proto, as
6121                    *foo is indistinguishable from ${\*foo}, and the proto-
6122                    type permits the latter. */
6123              || SvTYPE(SvRV(*svp)) > (
6124                      wantscalar       ? SVt_PVLV
6125                    : opnum == OP_LOCK || opnum == OP_UNDEF
6126                                       ? SVt_PVCV
6127                    :                    SVt_PVHV
6128                 )
6129                )
6130                 DIE(aTHX_
6131                  "Type of arg %d to &CORE::%s must be %s",
6132                   whicharg, PL_op_name[opnum],
6133                   wantscalar
6134                     ? "scalar reference"
6135                     : opnum == OP_LOCK || opnum == OP_UNDEF
6136                        ? "reference to one of [$@%&*]"
6137                        : "reference to one of [$@%*]"
6138                 );
6139             PUSHs(SvRV(*svp));
6140             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6141              && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6142                 /* Undo @_ localisation, so that sub exit does not undo
6143                    part of our undeffing. */
6144                 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6145                 POP_SAVEARRAY();
6146                 cx->cx_type &= ~ CXp_HASARGS;
6147                 assert(!AvREAL(cx->blk_sub.argarray));
6148             }
6149           }
6150           break;
6151         default:
6152             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6153         }
6154         oa = oa >> 4;
6155     }
6156
6157     RETURN;
6158 }
6159
6160 PP(pp_runcv)
6161 {
6162     dSP;
6163     CV *cv;
6164     if (PL_op->op_private & OPpOFFBYONE) {
6165         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6166     }
6167     else cv = find_runcv(NULL);
6168     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6169     RETURN;
6170 }
6171
6172 static void
6173 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6174                             const bool can_preserve)
6175 {
6176     const SSize_t ix = SvIV(keysv);
6177     if (can_preserve ? av_exists(av, ix) : TRUE) {
6178         SV ** const svp = av_fetch(av, ix, 1);
6179         if (!svp || !*svp)
6180             Perl_croak(aTHX_ PL_no_aelem, ix);
6181         save_aelem(av, ix, svp);
6182     }
6183     else
6184         SAVEADELETE(av, ix);
6185 }
6186
6187 static void
6188 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6189                             const bool can_preserve)
6190 {
6191     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6192         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6193         SV ** const svp = he ? &HeVAL(he) : NULL;
6194         if (!svp || !*svp)
6195             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6196         save_helem_flags(hv, keysv, svp, 0);
6197     }
6198     else
6199         SAVEHDELETE(hv, keysv);
6200 }
6201
6202 static void
6203 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6204 {
6205     if (type == OPpLVREF_SV) {
6206         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6207         GvSV(gv) = 0;
6208     }
6209     else if (type == OPpLVREF_AV)
6210         /* XXX Inefficient, as it creates a new AV, which we are
6211                about to clobber.  */
6212         save_ary(gv);
6213     else {
6214         assert(type == OPpLVREF_HV);
6215         /* XXX Likewise inefficient.  */
6216         save_hash(gv);
6217     }
6218 }
6219
6220
6221 PP(pp_refassign)
6222 {
6223     dSP;
6224     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6225     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6226     dTOPss;
6227     const char *bad = NULL;
6228     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6229     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6230     switch (type) {
6231     case OPpLVREF_SV:
6232         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6233             bad = " SCALAR";
6234         break;
6235     case OPpLVREF_AV:
6236         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6237             bad = "n ARRAY";
6238         break;
6239     case OPpLVREF_HV:
6240         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6241             bad = " HASH";
6242         break;
6243     case OPpLVREF_CV:
6244         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6245             bad = " CODE";
6246     }
6247     if (bad)
6248         /* diag_listed_as: Assigned value is not %s reference */
6249         DIE(aTHX_ "Assigned value is not a%s reference", bad);
6250     {
6251     MAGIC *mg;
6252     HV *stash;
6253     switch (left ? SvTYPE(left) : 0) {
6254     case 0:
6255     {
6256         SV * const old = PAD_SV(ARGTARG);
6257         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6258         SvREFCNT_dec(old);
6259         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6260                 == OPpLVAL_INTRO)
6261             SAVECLEARSV(PAD_SVl(ARGTARG));
6262         break;
6263     }
6264     case SVt_PVGV:
6265         if (PL_op->op_private & OPpLVAL_INTRO) {
6266             S_localise_gv_slot(aTHX_ (GV *)left, type);
6267         }
6268         gv_setref(left, sv);
6269         SvSETMAGIC(left);
6270         break;
6271     case SVt_PVAV:
6272         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6273             S_localise_aelem_lval(aTHX_ (AV *)left, key,
6274                                         SvCANEXISTDELETE(left));
6275         }
6276         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6277         break;
6278     case SVt_PVHV:
6279         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
6280             S_localise_helem_lval(aTHX_ (HV *)left, key,
6281                                         SvCANEXISTDELETE(left));
6282         (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6283     }
6284     if (PL_op->op_flags & OPf_MOD)
6285         SETs(sv_2mortal(newSVsv(sv)));
6286     /* XXX else can weak references go stale before they are read, e.g.,
6287        in leavesub?  */
6288     RETURN;
6289     }
6290 }
6291
6292 PP(pp_lvref)
6293 {
6294     dSP;
6295     SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6296     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6297     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6298     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6299                                    &PL_vtbl_lvref, (char *)elem,
6300                                    elem ? HEf_SVKEY : (I32)ARGTARG);
6301     mg->mg_private = PL_op->op_private;
6302     if (PL_op->op_private & OPpLVREF_ITER)
6303         mg->mg_flags |= MGf_PERSIST;
6304     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6305       if (elem) {
6306         MAGIC *mg;
6307         HV *stash;
6308         const bool can_preserve = SvCANEXISTDELETE(arg);
6309         if (SvTYPE(arg) == SVt_PVAV)
6310             S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6311         else
6312             S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6313       }
6314       else if (arg) {
6315         S_localise_gv_slot(aTHX_ (GV *)arg,
6316                                  PL_op->op_private & OPpLVREF_TYPE);
6317       }
6318       else if (!(PL_op->op_private & OPpPAD_STATE))
6319         SAVECLEARSV(PAD_SVl(ARGTARG));
6320     }
6321     XPUSHs(ret);
6322     RETURN;
6323 }
6324
6325 PP(pp_lvrefslice)
6326 {
6327     dSP; dMARK;
6328     AV * const av = (AV *)POPs;
6329     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6330     bool can_preserve = FALSE;
6331
6332     if (UNLIKELY(localizing)) {
6333         MAGIC *mg;
6334         HV *stash;
6335         SV **svp;
6336
6337         can_preserve = SvCANEXISTDELETE(av);
6338
6339         if (SvTYPE(av) == SVt_PVAV) {
6340             SSize_t max = -1;
6341
6342             for (svp = MARK + 1; svp <= SP; svp++) {
6343                 const SSize_t elem = SvIV(*svp);
6344                 if (elem > max)
6345                     max = elem;
6346             }
6347             if (max > AvMAX(av))
6348                 av_extend(av, max);
6349         }
6350     }
6351
6352     while (++MARK <= SP) {
6353         SV * const elemsv = *MARK;
6354         if (SvTYPE(av) == SVt_PVAV)
6355             S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6356         else
6357             S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6358         *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6359         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6360     }
6361     RETURN;
6362 }
6363
6364 PP(pp_lvavref)
6365 {
6366     if (PL_op->op_flags & OPf_STACKED)
6367         Perl_pp_rv2av(aTHX);
6368     else
6369         Perl_pp_padav(aTHX);
6370     {
6371         dSP;
6372         dTOPss;
6373         SETs(0); /* special alias marker that aassign recognises */
6374         XPUSHs(sv);
6375         RETURN;
6376     }
6377 }
6378
6379 PP(pp_anonconst)
6380 {
6381     dSP;
6382     dTOPss;
6383     SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6384                                         ? CopSTASH(PL_curcop)
6385                                         : NULL,
6386                                       NULL, SvREFCNT_inc_simple_NN(sv))));
6387     RETURN;
6388 }
6389
6390 /*
6391  * Local variables:
6392  * c-indentation-style: bsd
6393  * c-basic-offset: 4
6394  * indent-tabs-mode: nil
6395  * End:
6396  *
6397  * ex: set ts=8 sts=4 sw=4 et:
6398  */