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