pp.c

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