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