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