pp.c

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