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