pp.c

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