pp.c

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