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