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