pp.c

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