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