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