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 "invlist_inline.h"
  32 #include "reentr.h"
  33 #include "regcharclass.h"
  34
  35 /* variations on pp_null */
  36
  37 PP(pp_stub)
  38 {
  39     if (GIMME_V == G_SCALAR)
  40         rpp_xpush_1(&PL_sv_undef);
  41     return NORMAL;
  42 }
  43
  44 /* Pushy stuff. */
  45
  46
  47
  48 PP(pp_padcv)
  49 {
  50     dTARGET;
  51     assert(SvTYPE(TARG) == SVt_PVCV);
  52     rpp_xpush_1(TARG);
  53     return NORMAL;
  54 }
  55
  56 PP(pp_introcv)
  57 {
  58     dTARGET;
  59     SvPADSTALE_off(TARG);
  60     return NORMAL;
  61 }
  62
  63 PP(pp_clonecv)
  64 {
  65     dTARGET;
  66     CV * const protocv = PadnamePROTOCV(
  67         PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
  68     );
  69     assert(SvTYPE(TARG) == SVt_PVCV);
  70     assert(protocv);
  71     if (CvISXSUB(protocv)) { /* constant */
  72         /* XXX Should we clone it here? */
  73         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
  74            to introcv and remove the SvPADSTALE_off. */
  75         SAVEPADSVANDMORTALIZE(ARGTARG);
  76         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
  77     }
  78     else {
  79         if (CvROOT(protocv)) {
  80             assert(CvCLONE(protocv));
  81             assert(!CvCLONED(protocv));
  82         }
  83         cv_clone_into(protocv,(CV *)TARG);
  84         SAVECLEARSV(PAD_SVl(ARGTARG));
  85     }
  86     return NORMAL;
  87 }
  88
  89 /* Translations. */
  90
  91 /* In some cases this function inspects PL_op.  If this function is called
  92    for new op types, more bool parameters may need to be added in place of
  93    the checks.
  94
  95    When noinit is true, the absence of a gv will cause a retval of undef.
  96    This is unrelated to the cv-to-gv assignment case.
  97 */
  98
  99 static SV *
 100 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
 101               const bool noinit)
 102 {
 103     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
 104     if (SvROK(sv)) {
 105         if (SvAMAGIC(sv)) {
 106             sv = amagic_deref_call(sv, to_gv_amg);
 107         }
 108       wasref:
 109         sv = SvRV(sv);
 110         if (SvTYPE(sv) == SVt_PVIO) {
 111             GV * const gv = MUTABLE_GV(sv_newmortal());
 112             gv_init(gv, 0, "__ANONIO__", 10, 0);
 113             GvIOp(gv) = MUTABLE_IO(sv);
 114             SvREFCNT_inc_void_NN(sv);
 115             sv = MUTABLE_SV(gv);
 116         }
 117         else if (!isGV_with_GP(sv)) {
 118             Perl_die(aTHX_ "Not a GLOB reference");
 119         }
 120     }
 121     else {
 122         if (!isGV_with_GP(sv)) {
 123             if (!SvOK(sv)) {
 124                 /* If this is a 'my' scalar and flag is set then vivify
 125                  * NI-S 1999/05/07
 126                  */
 127                 if (vivify_sv && sv != &PL_sv_undef) {
 128                     GV *gv;
 129                     HV *stash;
 130                     if (SvREADONLY(sv))
 131                         Perl_croak_no_modify();
 132                     gv = MUTABLE_GV(newSV_type(SVt_NULL));
 133                     stash = CopSTASH(PL_curcop);
 134                     if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
 135                     if (cUNOP->op_targ) {
 136                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 137                         gv_init_sv(gv, stash, namesv, 0);
 138                     }
 139                     else {
 140                         gv_init_pv(gv, stash, "__ANONIO__", 0);
 141                     }
 142                     sv_setrv_noinc_mg(sv, MUTABLE_SV(gv));
 143                     goto wasref;
 144                 }
 145                 if (PL_op->op_flags & OPf_REF || strict) {
 146                     Perl_die(aTHX_ PL_no_usym, "a symbol");
 147                 }
 148                 if (ckWARN(WARN_UNINITIALIZED))
 149                     report_uninit(sv);
 150                 return &PL_sv_undef;
 151             }
 152             if (noinit)
 153             {
 154                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
 155                            sv, GV_ADDMG, SVt_PVGV
 156                    ))))
 157                     return &PL_sv_undef;
 158             }
 159             else {
 160                 if (strict) {
 161                     Perl_die(aTHX_
 162                              PL_no_symref_sv,
 163                              sv,
 164                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
 165                              "a symbol"
 166                              );
 167                 }
 168                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 169                     == OPpDONT_INIT_GV) {
 170                     /* We are the target of a coderef assignment.  Return
 171                        the scalar unchanged, and let pp_sasssign deal with
 172                        things.  */
 173                     return sv;
 174                 }
 175                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
 176             }
 177             /* FAKE globs in the symbol table cause weird bugs (#77810) */
 178             SvFAKE_off(sv);
 179         }
 180     }
 181     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
 182         SV *newsv = sv_mortalcopy_flags(sv, 0);
 183         SvFAKE_off(newsv);
 184         sv = newsv;
 185     }
 186     return sv;
 187 }
 188
 189 PP_wrapped(pp_rv2gv, 1, 0)
 190 {
 191     dSP; dTOPss;
 192
 193     sv = S_rv2gv(aTHX_
 194           sv, PL_op->op_private & OPpDEREF,
 195           PL_op->op_private & HINT_STRICT_REFS,
 196           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
 197              || PL_op->op_type == OP_READLINE
 198          );
 199     if (PL_op->op_private & OPpLVAL_INTRO)
 200         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 201     SETs(sv);
 202     RETURN;
 203 }
 204
 205 /* Helper function for pp_rv2sv and pp_rv2av/hv.
 206  *
 207  * Return a GV based on the value of sv, using symbolic references etc.
 208  * On success: leaves argument on stack and returns gv.
 209  * On failure: pops one item off stack;
 210  *             then unless (list context and not rv2sv), also pushes undef;
 211  *             then returns NULL.
 212  */
 213
 214 GV *
 215 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 216                 const svtype type)
 217 {
 218     GV *gv;
 219
 220     PERL_ARGS_ASSERT_SOFTREF2XV;
 221
 222     if (PL_op->op_private & HINT_STRICT_REFS) {
 223         if (SvOK(sv))
 224             Perl_die(aTHX_ PL_no_symref_sv, sv,
 225                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 226         else
 227             Perl_die(aTHX_ PL_no_usym, what);
 228     }
 229     if (!SvOK(sv)) {
 230         if (
 231           PL_op->op_flags & OPf_REF
 232         )
 233             Perl_die(aTHX_ PL_no_usym, what);
 234         if (ckWARN(WARN_UNINITIALIZED))
 235             report_uninit(sv);
 236         if (type != SVt_PV && GIMME_V == G_LIST) {
 237             rpp_popfree_1();
 238             return NULL;
 239         }
 240         rpp_replace_1_1(&PL_sv_undef);
 241         return NULL;
 242     }
 243     if ((PL_op->op_flags & OPf_SPECIAL) &&
 244         !(PL_op->op_flags & OPf_MOD))
 245         {
 246             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
 247                 {
 248                     rpp_replace_1_1(&PL_sv_undef);
 249                     return NULL;
 250                 }
 251         }
 252     else {
 253         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
 254     }
 255     return gv;
 256 }
 257
 258 PP(pp_rv2sv)
 259 {
 260     SV *sv = *PL_stack_sp;
 261     GV *gv = NULL;
 262
 263     SvGETMAGIC(sv);
 264     if (SvROK(sv)) {
 265         if (SvAMAGIC(sv)) {
 266             sv = amagic_deref_call(sv, to_sv_amg);
 267         }
 268
 269         sv = SvRV(sv);
 270         if (SvTYPE(sv) >= SVt_PVAV)
 271             DIE(aTHX_ "Not a SCALAR reference");
 272     }
 273     else {
 274         gv = MUTABLE_GV(sv);
 275
 276         if (!isGV_with_GP(gv)) {
 277             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV);
 278             if (!gv)
 279                 return NORMAL;
 280         }
 281         sv = GvSVn(gv);
 282     }
 283     if (PL_op->op_flags & OPf_MOD) {
 284         if (PL_op->op_private & OPpLVAL_INTRO) {
 285             if (cUNOP->op_first->op_type == OP_NULL)
 286                 sv = save_scalar(MUTABLE_GV(*PL_stack_sp));
 287             else if (gv)
 288                 sv = save_scalar(gv);
 289             else
 290                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 291         }
 292         else if (PL_op->op_private & OPpDEREF)
 293             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
 294     }
 295     rpp_replace_1_1(sv);
 296     return NORMAL;
 297 }
 298
 299 PP(pp_av2arylen)
 300 {
 301     AV * const av = MUTABLE_AV(*PL_stack_sp);
 302     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 303     if (lvalue) {
 304         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 305         if (!*svp) {
 306             *svp = newSV_type(SVt_PVMG);
 307             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 308         }
 309         SV *sv_al = *svp; /* the temporary SV with arylen magic */
 310 #ifdef PERL_RC_STACK
 311         if (SvREFCNT(av) == 1) {
 312             /* At this point there are two SVs pointing at each other,
 313              * av and sv_al. av -> sv_al is strong (MGf_REFCOUNTED),
 314              * while sv_al -> av is weak, to avoid a leaking loop.
 315              *
 316              * The only thing keeping av alive right now is the ref from
 317              * the stack. We want to swap av and sv_al on the stack, but
 318              * that would trigger freeing av. So keep the ref counts and
 319              * just swap the strong/weak pointer settings.
 320              *
 321              * XXX perhaps this should be done even for SvREFCNT(av)>1 ?
 322              */
 323             MAGIC *mg_av = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 324             MAGIC *mg_al = mg_find(sv_al,          PERL_MAGIC_arylen);
 325             assert(mg_av);
 326             assert(mg_al);
 327             assert(  mg_av->mg_flags & MGf_REFCOUNTED);
 328             assert(!(mg_al->mg_flags & MGf_REFCOUNTED));
 329             mg_av->mg_flags &= ~MGf_REFCOUNTED;
 330             mg_al->mg_flags |=  MGf_REFCOUNTED;
 331             *PL_stack_sp = sv_al;
 332         }
 333         else
 334 #endif
 335         rpp_replace_1_1(sv_al);
 336     } else {
 337         SV *sv = newSViv(AvFILL(MUTABLE_AV(av)));
 338         rpp_popfree_1();
 339         rpp_push_1_norc(sv);
 340     }
 341     return NORMAL;
 342 }
 343
 344 PP(pp_pos)
 345 {
 346     SV *sv = *PL_stack_sp;
 347
 348     if (PL_op->op_flags & OPf_MOD || LVRET) {
 349         SV * const ret = newSV_type_mortal(SVt_PVLV);/* Not TARG RT#67838 */
 350         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
 351         LvTYPE(ret) = '.';
 352         LvTARG(ret) = SvREFCNT_inc_simple(sv);
 353         rpp_replace_1_1(ret);    /* no SvSETMAGIC */
 354     }
 355     else {
 356             const MAGIC * const mg = mg_find_mglob(sv);
 357             if (mg && mg->mg_len != -1) {
 358                 STRLEN i = mg->mg_len;
 359                 if (PL_op->op_private & OPpTRUEBOOL)
 360                     rpp_replace_1_1(i ? &PL_sv_yes : &PL_sv_zero);
 361                 else {
 362                     dTARGET;
 363                     if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
 364                         i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
 365                     TARGu(i,1);
 366                     rpp_replace_1_1(targ);
 367                 }
 368                 return NORMAL;
 369             }
 370             rpp_replace_1_1(&PL_sv_undef);
 371     }
 372     return NORMAL;
 373 }
 374
 375 PP(pp_rv2cv)
 376 {
 377     GV *gv;
 378     HV *stash_unused;
 379     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 380         ? GV_ADDMG
 381         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
 382                                                     == OPpMAY_RETURN_CONSTANT)
 383             ? GV_ADD|GV_NOEXPAND
 384             : GV_ADD;
 385     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 386     /* (But not in defined().) */
 387
 388     CV *cv = sv_2cv(*PL_stack_sp, &stash_unused, &gv, flags);
 389     if (cv) NOOP;
 390     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 391         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
 392             ? MUTABLE_CV(SvRV(gv))
 393             : MUTABLE_CV(gv);
 394     }
 395     else
 396         cv = MUTABLE_CV(&PL_sv_undef);
 397     rpp_replace_1_1(MUTABLE_SV(cv));
 398     return NORMAL;
 399 }
 400
 401 PP(pp_prototype)
 402 {
 403     CV *cv;
 404     HV *stash;
 405     GV *gv;
 406     SV *ret = &PL_sv_undef;
 407     SV *fn = *PL_stack_sp;
 408
 409     if (SvGMAGICAL(fn))
 410         fn = sv_mortalcopy(fn);
 411
 412     if (SvPOK(fn) && SvCUR(fn) >= 7) {
 413         const char * s = SvPVX_const(fn);
 414         if (memBEGINs(s, SvCUR(fn), "CORE::")) {
 415             const int code = keyword(s + 6, SvCUR(fn) - 6, 1);
 416             if (!code)
 417                 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
 418                    UTF8fARG(SvFLAGS(fn) & SVf_UTF8, SvCUR(fn)-6, s+6));
 419             {
 420                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
 421                 if (sv) ret = sv;
 422             }
 423             goto set;
 424         }
 425     }
 426     cv = sv_2cv(fn, &stash, &gv, 0);
 427     if (cv && SvPOK(cv))
 428         ret = newSVpvn_flags(
 429             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
 430         );
 431   set:
 432     rpp_replace_1_1(ret);
 433     return NORMAL;
 434 }
 435
 436 PP(pp_anoncode)
 437 {
 438     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 439     if (CvCLONE(cv))
 440         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 441
 442     SV* sv = MUTABLE_SV(cv);
 443
 444     if (LIKELY(PL_op->op_flags & OPf_REF)) {
 445         sv = refto(sv);
 446     }
 447
 448     rpp_xpush_1(sv);
 449     return NORMAL;
 450 }
 451
 452 PP(pp_srefgen)
 453 {
 454     rpp_replace_1_1(refto(*PL_stack_sp));
 455     return NORMAL;
 456 }
 457
 458 PP_wrapped(pp_refgen, 0, 1)
 459 {
 460     dSP; dMARK;
 461     if (GIMME_V != G_LIST) {
 462         if (++MARK <= SP)
 463             *MARK = *SP;
 464         else
 465         {
 466             MEXTEND(SP, 1);
 467             *MARK = &PL_sv_undef;
 468         }
 469         *MARK = refto(*MARK);
 470         SP = MARK;
 471         RETURN;
 472     }
 473     EXTEND_MORTAL(SP - MARK);
 474     while (++MARK <= SP)
 475         *MARK = refto(*MARK);
 476     RETURN;
 477 }
 478
 479 STATIC SV*
 480 S_refto(pTHX_ SV *sv)
 481 {
 482     SV* rv;
 483
 484     PERL_ARGS_ASSERT_REFTO;
 485
 486     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 487         if (LvTARGLEN(sv))
 488             vivify_defelem(sv);
 489         if (!(sv = LvTARG(sv)))
 490             sv = &PL_sv_undef;
 491         else
 492             SvREFCNT_inc_void_NN(sv);
 493     }
 494     else if (SvTYPE(sv) == SVt_PVAV) {
 495         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 496             av_reify(MUTABLE_AV(sv));
 497         SvTEMP_off(sv);
 498         SvREFCNT_inc_void_NN(sv);
 499     }
 500     else if (SvPADTMP(sv)) {
 501         sv = newSVsv(sv);
 502     }
 503     else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem)))
 504         sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem);
 505     else {
 506         SvTEMP_off(sv);
 507         SvREFCNT_inc_void_NN(sv);
 508     }
 509     rv = newSV_type_mortal(SVt_IV);
 510     sv_setrv_noinc(rv, sv);
 511     return rv;
 512 }
 513
 514 PP(pp_ref)
 515 {
 516     SV * const sv = *PL_stack_sp;
 517
 518     SvGETMAGIC(sv);
 519     if (!SvROK(sv)) {
 520         rpp_replace_1_1(&PL_sv_no);
 521         return NORMAL;
 522     }
 523
 524     /* op is in boolean context? */
 525     if (   (PL_op->op_private & OPpTRUEBOOL)
 526         || (   (PL_op->op_private & OPpMAYBE_TRUEBOOL)
 527             && block_gimme() == G_VOID))
 528     {
 529         /* refs are always true - unless it's to an object blessed into a
 530          * class with a false name, i.e. "0". So we have to check for
 531          * that remote possibility. The following is is basically an
 532          * unrolled SvTRUE(sv_reftype(rv)) */
 533         SV * const rv = SvRV(sv);
 534         if (SvOBJECT(rv)) {
 535             HV *stash = SvSTASH(rv);
 536             HEK *hek = HvNAME_HEK(stash);
 537             if (hek) {
 538                 I32 len = HEK_LEN(hek);
 539                 /* bail out and do it the hard way? */
 540                 if (UNLIKELY(
 541                        len == HEf_SVKEY
 542                     || (len == 1 && HEK_KEY(hek)[0] == '0')
 543                 ))
 544                     goto do_sv_ref;
 545             }
 546         }
 547         rpp_replace_1_1(&PL_sv_yes);
 548         return NORMAL;
 549     }
 550
 551   do_sv_ref:
 552     {
 553         dTARGET;
 554         sv_ref(TARG, SvRV(sv), TRUE);
 555         rpp_replace_1_1(TARG);
 556         SvSETMAGIC(TARG);
 557         return NORMAL;
 558     }
 559
 560 }
 561
 562
 563 PP_wrapped(pp_bless, MAXARG, 0)
 564 {
 565     dSP;
 566     HV *stash;
 567
 568     if (MAXARG == 1)
 569     {
 570       curstash:
 571         stash = CopSTASH(PL_curcop);
 572         if (SvTYPE(stash) != SVt_PVHV)
 573             Perl_croak(aTHX_ "Attempt to bless into a freed package");
 574     }
 575     else {
 576         SV * const ssv = POPs;
 577         STRLEN len;
 578         const char *ptr;
 579
 580         if (!ssv) goto curstash;
 581         SvGETMAGIC(ssv);
 582         if (SvROK(ssv)) {
 583           if (!SvAMAGIC(ssv)) {
 584            frog:
 585             Perl_croak(aTHX_ "Attempt to bless into a reference");
 586           }
 587           /* SvAMAGIC is on here, but it only means potentially overloaded,
 588              so after stringification: */
 589           ptr = SvPV_nomg_const(ssv,len);
 590           /* We need to check the flag again: */
 591           if (!SvAMAGIC(ssv)) goto frog;
 592         }
 593         else ptr = SvPV_nomg_const(ssv,len);
 594         if (len == 0)
 595             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 596                            "Explicit blessing to '' (assuming package main)");
 597         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
 598     }
 599
 600     (void)sv_bless(TOPs, stash);
 601     RETURN;
 602 }
 603
 604 PP(pp_gelem)
 605 {
 606     SV *sv = PL_stack_sp[0];
 607     STRLEN len;
 608     const char * const elem = SvPV_const(sv, len);
 609     GV * const gv = MUTABLE_GV(PL_stack_sp[-1]);
 610     SV * tmpRef = NULL;
 611
 612     sv = NULL;
 613     if (elem) {
 614         /* elem will always be NUL terminated.  */
 615         switch (*elem) {
 616         case 'A':
 617             if (memEQs(elem, len, "ARRAY"))
 618             {
 619                 tmpRef = MUTABLE_SV(GvAV(gv));
 620                 if (tmpRef && !AvREAL((const AV *)tmpRef)
 621                  && AvREIFY((const AV *)tmpRef))
 622                     av_reify(MUTABLE_AV(tmpRef));
 623             }
 624             break;
 625         case 'C':
 626             if (memEQs(elem, len, "CODE"))
 627                 tmpRef = MUTABLE_SV(GvCVu(gv));
 628             break;
 629         case 'F':
 630             if (memEQs(elem, len, "FILEHANDLE")) {
 631                 tmpRef = MUTABLE_SV(GvIOp(gv));
 632             }
 633             else
 634                 if (memEQs(elem, len, "FORMAT"))
 635                     tmpRef = MUTABLE_SV(GvFORM(gv));
 636             break;
 637         case 'G':
 638             if (memEQs(elem, len, "GLOB"))
 639                 tmpRef = MUTABLE_SV(gv);
 640             break;
 641         case 'H':
 642             if (memEQs(elem, len, "HASH"))
 643                 tmpRef = MUTABLE_SV(GvHV(gv));
 644             break;
 645         case 'I':
 646             if (memEQs(elem, len, "IO"))
 647                 tmpRef = MUTABLE_SV(GvIOp(gv));
 648             break;
 649         case 'N':
 650             if (memEQs(elem, len, "NAME"))
 651                 sv = newSVhek(GvNAME_HEK(gv));
 652             break;
 653         case 'P':
 654             if (memEQs(elem, len, "PACKAGE")) {
 655                 const HV * const stash = GvSTASH(gv);
 656                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 657                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 658             }
 659             break;
 660         case 'S':
 661             if (memEQs(elem, len, "SCALAR"))
 662                 tmpRef = GvSVn(gv);
 663             break;
 664         }
 665     }
 666     if (tmpRef)
 667         sv = newRV(tmpRef);
 668     if (sv)
 669         sv_2mortal(sv);
 670     else
 671         sv = &PL_sv_undef;
 672     rpp_replace_2_1(sv);
 673     return NORMAL;
 674 }
 675
 676 /* Pattern matching */
 677
 678 PP(pp_study)
 679 {
 680     SV *sv = *PL_stack_sp;
 681     STRLEN len;
 682
 683     (void)SvPV(sv, len);
 684     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
 685         /* Historically, study was skipped in these cases. */
 686         rpp_replace_1_1(&PL_sv_no);
 687         return NORMAL;
 688     }
 689
 690     /* Make study a no-op. It's no longer useful and its existence
 691        complicates matters elsewhere. */
 692     rpp_replace_1_1(&PL_sv_yes);
 693     return NORMAL;
 694 }
 695
 696
 697 /* also used for: pp_transr() */
 698
 699 PP_wrapped(pp_trans, ((PL_op->op_flags & OPf_STACKED) ? 1 : 0), 0)
 700 {
 701     dSP;
 702     SV *sv;
 703
 704     if (PL_op->op_flags & OPf_STACKED)
 705         sv = POPs;
 706     else {
 707         EXTEND(SP,1);
 708         if (ARGTARG)
 709             sv = PAD_SV(ARGTARG);
 710         else {
 711             sv = DEFSV;
 712         }
 713     }
 714     if(PL_op->op_type == OP_TRANSR) {
 715         STRLEN len;
 716         const char * const pv = SvPV(sv,len);
 717         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
 718         do_trans(newsv);
 719         PUSHs(newsv);
 720     }
 721     else {
 722         Size_t i = do_trans(sv);
 723         mPUSHi((UV)i);
 724     }
 725     RETURN;
 726 }
 727
 728 /* Lvalue operators. */
 729
 730 static size_t
 731 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 732 {
 733     STRLEN len;
 734     char *s;
 735     size_t count = 0;
 736
 737     PERL_ARGS_ASSERT_DO_CHOMP;
 738
 739     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
 740         return 0;
 741     if (SvTYPE(sv) == SVt_PVAV) {
 742         I32 i;
 743         AV *const av = MUTABLE_AV(sv);
 744         const I32 max = AvFILL(av);
 745
 746         for (i = 0; i <= max; i++) {
 747             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
 748             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 749                 count += do_chomp(retval, sv, chomping);
 750         }
 751         return count;
 752     }
 753     else if (SvTYPE(sv) == SVt_PVHV) {
 754         HV* const hv = MUTABLE_HV(sv);
 755         HE* entry;
 756         (void)hv_iterinit(hv);
 757         while ((entry = hv_iternext(hv)))
 758             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
 759         return count;
 760     }
 761     else if (SvREADONLY(sv)) {
 762             Perl_croak_no_modify();
 763     }
 764
 765     s = SvPV(sv, len);
 766     if (chomping) {
 767         if (s && len) {
 768             char *temp_buffer = NULL;
 769             s += --len;
 770             if (RsPARA(PL_rs)) {
 771                 if (*s != '\n')
 772                     goto nope_free_nothing;
 773                 ++count;
 774                 while (len && s[-1] == '\n') {
 775                     --len;
 776                     --s;
 777                     ++count;
 778                 }
 779             }
 780             else {
 781                 STRLEN rslen, rs_charlen;
 782                 const char *rsptr = SvPV_const(PL_rs, rslen);
 783
 784                 rs_charlen = SvUTF8(PL_rs)
 785                     ? sv_len_utf8(PL_rs)
 786                     : rslen;
 787
 788                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
 789                     /* Assumption is that rs is shorter than the scalar.  */
 790                     if (SvUTF8(PL_rs)) {
 791                         /* RS is utf8, scalar is 8 bit.  */
 792                         bool is_utf8 = TRUE;
 793                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
 794                                                              &rslen, &is_utf8);
 795                         if (is_utf8) {
 796                             /* Cannot downgrade, therefore cannot possibly match.
 797                                At this point, temp_buffer is not alloced, and
 798                                is the buffer inside PL_rs, so don't free it.
 799                              */
 800                             assert (temp_buffer == rsptr);
 801                             goto nope_free_nothing;
 802                         }
 803                         rsptr = temp_buffer;
 804                     }
 805                     else {
 806                         /* RS is 8 bit, scalar is utf8.  */
 807                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
 808                         rsptr = temp_buffer;
 809                     }
 810                 }
 811                 if (rslen == 1) {
 812                     if (*s != *rsptr)
 813                         goto nope_free_all;
 814                     ++count;
 815                 }
 816                 else {
 817                     if (len < rslen - 1)
 818                         goto nope_free_all;
 819                     len -= rslen - 1;
 820                     s -= rslen - 1;
 821                     if (memNE(s, rsptr, rslen))
 822                         goto nope_free_all;
 823                     count += rs_charlen;
 824                 }
 825             }
 826             SvPV_force_nomg_nolen(sv);
 827             SvCUR_set(sv, len);
 828             *SvEND(sv) = '\0';
 829             SvNIOK_off(sv);
 830             SvSETMAGIC(sv);
 831
 832             nope_free_all:
 833             Safefree(temp_buffer);
 834             nope_free_nothing: ;
 835         }
 836     } else {
 837         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
 838             s = SvPV_force_nomg(sv, len);
 839         if (DO_UTF8(sv)) {
 840             if (s && len) {
 841                 char * const send = s + len;
 842                 char * const start = s;
 843                 s = (char *) utf8_hop_back((U8 *) send, -1, (U8 *) start);
 844                 if (is_utf8_string((U8*)s, send - s)) {
 845                     sv_setpvn(retval, s, send - s);
 846                     *s = '\0';
 847                     SvCUR_set(sv, s - start);
 848                     SvNIOK_off(sv);
 849                     SvUTF8_on(retval);
 850                 }
 851             }
 852             else
 853                 SvPVCLEAR(retval);
 854         }
 855         else if (s && len) {
 856             s += --len;
 857             sv_setpvn(retval, s, 1);
 858             *s = '\0';
 859             SvCUR_set(sv, len);
 860             SvUTF8_off(sv);
 861             SvNIOK_off(sv);
 862         }
 863         else
 864             SvPVCLEAR(retval);
 865         SvSETMAGIC(sv);
 866     }
 867     return count;
 868 }
 869
 870
 871 /* also used for: pp_schomp() */
 872
 873 PP(pp_schop)
 874 {
 875     dTARGET;
 876     const bool chomping = PL_op->op_type == OP_SCHOMP;
 877
 878     const size_t count = do_chomp(TARG, *PL_stack_sp, chomping);
 879     if (chomping)
 880         sv_setiv(TARG, count);
 881     SvSETMAGIC(TARG);
 882     rpp_replace_1_1(TARG);
 883     return NORMAL;
 884 }
 885
 886
 887 /* also used for: pp_chomp() */
 888
 889 PP_wrapped(pp_chop, 0, 1)
 890 {
 891     dSP; dMARK; dTARGET; dORIGMARK;
 892     const bool chomping = PL_op->op_type == OP_CHOMP;
 893     size_t count = 0;
 894
 895     while (MARK < SP)
 896         count += do_chomp(TARG, *++MARK, chomping);
 897     if (chomping)
 898         sv_setiv(TARG, count);
 899     SP = ORIGMARK;
 900     XPUSHTARG;
 901     RETURN;
 902 }
 903
 904 PP_wrapped(pp_undef,
 905     ((!PL_op->op_private || (PL_op->op_private & OPpTARGET_MY)) ? 0 : 1),
 906     0)
 907 {
 908     dSP;
 909     SV *sv;
 910
 911     if (!PL_op->op_private) {
 912         EXTEND(SP, 1);
 913         RETPUSHUNDEF;
 914     }
 915
 916     if (PL_op->op_private & OPpTARGET_MY) {
 917         SV** const padentry = &PAD_SVl(PL_op->op_targ);
 918         sv = *padentry;
 919         EXTEND(SP,1);sp++;PUTBACK;
 920         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
 921             save_clearsv(padentry);
 922         }
 923     } else {
 924         sv = TOPs;
 925
 926         if (!sv)
 927         {
 928             SETs(&PL_sv_undef);
 929             return NORMAL;
 930         }
 931     }
 932
 933     if (SvTHINKFIRST(sv))
 934         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
 935
 936     switch (SvTYPE(sv)) {
 937     case SVt_NULL:
 938         break;
 939     case SVt_PVAV:
 940         av_undef(MUTABLE_AV(sv));
 941         break;
 942     case SVt_PVHV:
 943         hv_undef(MUTABLE_HV(sv));
 944         break;
 945     case SVt_PVCV:
 946         if (cv_const_sv((const CV *)sv))
 947             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 948                           "Constant subroutine %" SVf " undefined",
 949                            SVfARG(CvANON((const CV *)sv)
 950                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
 951                              : newSVhek_mortal(
 952                                 CvNAMED(sv)
 953                                  ? CvNAME_HEK((CV *)sv)
 954                                  : GvENAME_HEK(CvGV((const CV *)sv))
 955                                )
 956                            ));
 957         /* FALLTHROUGH */
 958     case SVt_PVFM:
 959             /* let user-undef'd sub keep its identity */
 960         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
 961         break;
 962     case SVt_PVGV:
 963         assert(isGV_with_GP(sv));
 964         assert(!SvFAKE(sv));
 965         {
 966             GP *gp;
 967             HV *stash;
 968
 969             /* undef *Pkg::meth_name ... */
 970             bool method_changed
 971              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
 972               && HvHasENAME(stash);
 973             /* undef *Foo:: */
 974             if((stash = GvHV((const GV *)sv))) {
 975                 if(HvENAME_get(stash))
 976                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
 977                 else stash = NULL;
 978             }
 979
 980             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
 981             gp_free(MUTABLE_GV(sv));
 982             Newxz(gp, 1, GP);
 983             GvGP_set(sv, gp_ref(gp));
 984 #ifndef PERL_DONT_CREATE_GVSV
 985             GvSV(sv) = newSV_type(SVt_NULL);
 986 #endif
 987             GvLINE(sv) = CopLINE(PL_curcop);
 988             GvEGV(sv) = MUTABLE_GV(sv);
 989             GvMULTI_on(sv);
 990
 991             if(stash)
 992                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
 993             stash = NULL;
 994             /* undef *Foo::ISA */
 995             if( strEQ(GvNAME((const GV *)sv), "ISA")
 996              && (stash = GvSTASH((const GV *)sv))
 997              && (method_changed || HvHasENAME(stash)) )
 998                 mro_isa_changed_in(stash);
 999             else if(method_changed)
1000                 mro_method_changed_in(
1001                  GvSTASH((const GV *)sv)
1002                 );
1003
1004             break;
1005         }
1006     default:
1007         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)
1008             && !(PL_op->op_private & OPpUNDEF_KEEP_PV)
1009         ) {
1010             SvPV_free(sv);
1011             SvPV_set(sv, NULL);
1012             SvLEN_set(sv, 0);
1013         }
1014         SvOK_off(sv);
1015         SvSETMAGIC(sv);
1016     }
1017
1018
1019     if (PL_op->op_private & OPpTARGET_MY)
1020         SETs(sv);
1021     else
1022         SETs(&PL_sv_undef);
1023     return NORMAL;
1024 }
1025
1026
1027 /* common "slow" code for pp_postinc and pp_postdec */
1028
1029 static OP *
1030 S_postincdec_common(pTHX_ SV *sv, SV *targ)
1031 {
1032     const bool inc =
1033         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1034
1035     if (SvROK(sv))
1036         TARG = sv_newmortal();
1037     sv_setsv(TARG, sv);
1038     if (inc)
1039         sv_inc_nomg(sv);
1040     else
1041         sv_dec_nomg(sv);
1042     SvSETMAGIC(sv);
1043     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1044     if (inc && !SvOK(TARG))
1045         sv_setiv(TARG, 0);
1046     SvSETMAGIC(TARG);
1047     rpp_replace_1_1(TARG);
1048     return NORMAL;
1049 }
1050
1051
1052 /* also used for: pp_i_postinc() */
1053
1054 PP(pp_postinc)
1055 {
1056     dTARGET;
1057     SV *sv = *PL_stack_sp;
1058
1059     /* special-case sv being a simple integer */
1060     if (LIKELY(((sv->sv_flags &
1061                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1062                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1063                 == SVf_IOK))
1064         && SvIVX(sv) != IV_MAX)
1065     {
1066         IV iv = SvIVX(sv);
1067         SvIV_set(sv,  iv + 1);
1068         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1069         rpp_replace_1_1(TARG);
1070         return NORMAL;
1071     }
1072
1073     return S_postincdec_common(aTHX_ sv, TARG);
1074 }
1075
1076
1077 /* also used for: pp_i_postdec() */
1078
1079 PP(pp_postdec)
1080 {
1081     dTARGET;
1082     SV *sv = *PL_stack_sp;
1083
1084     /* special-case sv being a simple integer */
1085     if (LIKELY(((sv->sv_flags &
1086                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1087                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1088                 == SVf_IOK))
1089         && SvIVX(sv) != IV_MIN)
1090     {
1091         IV iv = SvIVX(sv);
1092         SvIV_set(sv,  iv - 1);
1093         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1094         rpp_replace_1_1(TARG);
1095         return NORMAL;
1096     }
1097
1098     return S_postincdec_common(aTHX_ sv, TARG);
1099 }
1100
1101
1102 /* Ordinary operators. */
1103
1104 PP(pp_pow)
1105 {
1106     SV *targ = (PL_op->op_flags & OPf_STACKED)
1107                     ? PL_stack_sp[-1]
1108                     : PAD_SV(PL_op->op_targ);
1109
1110     if (rpp_try_AMAGIC_2(pow_amg, AMGf_assign|AMGf_numeric))
1111         return NORMAL;
1112
1113     SV *svr = PL_stack_sp[0];
1114     SV *svl = PL_stack_sp[-1];
1115
1116 #ifdef PERL_PRESERVE_IVUV
1117     bool is_int = 0;
1118     /* For integer to integer power, we do the calculation by hand wherever
1119        we're sure it is safe; otherwise we call pow() and try to convert to
1120        integer afterwards. */
1121     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1122                 UV power;
1123                 bool baseuok;
1124                 UV baseuv;
1125
1126                 if (SvUOK(svr)) {
1127                     power = SvUVX(svr);
1128                 } else {
1129                     const IV iv = SvIVX(svr);
1130                     if (iv >= 0) {
1131                         power = iv;
1132                     } else {
1133                         goto float_it; /* Can't do negative powers this way.  */
1134                     }
1135                 }
1136
1137                 baseuok = SvUOK(svl);
1138                 if (baseuok) {
1139                     baseuv = SvUVX(svl);
1140                 } else {
1141                     const IV iv = SvIVX(svl);
1142                     if (iv >= 0) {
1143                         baseuv = iv;
1144                         baseuok = TRUE; /* effectively it's a UV now */
1145                     } else {
1146                         baseuv = -iv; /* abs, baseuok == false records sign */
1147                     }
1148                 }
1149                 /* now we have integer ** positive integer. */
1150                 is_int = 1;
1151
1152                 /* foo & (foo - 1) is zero only for a power of 2.  */
1153                 if (!(baseuv & (baseuv - 1))) {
1154                     /* We are raising power-of-2 to a positive integer.
1155                        The logic here will work for any base (even non-integer
1156                        bases) but it can be less accurate than
1157                        pow (base,power) or exp (power * log (base)) when the
1158                        intermediate values start to spill out of the mantissa.
1159                        With powers of 2 we know this can't happen.
1160                        And powers of 2 are the favourite thing for perl
1161                        programmers to notice ** not doing what they mean. */
1162                     NV result = 1.0;
1163                     NV base = baseuok ? baseuv : -(NV)baseuv;
1164
1165                     if (power & 1) {
1166                         result *= base;
1167                     }
1168                     while (power >>= 1) {
1169                         base *= base;
1170                         if (power & 1) {
1171                             result *= base;
1172                         }
1173                     }
1174                     TARGn(result, 1);
1175                     SvIV_please_nomg(svr);
1176                     goto ret;
1177                 } else {
1178                     unsigned int highbit = 8 * sizeof(UV);
1179                     unsigned int diff = 8 * sizeof(UV);
1180                     while (diff >>= 1) {
1181                         highbit -= diff;
1182                         if (baseuv >> highbit) {
1183                             highbit += diff;
1184                         }
1185                     }
1186                     /* we now have baseuv < 2 ** highbit */
1187                     if (power * highbit <= 8 * sizeof(UV)) {
1188                         /* result will definitely fit in UV, so use UV math
1189                            on same algorithm as above */
1190                         UV result = 1;
1191                         UV base = baseuv;
1192                         const bool odd_power = cBOOL(power & 1);
1193                         if (odd_power) {
1194                             result *= base;
1195                         }
1196                         while (power >>= 1) {
1197                             base *= base;
1198                             if (power & 1) {
1199                                 result *= base;
1200                             }
1201                         }
1202                         if (baseuok || !odd_power)
1203                             /* answer is positive */
1204                             TARGu(result, 1);
1205                         else if (result <= (UV)IV_MAX)
1206                             /* answer negative, fits in IV */
1207                             TARGi(-(IV)result, 1);
1208                         else if (result == (UV)IV_MIN)
1209                             /* 2's complement assumption: special case IV_MIN */
1210                             TARGi(IV_MIN, 1);
1211                         else
1212                             /* answer negative, doesn't fit */
1213                             TARGn(-(NV)result, 1);
1214                         goto ret;
1215                     }
1216                 }
1217     }
1218   float_it:
1219 #endif
1220     {
1221         NV right = SvNV_nomg(svr);
1222         NV left  = SvNV_nomg(svl);
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                 TARGn(-Perl_pow(-left, right), 1);
1252             } else if (mod2 == 0.0) {           /* even integer */
1253                 TARGn(Perl_pow(-left, right), 1);
1254             } else {                            /* fractional power */
1255                 TARGn(NV_NAN, 1);
1256             }
1257         } else {
1258             TARGn(Perl_pow(left, right), 1);
1259         }
1260 #elif IVSIZE == 4 && defined(LONGDOUBLE_DOUBLEDOUBLE) && defined(USE_LONG_DOUBLE)
1261     /*
1262     Under these conditions, if a known libm bug exists, Perl_pow() could return
1263     an incorrect value if the correct value is an integer in the range of around
1264     25 or more bits. The error is always quite small, so we work around it by
1265     rounding to the nearest integer value ... but only if is_int is true.
1266     See https://github.com/Perl/perl5/issues/19625.
1267     */
1268
1269         if (is_int) {
1270             TARGn(roundl(Perl_pow(left, right)), 1);
1271         }
1272         else
1273             TARGn(Perl_pow(left, right), 1 );
1274
1275 #else
1276         TARGn(Perl_pow(left, right), 1);
1277 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1278
1279 #ifdef PERL_PRESERVE_IVUV
1280         if (is_int)
1281             SvIV_please_nomg(svr);
1282 #endif
1283     }
1284
1285   ret:
1286     rpp_replace_2_1(targ);
1287     return NORMAL;
1288 }
1289
1290
1291 PP(pp_multiply)
1292 {
1293     SV *targ = (PL_op->op_flags & OPf_STACKED)
1294                     ? PL_stack_sp[-1]
1295                     : PAD_SV(PL_op->op_targ);
1296
1297     if (rpp_try_AMAGIC_2(mult_amg, AMGf_assign|AMGf_numeric))
1298         return NORMAL;
1299
1300     SV *svr = PL_stack_sp[0];
1301     SV *svl = PL_stack_sp[-1];
1302
1303 #ifdef PERL_PRESERVE_IVUV
1304
1305     /* special-case some simple common cases */
1306     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1307         IV il, ir;
1308         U32 flags = (svl->sv_flags & svr->sv_flags);
1309         if (flags & SVf_IOK) {
1310             /* both args are simple IVs */
1311             UV topl, topr;
1312             il = SvIVX(svl);
1313             ir = SvIVX(svr);
1314           do_iv:
1315             topl = ((UV)il) >> (UVSIZE * 4 - 1);
1316             topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1317
1318             /* if both are in a range that can't under/overflow, do a
1319              * simple integer multiply: if the top halves(*) of both numbers
1320              * are 00...00  or 11...11, then it's safe.
1321              * (*) for 32-bits, the "top half" is the top 17 bits,
1322              *     for 64-bits, its 33 bits */
1323             if (!(
1324                       ((topl+1) | (topr+1))
1325                     & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1326             )) {
1327                 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1328                 goto ret;
1329             }
1330             goto generic;
1331         }
1332         else if (flags & SVf_NOK) {
1333             /* both args are NVs */
1334             NV nl = SvNVX(svl);
1335             NV nr = SvNVX(svr);
1336             NV result;
1337
1338             if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1339                 /* nothing was lost by converting to IVs */
1340                 goto do_iv;
1341             }
1342             result = nl * nr;
1343 #  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1344             if (Perl_isinf(result)) {
1345                 Zero((U8*)&result + 8, 8, U8);
1346             }
1347 #  endif
1348             TARGn(result, 0); /* args not GMG, so can't be tainted */
1349             goto ret;
1350         }
1351     }
1352
1353   generic:
1354
1355     if (SvIV_please_nomg(svr)) {
1356         /* Unless the left argument is integer in range we are going to have to
1357            use NV maths. Hence only attempt to coerce the right argument if
1358            we know the left is integer.  */
1359         /* Left operand is defined, so is it IV? */
1360         if (SvIV_please_nomg(svl)) {
1361             bool auvok = SvUOK(svl);
1362             bool buvok = SvUOK(svr);
1363             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1364             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1365             UV alow;
1366             UV ahigh;
1367             UV blow;
1368             UV bhigh;
1369
1370             if (auvok) {
1371                 alow = SvUVX(svl);
1372             } else {
1373                 const IV aiv = SvIVX(svl);
1374                 if (aiv >= 0) {
1375                     alow = aiv;
1376                     auvok = TRUE; /* effectively it's a UV now */
1377                 } else {
1378                     /* abs, auvok == false records sign; Using 0- here and
1379                      * later to silence bogus warning from MS VC */
1380                     alow = (UV) (0 - (UV) aiv);
1381                 }
1382             }
1383             if (buvok) {
1384                 blow = SvUVX(svr);
1385             } else {
1386                 const IV biv = SvIVX(svr);
1387                 if (biv >= 0) {
1388                     blow = biv;
1389                     buvok = TRUE; /* effectively it's a UV now */
1390                 } else {
1391                     /* abs, buvok == false records sign */
1392                     blow = (UV) (0 - (UV) biv);
1393                 }
1394             }
1395
1396             /* If this does sign extension on unsigned it's time for plan B  */
1397             ahigh = alow >> (4 * sizeof (UV));
1398             alow &= botmask;
1399             bhigh = blow >> (4 * sizeof (UV));
1400             blow &= botmask;
1401             if (ahigh && bhigh) {
1402                 NOOP;
1403                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1404                    which is overflow. Drop to NVs below.  */
1405             } else if (!ahigh && !bhigh) {
1406                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1407                    so the unsigned multiply cannot overflow.  */
1408                 const UV product = alow * blow;
1409                 if (auvok == buvok) {
1410                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1411                     TARGu(product, 1);
1412                     goto ret;
1413                 } else if (product <= (UV)IV_MIN) {
1414                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1415                     /* -ve result, which could overflow an IV  */
1416                     /* can't negate IV_MIN, but there are aren't two
1417                      * integers such that !ahigh && !bhigh, where the
1418                      * product equals 0x800....000 */
1419                     assert(product != (UV)IV_MIN);
1420                     TARGi(-(IV)product, 1);
1421                     goto ret;
1422                 } /* else drop to NVs below. */
1423             } else {
1424                 /* One operand is large, 1 small */
1425                 UV product_middle;
1426                 if (bhigh) {
1427                     /* swap the operands */
1428                     ahigh = bhigh;
1429                     bhigh = blow; /* bhigh now the temp var for the swap */
1430                     blow = alow;
1431                     alow = bhigh;
1432                 }
1433                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1434                    multiplies can't overflow. shift can, add can, -ve can.  */
1435                 product_middle = ahigh * blow;
1436                 if (!(product_middle & topmask)) {
1437                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1438                     UV product_low;
1439                     product_middle <<= (4 * sizeof (UV));
1440                     product_low = alow * blow;
1441
1442                     /* as for pp_add, UV + something mustn't get smaller.
1443                        IIRC ANSI mandates this wrapping *behaviour* for
1444                        unsigned whatever the actual representation*/
1445                     product_low += product_middle;
1446                     if (product_low >= product_middle) {
1447                         /* didn't overflow */
1448                         if (auvok == buvok) {
1449                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1450                             TARGu(product_low, 1);
1451                             goto ret;
1452                         } else if (product_low <= (UV)IV_MIN) {
1453                             /* 2s complement assumption again  */
1454                             /* -ve result, which could overflow an IV  */
1455                             TARGi(product_low == (UV)IV_MIN
1456                                     ? IV_MIN : -(IV)product_low,
1457                                   1);
1458                             goto ret;
1459                         } /* else drop to NVs below. */
1460                     }
1461                 } /* product_middle too large */
1462             } /* ahigh && bhigh */
1463         } /* SvIOK(svl) */
1464     } /* SvIOK(svr) */
1465 #endif
1466     {
1467       NV right = SvNV_nomg(svr);
1468       NV left  = SvNV_nomg(svl);
1469       NV result = left * right;
1470
1471 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1472       if (Perl_isinf(result)) {
1473           Zero((U8*)&result + 8, 8, U8);
1474       }
1475 #endif
1476       TARGn(result, 1);
1477       goto ret;
1478     }
1479
1480   ret:
1481     rpp_replace_2_1(targ);
1482     return NORMAL;
1483 }
1484
1485
1486 PP(pp_divide)
1487 {
1488     SV *targ = (PL_op->op_flags & OPf_STACKED)
1489                     ? PL_stack_sp[-1]
1490                     : PAD_SV(PL_op->op_targ);
1491
1492     if (rpp_try_AMAGIC_2(div_amg, AMGf_assign|AMGf_numeric))
1493         return NORMAL;
1494
1495     SV *svr = PL_stack_sp[0];
1496     SV *svl = PL_stack_sp[-1];
1497
1498     /* Only try to do UV divide first
1499        if ((SLOPPYDIVIDE is true) or
1500            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1501             to preserve))
1502        The assumption is that it is better to use floating point divide
1503        whenever possible, only doing integer divide first if we can't be sure.
1504        If NV_PRESERVES_UV is true then we know at compile time that no UV
1505        can be too large to preserve, so don't need to compile the code to
1506        test the size of UVs.  */
1507
1508 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
1509 #  define PERL_TRY_UV_DIVIDE
1510     /* ensure that 20./5. == 4. */
1511 #endif
1512
1513 #ifdef PERL_TRY_UV_DIVIDE
1514     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1515             bool left_non_neg = SvUOK(svl);
1516             bool right_non_neg = SvUOK(svr);
1517             UV left;
1518             UV right;
1519
1520             if (right_non_neg) {
1521                 right = SvUVX(svr);
1522             }
1523             else {
1524                 const IV biv = SvIVX(svr);
1525                 if (biv >= 0) {
1526                     right = biv;
1527                     right_non_neg = TRUE; /* effectively it's a UV now */
1528                 }
1529                 else {
1530                     right = -(UV)biv;
1531                 }
1532             }
1533             /* historically undef()/0 gives a "Use of uninitialized value"
1534                warning before dieing, hence this test goes here.
1535                If it were immediately before the second SvIV_please, then
1536                DIE() would be invoked before left was even inspected, so
1537                no inspection would give no warning.  */
1538             if (right == 0)
1539                 DIE(aTHX_ "Illegal division by zero");
1540
1541             if (left_non_neg) {
1542                 left = SvUVX(svl);
1543             }
1544             else {
1545                 const IV aiv = SvIVX(svl);
1546                 if (aiv >= 0) {
1547                     left = aiv;
1548                     left_non_neg = TRUE; /* effectively it's a UV now */
1549                 }
1550                 else {
1551                     left = -(UV)aiv;
1552                 }
1553             }
1554
1555             if (left >= right
1556 #ifdef SLOPPYDIVIDE
1557                 /* For sloppy divide we always attempt integer division.  */
1558 #else
1559                 /* Otherwise we only attempt it if either or both operands
1560                    would not be preserved by an NV.  If both fit in NVs
1561                    we fall through to the NV divide code below.  However,
1562                    as left >= right to ensure integer result here, we know that
1563                    we can skip the test on the right operand - right big
1564                    enough not to be preserved can't get here unless left is
1565                    also too big.  */
1566
1567                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1568 #endif
1569                 ) {
1570                 /* Integer division can't overflow, but it can be imprecise.  */
1571
1572                 /* Modern compilers optimize division followed by
1573                  * modulo into a single div instruction */
1574                 const UV result = left / right;
1575                 if (left % right == 0) {
1576                     /* result is valid */
1577                     if (left_non_neg == right_non_neg) {
1578                         /* signs identical, result is positive.  */
1579                         TARGu(result, 1);
1580                         goto ret;
1581                     }
1582                     /* 2s complement assumption */
1583                     if (result <= (UV)IV_MIN)
1584                         TARGi(result == (UV)IV_MIN ? IV_MIN : -(IV)result,
1585                               1);
1586                     else {
1587                         /* It's exact but too negative for IV. */
1588                         TARGn(-(NV)result, 1);
1589                     }
1590                     goto ret;
1591                 } /* tried integer divide but it was not an integer result */
1592             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1593     } /* one operand wasn't SvIOK */
1594 #endif /* PERL_TRY_UV_DIVIDE */
1595     {
1596         NV right = SvNV_nomg(svr);
1597         NV left  = SvNV_nomg(svl);
1598 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1599         if (! Perl_isnan(right) && right == 0.0)
1600 #else
1601         if (right == 0.0)
1602 #endif
1603             DIE(aTHX_ "Illegal division by zero");
1604         TARGn(left / right, 1);
1605     }
1606
1607   ret:
1608     rpp_replace_2_1(targ);
1609     return NORMAL;
1610 }
1611
1612
1613 PP(pp_modulo)
1614 {
1615     SV *targ = (PL_op->op_flags & OPf_STACKED)
1616                     ? PL_stack_sp[-1]
1617                     : PAD_SV(PL_op->op_targ);
1618
1619     if (rpp_try_AMAGIC_2(modulo_amg, AMGf_assign|AMGf_numeric))
1620         return NORMAL;
1621
1622     {
1623         UV left  = 0;
1624         UV right = 0;
1625         bool left_neg = FALSE;
1626         bool right_neg = FALSE;
1627         bool use_double = FALSE;
1628         bool dright_valid = FALSE;
1629         NV dright = 0.0;
1630         NV dleft  = 0.0;
1631         SV * const svr = PL_stack_sp[0];
1632         SV * const svl = PL_stack_sp[-1];
1633         if (SvIV_please_nomg(svr)) {
1634             right_neg = !SvUOK(svr);
1635             if (!right_neg) {
1636                 right = SvUVX(svr);
1637             } else {
1638                 const IV biv = SvIVX(svr);
1639                 if (biv >= 0) {
1640                     right = biv;
1641                     right_neg = FALSE; /* effectively it's a UV now */
1642                 } else {
1643                     right = (UV) (0 - (UV) biv);
1644                 }
1645             }
1646         }
1647         else {
1648             dright = SvNV_nomg(svr);
1649             right_neg = dright < 0;
1650             if (right_neg)
1651                 dright = -dright;
1652             if (dright < UV_MAX_P1) {
1653                 right = U_V(dright);
1654                 dright_valid = TRUE; /* In case we need to use double below.  */
1655             } else {
1656                 use_double = TRUE;
1657             }
1658         }
1659
1660         /* At this point use_double is only true if right is out of range for
1661            a UV.  In range NV has been rounded down to nearest UV and
1662            use_double false.  */
1663         if (!use_double && SvIV_please_nomg(svl)) {
1664                 left_neg = !SvUOK(svl);
1665                 if (!left_neg) {
1666                     left = SvUVX(svl);
1667                 } else {
1668                     const IV aiv = SvIVX(svl);
1669                     if (aiv >= 0) {
1670                         left = aiv;
1671                         left_neg = FALSE; /* effectively it's a UV now */
1672                     } else {
1673                         left = (UV) (0 - (UV) aiv);
1674                     }
1675                 }
1676         }
1677         else {
1678             dleft = SvNV_nomg(svl);
1679             left_neg = dleft < 0;
1680             if (left_neg)
1681                 dleft = -dleft;
1682
1683             /* This should be exactly the 5.6 behaviour - if left and right are
1684                both in range for UV then use U_V() rather than floor.  */
1685             if (!use_double) {
1686                 if (dleft < UV_MAX_P1) {
1687                     /* right was in range, so is dleft, so use UVs not double.
1688                      */
1689                     left = U_V(dleft);
1690                 }
1691                 /* left is out of range for UV, right was in range, so promote
1692                    right (back) to double.  */
1693                 else {
1694                     /* The +0.5 is used in 5.6 even though it is not strictly
1695                        consistent with the implicit +0 floor in the U_V()
1696                        inside the #if 1. */
1697                     dleft = Perl_floor(dleft + 0.5);
1698                     use_double = TRUE;
1699                     if (dright_valid)
1700                         dright = Perl_floor(dright + 0.5);
1701                     else
1702                         dright = right;
1703                 }
1704             }
1705         }
1706
1707         if (use_double) {
1708             NV dans;
1709
1710             if (!dright)
1711                 DIE(aTHX_ "Illegal modulus zero");
1712
1713             dans = Perl_fmod(dleft, dright);
1714             if ((left_neg != right_neg) && dans)
1715                 dans = dright - dans;
1716             if (right_neg)
1717                 dans = -dans;
1718             sv_setnv(TARG, dans);
1719         }
1720         else {
1721             UV ans;
1722
1723             if (!right)
1724                 DIE(aTHX_ "Illegal modulus zero");
1725
1726             ans = left % right;
1727             if ((left_neg != right_neg) && ans)
1728                 ans = right - ans;
1729             if (right_neg) {
1730                 /* XXX may warn: unary minus operator applied to unsigned type */
1731                 /* could change -foo to be (~foo)+1 instead     */
1732                 if (ans <= ~((UV)IV_MAX)+1)
1733                     sv_setiv(TARG, ~ans+1);
1734                 else
1735                     sv_setnv(TARG, -(NV)ans);
1736             }
1737             else
1738                 sv_setuv(TARG, ans);
1739         }
1740
1741         SvSETMAGIC(TARG);
1742         rpp_replace_2_1(targ);
1743         return NORMAL;
1744     }
1745 }
1746
1747
1748 PP_wrapped(pp_repeat,
1749     /* two scalar args or one list */
1750     ((PL_op->op_private & OPpREPEAT_DOLIST) ? 0 : 2),
1751     ((PL_op->op_private & OPpREPEAT_DOLIST) ? 1 : 0))
1752 {
1753     dSP; dATARGET;
1754     IV count;
1755     SV *sv;
1756     bool infnan = FALSE;
1757     const U8 gimme = GIMME_V;
1758
1759     if (gimme == G_LIST && PL_op->op_private & OPpREPEAT_DOLIST) {
1760         /* TODO: think of some way of doing list-repeat overloading ??? */
1761         sv = POPs;
1762         SvGETMAGIC(sv);
1763     }
1764     else {
1765         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1766             /* The parser saw this as a list repeat, and there
1767                are probably several items on the stack. But we're
1768                in scalar/void context, and there's no pp_list to save us
1769                now. So drop the rest of the items -- robin@kitsite.com
1770              */
1771             dMARK;
1772             if (MARK + 1 < SP) {
1773                 MARK[1] = TOPm1s;
1774                 MARK[2] = TOPs;
1775             }
1776             else {
1777                 dTOPss;
1778                 ASSUME(MARK + 1 == SP);
1779                 MEXTEND(SP, 1);
1780                 PUSHs(sv);
1781                 MARK[1] = &PL_sv_undef;
1782             }
1783             SP = MARK + 2;
1784         }
1785         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1786         sv = POPs;
1787     }
1788
1789     if (SvIOKp(sv)) {
1790          if (SvUOK(sv)) {
1791               const UV uv = SvUV_nomg(sv);
1792               if (uv > IV_MAX)
1793                    count = IV_MAX; /* The best we can do? */
1794               else
1795                    count = uv;
1796          } else {
1797               count = SvIV_nomg(sv);
1798          }
1799     }
1800     else if (SvNOKp(sv)) {
1801         const NV nv = SvNV_nomg(sv);
1802         infnan = Perl_isinfnan(nv);
1803         if (UNLIKELY(infnan)) {
1804             count = 0;
1805         } else {
1806             if (nv < 0.0)
1807                 count = -1;   /* An arbitrary negative integer */
1808             else
1809                 count = (IV)nv;
1810         }
1811     }
1812     else
1813         count = SvIV_nomg(sv);
1814
1815     if (infnan) {
1816         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1817                        "Non-finite repeat count does nothing");
1818     } else if (count < 0) {
1819         count = 0;
1820         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1821                        "Negative repeat count does nothing");
1822     }
1823
1824     if (gimme == G_LIST && PL_op->op_private & OPpREPEAT_DOLIST) {
1825         dMARK;
1826         const SSize_t items = SP - MARK;
1827         const U8 mod = PL_op->op_flags & OPf_MOD;
1828
1829         if (count > 1) {
1830             SSize_t max;
1831
1832             if (  items > SSize_t_MAX / count   /* max would overflow */
1833                                                 /* repeatcpy would overflow */
1834                || items > I32_MAX / (I32)sizeof(SV *)
1835             )
1836                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1837             max = items * count;
1838             MEXTEND(MARK, max);
1839
1840             while (SP > MARK) {
1841                 if (*SP) {
1842                    if (mod && SvPADTMP(*SP)) {
1843                        *SP = sv_mortalcopy(*SP);
1844                    }
1845                    SvTEMP_off((*SP));
1846                 }
1847                 SP--;
1848             }
1849             MARK++;
1850             repeatcpy((char*)(MARK + items), (char*)MARK,
1851                 items * sizeof(const SV *), count - 1);
1852             SP += max;
1853         }
1854         else if (count <= 0)
1855             SP = MARK;
1856     }
1857     else {      /* Note: mark already snarfed by pp_list */
1858         SV * const tmpstr = POPs;
1859         STRLEN len;
1860         bool isutf;
1861
1862         if (TARG != tmpstr)
1863             sv_setsv_nomg(TARG, tmpstr);
1864         SvPV_force_nomg(TARG, len);
1865         isutf = DO_UTF8(TARG);
1866         if (count != 1) {
1867             if (count < 1)
1868                 SvCUR_set(TARG, 0);
1869             else {
1870                 STRLEN max;
1871
1872                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1873                 )
1874                      Perl_croak(aTHX_ "%s",
1875                                         "Out of memory during string extend");
1876                 max = (UV)count * len + 1;
1877                 SvGROW(TARG, max);
1878
1879                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1880                 SvCUR_set(TARG, SvCUR(TARG) * count);
1881             }
1882             *SvEND(TARG) = '\0';
1883         }
1884         if (isutf)
1885             (void)SvPOK_only_UTF8(TARG);
1886         else
1887             (void)SvPOK_only(TARG);
1888
1889         PUSHTARG;
1890     }
1891     RETURN;
1892 }
1893
1894
1895 PP(pp_subtract)
1896 {
1897     bool useleft;
1898     SV *targ = (PL_op->op_flags & OPf_STACKED)
1899                     ? PL_stack_sp[-1]
1900                     : PAD_SV(PL_op->op_targ);
1901
1902     if (rpp_try_AMAGIC_2(subtr_amg, AMGf_assign|AMGf_numeric))
1903         return NORMAL;
1904
1905     SV *svr = PL_stack_sp[0];
1906     SV *svl = PL_stack_sp[-1];
1907
1908
1909 #ifdef PERL_PRESERVE_IVUV
1910
1911     /* special-case some simple common cases */
1912     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1913         IV il, ir;
1914         U32 flags = (svl->sv_flags & svr->sv_flags);
1915         if (flags & SVf_IOK) {
1916             /* both args are simple IVs */
1917             UV topl, topr;
1918             il = SvIVX(svl);
1919             ir = SvIVX(svr);
1920           do_iv:
1921             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1922             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1923
1924             /* if both are in a range that can't under/overflow, do a
1925              * simple integer subtract: if the top of both numbers
1926              * are 00  or 11, then it's safe */
1927             if (!( ((topl+1) | (topr+1)) & 2)) {
1928                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1929                 goto ret;
1930             }
1931             goto generic;
1932         }
1933         else if (flags & SVf_NOK) {
1934             /* both args are NVs */
1935             NV nl = SvNVX(svl);
1936             NV nr = SvNVX(svr);
1937
1938             if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1939                 /* nothing was lost by converting to IVs */
1940                 goto do_iv;
1941             }
1942             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1943             goto ret;
1944         }
1945     }
1946
1947   generic:
1948
1949     useleft = USE_LEFT(svl);
1950     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1951        "bad things" happen if you rely on signed integers wrapping.  */
1952     if (SvIV_please_nomg(svr)) {
1953         /* Unless the left argument is integer in range we are going to have to
1954            use NV maths. Hence only attempt to coerce the right argument if
1955            we know the left is integer.  */
1956         UV auv = 0;
1957         bool auvok = FALSE;
1958         bool a_valid = 0;
1959
1960         if (!useleft) {
1961             auv = 0;
1962             a_valid = auvok = 1;
1963             /* left operand is undef, treat as zero.  */
1964         } else {
1965             /* Left operand is defined, so is it IV? */
1966             if (SvIV_please_nomg(svl)) {
1967                 if ((auvok = SvUOK(svl)))
1968                     auv = SvUVX(svl);
1969                 else {
1970                     const IV aiv = SvIVX(svl);
1971                     if (aiv >= 0) {
1972                         auv = aiv;
1973                         auvok = 1;      /* Now acting as a sign flag.  */
1974                     } else {
1975                         auv = (UV) (0 - (UV) aiv);
1976                     }
1977                 }
1978                 a_valid = 1;
1979             }
1980         }
1981         if (a_valid) {
1982             bool result_good = 0;
1983             UV result;
1984             UV buv;
1985             bool buvok = SvUOK(svr);
1986
1987             if (buvok)
1988                 buv = SvUVX(svr);
1989             else {
1990                 const IV biv = SvIVX(svr);
1991                 if (biv >= 0) {
1992                     buv = biv;
1993                     buvok = 1;
1994                 } else
1995                     buv = (UV) (0 - (UV) biv);
1996             }
1997             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1998                else "IV" now, independent of how it came in.
1999                if a, b represents positive, A, B negative, a maps to -A etc
2000                a - b =>  (a - b)
2001                A - b => -(a + b)
2002                a - B =>  (a + b)
2003                A - B => -(a - b)
2004                all UV maths. negate result if A negative.
2005                subtract if signs same, add if signs differ. */
2006
2007             if (auvok ^ buvok) {
2008                 /* Signs differ.  */
2009                 result = auv + buv;
2010                 if (result >= auv)
2011                     result_good = 1;
2012             } else {
2013                 /* Signs same */
2014                 if (auv >= buv) {
2015                     result = auv - buv;
2016                     /* Must get smaller */
2017                     if (result <= auv)
2018                         result_good = 1;
2019                 } else {
2020                     result = buv - auv;
2021                     if (result <= buv) {
2022                         /* result really should be -(auv-buv). as its negation
2023                            of true value, need to swap our result flag  */
2024                         auvok = !auvok;
2025                         result_good = 1;
2026                     }
2027                 }
2028             }
2029             if (result_good) {
2030                 if (auvok)
2031                     TARGu(result, 1);
2032                 else {
2033                     /* Negate result */
2034                     if (result <= (UV)IV_MIN)
2035                         TARGi(result == (UV)IV_MIN
2036                                 ? IV_MIN : -(IV)result,
2037                               1);
2038                     else {
2039                         /* result valid, but out of range for IV.  */
2040                         TARGn(-(NV)result, 1);
2041                     }
2042                 }
2043                 goto ret;
2044             } /* Overflow, drop through to NVs.  */
2045         }
2046     }
2047 #else
2048     useleft = USE_LEFT(svl);
2049 #endif
2050     {
2051         NV value = SvNV_nomg(svr);
2052
2053         if (!useleft) {
2054             /* left operand is undef, treat as zero - value */
2055             TARGn(-value, 1);
2056             goto ret;
2057         }
2058         TARGn(SvNV_nomg(svl) - value, 1);
2059         goto ret;
2060     }
2061
2062   ret:
2063     rpp_replace_2_1(targ);
2064     return NORMAL;
2065
2066 }
2067
2068
2069 #define IV_BITS (IVSIZE * 8)
2070
2071 /* Taking the right operand of bitwise shift operators, returns an int
2072  * indicating the shift amount clipped to the range [-IV_BITS, +IV_BITS].
2073  */
2074 static int
2075 S_shift_amount(pTHX_ SV *const svr)
2076 {
2077     const IV iv = SvIV_nomg(svr);
2078
2079     /* Note that [INT_MIN, INT_MAX] cannot be used as the clipping bound;
2080      * INT_MIN will cause overflow in "shift = -shift;" in S_{iv,uv}_shift.
2081      */
2082     if (SvIsUV(svr))
2083         return SvUVX(svr) > IV_BITS ? IV_BITS : (int)SvUVX(svr);
2084     return iv < -IV_BITS ? -IV_BITS : iv > IV_BITS ? IV_BITS : (int)iv;
2085 }
2086
2087 static UV S_uv_shift(UV uv, int shift, bool left)
2088 {
2089    if (shift < 0) {
2090        shift = -shift;
2091        left = !left;
2092    }
2093    if (UNLIKELY(shift >= IV_BITS)) {
2094        return 0;
2095    }
2096    return left ? uv << shift : uv >> shift;
2097 }
2098
2099 static IV S_iv_shift(IV iv, int shift, bool left)
2100 {
2101     if (shift < 0) {
2102         shift = -shift;
2103         left = !left;
2104     }
2105
2106     if (UNLIKELY(shift >= IV_BITS)) {
2107         return iv < 0 && !left ? -1 : 0;
2108     }
2109
2110     /* For left shifts, perl 5 has chosen to treat the value as unsigned for
2111      * the purposes of shifting, then cast back to signed.  This is very
2112      * different from Raku:
2113      *
2114      * $ raku -e 'say -2 +< 5'
2115      * -64
2116      *
2117      * $ ./perl -le 'print -2 << 5'
2118      * 18446744073709551552
2119      * */
2120     if (left) {
2121         return (IV) (((UV) iv) << shift);
2122     }
2123
2124     /* Here is right shift */
2125     return iv >> shift;
2126 }
2127
2128 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2129 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2130 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2131 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2132
2133 PP(pp_left_shift)
2134 {
2135     SV *targ = (PL_op->op_flags & OPf_STACKED)
2136                     ? PL_stack_sp[-1]
2137                     : PAD_SV(PL_op->op_targ);
2138
2139     if (rpp_try_AMAGIC_2(lshift_amg, AMGf_assign|AMGf_numeric))
2140         return NORMAL;
2141
2142     SV *svr = PL_stack_sp[0];
2143     SV *svl = PL_stack_sp[-1];
2144
2145     {
2146       const int shift = S_shift_amount(aTHX_ svr);
2147       if (PL_op->op_private & OPpUSEINT) {
2148           TARGi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift), 1);
2149       }
2150       else {
2151           TARGu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift), 1);
2152       }
2153       rpp_replace_2_1(targ);
2154       return NORMAL;
2155     }
2156 }
2157
2158
2159 PP(pp_right_shift)
2160 {
2161     SV *targ = (PL_op->op_flags & OPf_STACKED)
2162                     ? PL_stack_sp[-1]
2163                     : PAD_SV(PL_op->op_targ);
2164
2165     if (rpp_try_AMAGIC_2(rshift_amg, AMGf_assign|AMGf_numeric))
2166         return NORMAL;
2167
2168     SV *svr = PL_stack_sp[0];
2169     SV *svl = PL_stack_sp[-1];
2170
2171     {
2172       const int shift = S_shift_amount(aTHX_ svr);
2173       if (PL_op->op_private & OPpUSEINT) {
2174           TARGi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift), 1);
2175       }
2176       else {
2177           TARGu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift), 1);
2178       }
2179       rpp_replace_2_1(targ);
2180       return NORMAL;
2181     }
2182 }
2183
2184
2185 PP(pp_lt)
2186 {
2187     if (rpp_try_AMAGIC_2(lt_amg, AMGf_numeric))
2188         return NORMAL;
2189
2190     SV *right = PL_stack_sp[0];
2191     SV *left  = PL_stack_sp[-1];
2192
2193     U32 flags_and = SvFLAGS(left) & SvFLAGS(right);
2194     U32 flags_or  = SvFLAGS(left) | SvFLAGS(right);
2195
2196     rpp_replace_2_1(boolSV(
2197         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2198         ?    (SvIVX(left) < SvIVX(right))
2199         : (flags_and & SVf_NOK)
2200         ?    (SvNVX(left) < SvNVX(right))
2201         : (do_ncmp(left, right) == -1)
2202     ));
2203     return NORMAL;
2204 }
2205
2206
2207 PP(pp_gt)
2208 {
2209     if (rpp_try_AMAGIC_2(gt_amg, AMGf_numeric))
2210         return NORMAL;
2211
2212     SV *right = PL_stack_sp[0];
2213     SV *left  = PL_stack_sp[-1];
2214
2215     U32 flags_and = SvFLAGS(left) & SvFLAGS(right);
2216     U32 flags_or  = SvFLAGS(left) | SvFLAGS(right);
2217
2218     rpp_replace_2_1(boolSV(
2219         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2220         ?    (SvIVX(left) > SvIVX(right))
2221         : (flags_and & SVf_NOK)
2222         ?    (SvNVX(left) > SvNVX(right))
2223         : (do_ncmp(left, right) == 1)
2224     ));
2225     return NORMAL;
2226 }
2227
2228
2229 PP(pp_le)
2230 {
2231     if (rpp_try_AMAGIC_2(le_amg, AMGf_numeric))
2232         return NORMAL;
2233
2234     SV *right = PL_stack_sp[0];
2235     SV *left  = PL_stack_sp[-1];
2236
2237     U32 flags_and = SvFLAGS(left) & SvFLAGS(right);
2238     U32 flags_or  = SvFLAGS(left) | SvFLAGS(right);
2239
2240     rpp_replace_2_1(boolSV(
2241         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2242         ?    (SvIVX(left) <= SvIVX(right))
2243         : (flags_and & SVf_NOK)
2244         ?    (SvNVX(left) <= SvNVX(right))
2245         : (do_ncmp(left, right) <= 0)
2246     ));
2247     return NORMAL;
2248 }
2249
2250
2251 PP(pp_ge)
2252 {
2253     if (rpp_try_AMAGIC_2(ge_amg, AMGf_numeric))
2254         return NORMAL;
2255
2256     SV *right = PL_stack_sp[0];
2257     SV *left  = PL_stack_sp[-1];
2258
2259     U32 flags_and = SvFLAGS(left) & SvFLAGS(right);
2260     U32 flags_or  = SvFLAGS(left) | SvFLAGS(right);
2261
2262     rpp_replace_2_1(boolSV(
2263         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2264         ?    (SvIVX(left) >= SvIVX(right))
2265         : (flags_and & SVf_NOK)
2266         ?    (SvNVX(left) >= SvNVX(right))
2267         : ( (do_ncmp(left, right) & 2) == 0)
2268     ));
2269     return NORMAL;
2270 }
2271
2272
2273 PP(pp_ne)
2274 {
2275     if (rpp_try_AMAGIC_2(ne_amg, AMGf_numeric))
2276         return NORMAL;
2277
2278     SV *right = PL_stack_sp[0];
2279     SV *left  = PL_stack_sp[-1];
2280
2281     U32 flags_and = SvFLAGS(left) & SvFLAGS(right);
2282     U32 flags_or  = SvFLAGS(left) | SvFLAGS(right);
2283
2284     rpp_replace_2_1(boolSV(
2285         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2286         ?    (SvIVX(left) != SvIVX(right))
2287         : (flags_and & SVf_NOK)
2288         ?    (SvNVX(left) != SvNVX(right))
2289         : (do_ncmp(left, right) != 0)
2290     ));
2291     return NORMAL;
2292 }
2293
2294
2295 /* compare left and right SVs. Returns:
2296  * -1: <
2297  *  0: ==
2298  *  1: >
2299  *  2: left or right was a NaN
2300  */
2301 I32
2302 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2303 {
2304     PERL_ARGS_ASSERT_DO_NCMP;
2305 #ifdef PERL_PRESERVE_IVUV
2306     /* Fortunately it seems NaN isn't IOK */
2307     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2308             if (!SvUOK(left)) {
2309                 const IV leftiv = SvIVX(left);
2310                 if (!SvUOK(right)) {
2311                     /* ## IV <=> IV ## */
2312                     const IV rightiv = SvIVX(right);
2313                     return (leftiv > rightiv) - (leftiv < rightiv);
2314                 }
2315                 /* ## IV <=> UV ## */
2316                 if (leftiv < 0)
2317                     /* As (b) is a UV, it's >=0, so it must be < */
2318                     return -1;
2319                 {
2320                     const UV rightuv = SvUVX(right);
2321                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2322                 }
2323             }
2324
2325             if (SvUOK(right)) {
2326                 /* ## UV <=> UV ## */
2327                 const UV leftuv = SvUVX(left);
2328                 const UV rightuv = SvUVX(right);
2329                 return (leftuv > rightuv) - (leftuv < rightuv);
2330             }
2331             /* ## UV <=> IV ## */
2332             {
2333                 const IV rightiv = SvIVX(right);
2334                 if (rightiv < 0)
2335                     /* As (a) is a UV, it's >=0, so it cannot be < */
2336                     return 1;
2337                 {
2338                     const UV leftuv = SvUVX(left);
2339                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2340                 }
2341             }
2342             NOT_REACHED; /* NOTREACHED */
2343     }
2344 #endif
2345     {
2346       NV const rnv = SvNV_nomg(right);
2347       NV const lnv = SvNV_nomg(left);
2348
2349 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2350       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2351           return 2;
2352        }
2353       return (lnv > rnv) - (lnv < rnv);
2354 #else
2355       if (lnv < rnv)
2356         return -1;
2357       if (lnv > rnv)
2358         return 1;
2359       if (lnv == rnv)
2360         return 0;
2361       return 2;
2362 #endif
2363     }
2364 }
2365
2366
2367 PP(pp_ncmp)
2368 {
2369     if (rpp_try_AMAGIC_2(ncmp_amg, AMGf_numeric))
2370         return NORMAL;
2371
2372     SV *right = PL_stack_sp[0];
2373     SV *left  = PL_stack_sp[-1];
2374
2375     SV *targ;
2376     I32 value = do_ncmp(left, right);
2377     if (value == 2) {
2378         targ = &PL_sv_undef;
2379     }
2380     else {
2381         GETTARGET;
2382         TARGi(value, 1);
2383     }
2384     rpp_replace_2_1(targ);
2385     return NORMAL;
2386 }
2387
2388
2389 /* also used for: pp_sge() pp_sgt() pp_slt() */
2390
2391 PP(pp_sle)
2392 {
2393     int amg_type = sle_amg;
2394     int multiplier = 1;
2395     int rhs = 1;
2396
2397     switch (PL_op->op_type) {
2398     case OP_SLT:
2399         amg_type = slt_amg;
2400         /* cmp < 0 */
2401         rhs = 0;
2402         break;
2403     case OP_SGT:
2404         amg_type = sgt_amg;
2405         /* cmp > 0 */
2406         multiplier = -1;
2407         rhs = 0;
2408         break;
2409     case OP_SGE:
2410         amg_type = sge_amg;
2411         /* cmp >= 0 */
2412         multiplier = -1;
2413         break;
2414     }
2415
2416     if (rpp_try_AMAGIC_2(amg_type, 0))
2417         return NORMAL;
2418
2419     SV *right = PL_stack_sp[0];
2420     SV *left  = PL_stack_sp[-1];
2421
2422     const int cmp =
2423 #ifdef USE_LOCALE_COLLATE
2424                       (IN_LC_RUNTIME(LC_COLLATE))
2425                       ? sv_cmp_locale_flags(left, right, 0)
2426                       :
2427 #endif
2428                         sv_cmp_flags(left, right, 0);
2429     rpp_replace_2_1(boolSV(cmp * multiplier < rhs));
2430     return NORMAL;
2431 }
2432
2433
2434 PP(pp_seq)
2435 {
2436     if (rpp_try_AMAGIC_2(seq_amg, 0))
2437         return NORMAL;
2438
2439     SV *right = PL_stack_sp[0];
2440     SV *left  = PL_stack_sp[-1];
2441
2442     rpp_replace_2_1(boolSV(sv_eq_flags(left, right, 0)));;
2443     return NORMAL;
2444 }
2445
2446
2447 PP(pp_sne)
2448 {
2449     if (rpp_try_AMAGIC_2(sne_amg, 0))
2450         return NORMAL;
2451
2452     SV *right = PL_stack_sp[0];
2453     SV *left  = PL_stack_sp[-1];
2454
2455     rpp_replace_2_1(boolSV(!sv_eq_flags(left, right, 0)));
2456     return NORMAL;
2457 }
2458
2459
2460 PP(pp_scmp)
2461 {
2462     dTARGET;
2463
2464     if (rpp_try_AMAGIC_2(scmp_amg, 0))
2465         return NORMAL;
2466
2467     SV *right = PL_stack_sp[0];
2468     SV *left  = PL_stack_sp[-1];
2469
2470     const int cmp =
2471 #ifdef USE_LOCALE_COLLATE
2472                       (IN_LC_RUNTIME(LC_COLLATE))
2473                       ? sv_cmp_locale_flags(left, right, 0)
2474                       :
2475 #endif
2476                         sv_cmp_flags(left, right, 0);
2477     TARGi(cmp, 1);
2478     rpp_replace_2_1(targ);
2479     return NORMAL;
2480 }
2481
2482
2483 PP(pp_bit_and)
2484 {
2485     SV *targ = (PL_op->op_flags & OPf_STACKED)
2486                     ? PL_stack_sp[-1]
2487                     : PAD_SV(PL_op->op_targ);
2488
2489     if (rpp_try_AMAGIC_2(band_amg, AMGf_assign))
2490         return NORMAL;
2491
2492     SV *right = PL_stack_sp[0];
2493     SV *left  = PL_stack_sp[-1];
2494
2495     {
2496       if (SvNIOKp(left) || SvNIOKp(right)) {
2497         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2498         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2499         if (PL_op->op_private & OPpUSEINT) {
2500           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2501           TARGi(i, 1);
2502         }
2503         else {
2504           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2505           TARGu(u, 1);
2506         }
2507         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2508         if (right_ro_nonnum) SvNIOK_off(right);
2509       }
2510       else {
2511         do_vop(PL_op->op_type, TARG, left, right);
2512         SvSETMAGIC(targ);
2513
2514       }
2515     }
2516     rpp_replace_2_1(targ);
2517     return NORMAL;
2518 }
2519
2520
2521 PP(pp_nbit_and)
2522 {
2523     if (rpp_try_AMAGIC_2(band_amg, AMGf_assign|AMGf_numarg))
2524         return NORMAL;
2525
2526     SV *targ = (PL_op->op_flags & OPf_STACKED)
2527                     ? PL_stack_sp[-1]
2528                     : PAD_SV(PL_op->op_targ);
2529
2530     SV *right = PL_stack_sp[0];
2531     SV *left  = PL_stack_sp[-1];
2532
2533     {
2534         if (PL_op->op_private & OPpUSEINT) {
2535           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2536           TARGi(i, 1);
2537         }
2538         else {
2539           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2540           TARGu(u, 1);
2541         }
2542     }
2543     rpp_replace_2_1(targ);
2544     return NORMAL;
2545 }
2546
2547
2548 PP(pp_sbit_and)
2549 {
2550     if (rpp_try_AMAGIC_2(sband_amg, AMGf_assign))
2551         return NORMAL;
2552
2553     SV *targ = (PL_op->op_flags & OPf_STACKED)
2554                     ? PL_stack_sp[-1]
2555                     : PAD_SV(PL_op->op_targ);
2556
2557     SV *right = PL_stack_sp[0];
2558     SV *left  = PL_stack_sp[-1];
2559
2560     do_vop(OP_BIT_AND, targ, left, right);
2561     SvSETMAGIC(targ);
2562     rpp_replace_2_1(targ);
2563     return NORMAL;
2564 }
2565
2566
2567 /* also used for: pp_bit_xor() */
2568
2569 PP(pp_bit_or)
2570 {
2571     SV *targ = (PL_op->op_flags & OPf_STACKED)
2572                     ? PL_stack_sp[-1]
2573                     : PAD_SV(PL_op->op_targ);
2574
2575     const int op_type = PL_op->op_type;
2576
2577     if (rpp_try_AMAGIC_2((op_type == OP_BIT_OR ? bor_amg : bxor_amg),
2578                             AMGf_assign))
2579         return NORMAL;
2580
2581     SV *right = PL_stack_sp[0];
2582     SV *left  = PL_stack_sp[-1];
2583
2584     {
2585       if (SvNIOKp(left) || SvNIOKp(right)) {
2586         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2587         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2588         if (PL_op->op_private & OPpUSEINT) {
2589           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2590           const IV r = SvIV_nomg(right);
2591           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2592           TARGi(result, 1);
2593         }
2594         else {
2595           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2596           const UV r = SvUV_nomg(right);
2597           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2598           TARGu(result, 1);
2599         }
2600         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2601         if (right_ro_nonnum) SvNIOK_off(right);
2602       }
2603       else {
2604         do_vop(op_type, TARG, left, right);
2605         SvSETMAGIC(targ);
2606       }
2607       rpp_replace_2_1(targ);
2608       return NORMAL;
2609     }
2610 }
2611
2612
2613 /* also used for: pp_nbit_xor() */
2614
2615 PP(pp_nbit_or)
2616 {
2617     const int op_type = PL_op->op_type;
2618
2619     if (rpp_try_AMAGIC_2((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2620                             AMGf_assign|AMGf_numarg))
2621         return NORMAL;
2622
2623     SV *targ = (PL_op->op_flags & OPf_STACKED)
2624                     ? PL_stack_sp[-1]
2625                     : PAD_SV(PL_op->op_targ);
2626
2627     SV *right = PL_stack_sp[0];
2628     SV *left  = PL_stack_sp[-1];
2629
2630     {
2631         if (PL_op->op_private & OPpUSEINT) {
2632           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2633           const IV r = SvIV_nomg(right);
2634           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2635           TARGi(result, 1);
2636         }
2637         else {
2638           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2639           const UV r = SvUV_nomg(right);
2640           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2641           TARGu(result, 1);
2642         }
2643     }
2644     rpp_replace_2_1(targ);
2645     return NORMAL;
2646 }
2647
2648
2649 /* also used for: pp_sbit_xor() */
2650
2651 PP(pp_sbit_or)
2652 {
2653     const int op_type = PL_op->op_type;
2654
2655     if (rpp_try_AMAGIC_2((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2656                             AMGf_assign))
2657         return NORMAL;
2658
2659     SV *targ = (PL_op->op_flags & OPf_STACKED)
2660                     ? PL_stack_sp[-1]
2661                     : PAD_SV(PL_op->op_targ);
2662
2663     SV *right = PL_stack_sp[0];
2664     SV *left  = PL_stack_sp[-1];
2665
2666     do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, targ,
2667             left, right);
2668
2669     SvSETMAGIC(TARG);
2670     rpp_replace_2_1(targ);
2671     return NORMAL;
2672 }
2673
2674
2675 PERL_STATIC_INLINE bool
2676 S_negate_string(pTHX)
2677 {
2678     dTARGET;
2679     STRLEN len;
2680     const char *s;
2681     SV * const sv = *PL_stack_sp;
2682
2683     assert(SvPOKp(sv));
2684     if (SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2685         return FALSE;
2686
2687     s = SvPV_nomg_const(sv, len);
2688     if (isIDFIRST(*s)) {
2689         if (LIKELY(TARG!=sv)) {
2690             sv_setpvs(TARG, "-");
2691             sv_catsv(TARG, sv);
2692         } else {
2693             sv_insert_flags(TARG, 0, 0, "-", 1, 0);
2694         }
2695     }
2696     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2697         sv_setsv_nomg(TARG, sv);
2698         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2699     }
2700     else return FALSE;
2701     SvSETMAGIC(TARG);
2702     if (LIKELY(targ != sv))
2703         rpp_replace_1_1(TARG);
2704     return TRUE;
2705 }
2706
2707 PP(pp_negate)
2708 {
2709     dTARGET;
2710
2711     if (rpp_try_AMAGIC_1(neg_amg, AMGf_numeric))
2712         return NORMAL;
2713
2714     SV * const sv = *PL_stack_sp;
2715
2716     if (SvPOKp(sv) && S_negate_string(aTHX))
2717         return NORMAL;
2718
2719     {
2720
2721         if (SvIOK(sv)) {
2722             /* It's publicly an integer */
2723         oops_its_an_int:
2724             if (SvIsUV(sv)) {
2725                 if (SvIVX(sv) == IV_MIN) {
2726                     /* 2s complement assumption. */
2727                     TARGi(SvIVX(sv), 1);/* special case: -((UV)IV_MAX+1) ==
2728                                            IV_MIN */
2729                     goto ret;
2730                 }
2731                 else if (SvUVX(sv) <= IV_MAX) {
2732                     TARGi(-SvIVX(sv), 1);
2733                     goto ret;
2734                 }
2735             }
2736             else if (SvIVX(sv) != IV_MIN) {
2737                 TARGi(-SvIVX(sv), 1);
2738                 goto ret;
2739             }
2740 #ifdef PERL_PRESERVE_IVUV
2741             else {
2742                 TARGu((UV)IV_MIN, 1);
2743                 goto ret;
2744             }
2745 #endif
2746         }
2747         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2748             TARGn(-SvNV_nomg(sv), 1);
2749         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2750                   goto oops_its_an_int;
2751         else
2752             TARGn(-SvNV_nomg(sv), 1);
2753     }
2754
2755   ret:
2756     if (LIKELY(targ != sv))
2757         rpp_replace_1_1(TARG);
2758     return NORMAL;
2759 }
2760
2761
2762 PP(pp_not)
2763 {
2764     if (rpp_try_AMAGIC_1(not_amg, 0))
2765         return NORMAL;
2766     rpp_replace_1_1(boolSV(!SvTRUE_nomg_NN(*PL_stack_sp)));
2767     return NORMAL;
2768 }
2769
2770 static void
2771 S_scomplement(pTHX_ SV *targ, SV *sv)
2772 {
2773         U8 *tmps;
2774         SSize_t anum;
2775         STRLEN len;
2776
2777         sv_copypv_nomg(TARG, sv);
2778         tmps = (U8*)SvPV_nomg(TARG, len);
2779
2780         if (SvUTF8(TARG)) {
2781             if (len && ! utf8_to_bytes(tmps, &len)) {
2782                 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2783             }
2784             SvCUR_set(TARG, len);
2785             SvUTF8_off(TARG);
2786         }
2787
2788         anum = len;
2789
2790         {
2791             long *tmpl;
2792             for ( ; anum && PTR2nat(tmps) % sizeof(long); anum--, tmps++)
2793                 *tmps = ~*tmps;
2794             tmpl = (long*)tmps;
2795             for ( ; anum >= (SSize_t)sizeof(long); anum -= (SSize_t)sizeof(long), tmpl++)
2796                 *tmpl = ~*tmpl;
2797             tmps = (U8*)tmpl;
2798         }
2799
2800         for ( ; anum > 0; anum--, tmps++)
2801             *tmps = ~*tmps;
2802 }
2803
2804 PP(pp_complement)
2805 {
2806     dTARGET;
2807     if (rpp_try_AMAGIC_1(compl_amg, AMGf_numeric))
2808         return NORMAL;
2809
2810     {
2811       SV *sv = *PL_stack_sp;
2812       if (SvNIOKp(sv)) {
2813         if (PL_op->op_private & OPpUSEINT) {
2814           const IV i = ~SvIV_nomg(sv);
2815           TARGi(i, 1);
2816         }
2817         else {
2818           const UV u = ~SvUV_nomg(sv);
2819           TARGu(u, 1);
2820         }
2821       }
2822       else {
2823         S_scomplement(aTHX_ TARG, sv);
2824         SvSETMAGIC(TARG);
2825       }
2826
2827       rpp_replace_1_1(TARG);
2828       return NORMAL;
2829     }
2830 }
2831
2832 PP(pp_ncomplement)
2833 {
2834     if (rpp_try_AMAGIC_1(compl_amg, AMGf_numeric|AMGf_numarg))
2835         return NORMAL;
2836
2837     dTARGET;
2838     {
2839         SV *sv = *PL_stack_sp;
2840         if (PL_op->op_private & OPpUSEINT) {
2841           const IV i = ~SvIV_nomg(sv);
2842           TARGi(i, 1);
2843         }
2844         else {
2845           const UV u = ~SvUV_nomg(sv);
2846           TARGu(u, 1);
2847         }
2848     }
2849
2850     rpp_replace_1_1(TARG);
2851     return NORMAL;
2852 }
2853
2854 PP(pp_scomplement)
2855 {
2856     if (rpp_try_AMAGIC_1(scompl_amg, AMGf_numeric))
2857         return NORMAL;
2858
2859     dTARGET;
2860     SV *sv = *PL_stack_sp;
2861     S_scomplement(aTHX_ TARG, sv);
2862     SvSETMAGIC(TARG);
2863     rpp_replace_1_1(TARG);
2864     return NORMAL;
2865 }
2866
2867
2868 /* integer versions of some of the above */
2869
2870 PP(pp_i_multiply)
2871 {
2872     SV *targ = (PL_op->op_flags & OPf_STACKED)
2873                     ? PL_stack_sp[-1]
2874                     : PAD_SV(PL_op->op_targ);
2875
2876     if (rpp_try_AMAGIC_2(mult_amg, AMGf_assign))
2877         return NORMAL;
2878
2879     IV right = SvIV_nomg(PL_stack_sp[0]);
2880     IV left  = SvIV_nomg(PL_stack_sp[-1]);
2881
2882     TARGi((IV)((UV)left * (UV)right), 1);
2883     rpp_replace_2_1(targ);
2884     return NORMAL;
2885 }
2886
2887
2888 PP(pp_i_divide)
2889 {
2890     SV *targ = (PL_op->op_flags & OPf_STACKED)
2891                     ? PL_stack_sp[-1]
2892                     : PAD_SV(PL_op->op_targ);
2893
2894     if (rpp_try_AMAGIC_2(div_amg, AMGf_assign))
2895         return NORMAL;
2896
2897     SV *right = PL_stack_sp[0];
2898     SV *left  = PL_stack_sp[-1];
2899
2900     {
2901       IV value = SvIV_nomg(right);
2902       if (value == 0)
2903           DIE(aTHX_ "Illegal division by zero");
2904       IV num = SvIV_nomg(left);
2905
2906       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2907       if (value == -1)
2908           value = (IV)-(UV)num;
2909       else
2910           value = num / value;
2911       TARGi(value, 1);
2912       rpp_replace_2_1(targ);
2913       return NORMAL;
2914     }
2915 }
2916
2917
2918 PP(pp_i_modulo)
2919 {
2920     SV *targ = (PL_op->op_flags & OPf_STACKED)
2921                     ? PL_stack_sp[-1]
2922                     : PAD_SV(PL_op->op_targ);
2923
2924     if (rpp_try_AMAGIC_2(modulo_amg, AMGf_assign))
2925         return NORMAL;
2926
2927     IV right = SvIV_nomg(PL_stack_sp[0]);
2928     IV left  = SvIV_nomg(PL_stack_sp[-1]);
2929
2930      {
2931           if (!right)
2932                DIE(aTHX_ "Illegal modulus zero");
2933           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2934           if (right == -1)
2935               TARGi(0, 1);
2936           else
2937               TARGi(left % right, 1);
2938      }
2939     rpp_replace_2_1(targ);
2940     return NORMAL;
2941 }
2942
2943
2944 PP(pp_i_add)
2945 {
2946     SV *targ = (PL_op->op_flags & OPf_STACKED)
2947                     ? PL_stack_sp[-1]
2948                     : PAD_SV(PL_op->op_targ);
2949
2950     if (rpp_try_AMAGIC_2(add_amg, AMGf_assign))
2951         return NORMAL;
2952
2953     IV right   = SvIV_nomg(PL_stack_sp[0]);
2954     SV *leftsv = PL_stack_sp[-1];
2955     IV left    = USE_LEFT(leftsv) ? SvIV_nomg(leftsv) : 0;
2956
2957     TARGi((IV)((UV)left + (UV)right), 1);
2958     rpp_replace_2_1(targ);
2959     return NORMAL;
2960 }
2961
2962
2963 PP(pp_i_subtract)
2964 {
2965     SV *targ = (PL_op->op_flags & OPf_STACKED)
2966                     ? PL_stack_sp[-1]
2967                     : PAD_SV(PL_op->op_targ);
2968
2969     if (rpp_try_AMAGIC_2(subtr_amg, AMGf_assign))
2970         return NORMAL;
2971
2972     IV right   = SvIV_nomg(PL_stack_sp[0]);
2973     SV *leftsv = PL_stack_sp[-1];
2974     IV left    = USE_LEFT(leftsv) ? SvIV_nomg(leftsv) : 0;
2975
2976     TARGi((IV)((UV)left - (UV)right), 1);
2977     rpp_replace_2_1(targ);
2978     return NORMAL;
2979 }
2980
2981
2982 PP(pp_i_lt)
2983 {
2984     if (rpp_try_AMAGIC_2(lt_amg, 0))
2985         return NORMAL;
2986
2987     IV right   = SvIV_nomg(PL_stack_sp[0]);
2988     IV left    = SvIV_nomg(PL_stack_sp[-1]);
2989
2990     rpp_replace_2_1(boolSV(left < right));
2991     return NORMAL;
2992 }
2993
2994
2995 PP(pp_i_gt)
2996 {
2997     if (rpp_try_AMAGIC_2(gt_amg, 0))
2998         return NORMAL;
2999
3000     IV right   = SvIV_nomg(PL_stack_sp[0]);
3001     IV left    = SvIV_nomg(PL_stack_sp[-1]);
3002
3003     rpp_replace_2_1(boolSV(left > right));
3004     return NORMAL;
3005 }
3006
3007
3008 PP(pp_i_le)
3009 {
3010     if (rpp_try_AMAGIC_2(le_amg, 0))
3011         return NORMAL;
3012
3013     IV right   = SvIV_nomg(PL_stack_sp[0]);
3014     IV left    = SvIV_nomg(PL_stack_sp[-1]);
3015
3016     rpp_replace_2_1(boolSV(left <= right));
3017     return NORMAL;
3018 }
3019
3020
3021 PP(pp_i_ge)
3022 {
3023     if (rpp_try_AMAGIC_2(ge_amg, 0))
3024         return NORMAL;
3025
3026     IV right   = SvIV_nomg(PL_stack_sp[0]);
3027     IV left    = SvIV_nomg(PL_stack_sp[-1]);
3028
3029     rpp_replace_2_1(boolSV(left >= right));
3030     return NORMAL;
3031 }
3032
3033
3034 PP(pp_i_eq)
3035 {
3036     if (rpp_try_AMAGIC_2(eq_amg, 0))
3037         return NORMAL;
3038
3039     IV right   = SvIV_nomg(PL_stack_sp[0]);
3040     IV left    = SvIV_nomg(PL_stack_sp[-1]);
3041
3042     rpp_replace_2_1(boolSV(left == right));
3043     return NORMAL;
3044 }
3045
3046
3047 PP(pp_i_ne)
3048 {
3049     if (rpp_try_AMAGIC_2(ne_amg, 0))
3050         return NORMAL;
3051
3052     IV right   = SvIV_nomg(PL_stack_sp[0]);
3053     IV left    = SvIV_nomg(PL_stack_sp[-1]);
3054
3055     rpp_replace_2_1(boolSV(left != right));
3056     return NORMAL;
3057 }
3058
3059
3060 PP(pp_i_ncmp)
3061 {
3062     dTARGET;
3063     if (rpp_try_AMAGIC_2(ncmp_amg, 0))
3064         return NORMAL;
3065
3066     IV right   = SvIV_nomg(PL_stack_sp[0]);
3067     IV left    = SvIV_nomg(PL_stack_sp[-1]);
3068
3069
3070     {
3071       I32 value;
3072
3073       if (left > right)
3074         value = 1;
3075       else if (left < right)
3076         value = -1;
3077       else
3078         value = 0;
3079       TARGi(value, 1);
3080     }
3081     rpp_replace_2_1(targ);
3082     return NORMAL;
3083 }
3084
3085 PP(pp_i_negate)
3086 {
3087     dTARGET;
3088     if (rpp_try_AMAGIC_1(neg_amg, 0))
3089         return NORMAL;
3090
3091     SV * const sv = *PL_stack_sp;
3092
3093     if (SvPOKp(sv) && S_negate_string(aTHX))
3094         return NORMAL;
3095     {
3096         IV const i = SvIV_nomg(sv);
3097         TARGi((IV)-(UV)i, 1);
3098         if (LIKELY(targ != sv))
3099             rpp_replace_1_1(TARG);
3100         return NORMAL;
3101     }
3102 }
3103
3104
3105 /* High falutin' math. */
3106
3107 PP(pp_atan2)
3108 {
3109     dTARGET;
3110     if (rpp_try_AMAGIC_2(atan2_amg, 0))
3111         return NORMAL;
3112
3113     NV right = SvNV_nomg(PL_stack_sp[0]);
3114     NV left  = SvNV_nomg(PL_stack_sp[-1]);
3115
3116     TARGn(Perl_atan2(left, right), 1);
3117     rpp_replace_2_1(targ);
3118     return NORMAL;
3119 }
3120
3121
3122 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
3123
3124 PP(pp_sin)
3125 {
3126     dTARGET;
3127     int amg_type = fallback_amg;
3128     const char *neg_report = NULL;
3129     const int op_type = PL_op->op_type;
3130
3131     switch (op_type) {
3132     case OP_SIN:  amg_type = sin_amg; break;
3133     case OP_COS:  amg_type = cos_amg; break;
3134     case OP_EXP:  amg_type = exp_amg; break;
3135     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
3136     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
3137     }
3138
3139     assert(amg_type != fallback_amg);
3140
3141     if (rpp_try_AMAGIC_1(amg_type, 0))
3142         return NORMAL;
3143
3144     {
3145       SV * const arg = *PL_stack_sp;
3146       const NV value = SvNV_nomg(arg);
3147 #ifdef NV_NAN
3148       NV result = NV_NAN;
3149 #else
3150       NV result = 0.0;
3151 #endif
3152       if (neg_report) { /* log or sqrt */
3153           if (
3154 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3155               ! Perl_isnan(value) &&
3156 #endif
3157               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)))
3158           {
3159               char * mesg;
3160               LC_NUMERIC_LOCK(0);
3161               SET_NUMERIC_STANDARD();
3162               mesg = Perl_form(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
3163               LC_NUMERIC_UNLOCK;
3164
3165               /* diag_listed_as: Can't take log of %g */
3166               DIE(aTHX_ "%s", mesg);
3167           }
3168       }
3169       switch (op_type) {
3170       default:
3171       case OP_SIN:  result = Perl_sin(value);  break;
3172       case OP_COS:  result = Perl_cos(value);  break;
3173       case OP_EXP:  result = Perl_exp(value);  break;
3174       case OP_LOG:  result = Perl_log(value);  break;
3175       case OP_SQRT: result = Perl_sqrt(value); break;
3176       }
3177       TARGn(result, 1);
3178       rpp_replace_1_1(TARG);
3179       return NORMAL;
3180     }
3181 }
3182
3183 /* Support Configure command-line overrides for rand() functions.
3184    After 5.005, perhaps we should replace this by Configure support
3185    for drand48(), random(), or rand().  For 5.005, though, maintain
3186    compatibility by calling rand() but allow the user to override it.
3187    See INSTALL for details.  --Andy Dougherty  15 July 1998
3188 */
3189 /* Now it's after 5.005, and Configure supports drand48() and random(),
3190    in addition to rand().  So the overrides should not be needed any more.
3191    --Jarkko Hietaniemi  27 September 1998
3192  */
3193
3194 PP_wrapped(pp_rand, MAXARG, 0)
3195 {
3196     if (!PL_srand_called) {
3197         Rand_seed_t s;
3198         if (PL_srand_override) {
3199             /* env var PERL_RAND_SEED has been set so the user wants
3200              * consistent srand() initialization. */
3201             PERL_SRAND_OVERRIDE_GET(s);
3202         } else {
3203             /* Pseudo random initialization from context state and possible
3204              * random devices */
3205             s= (Rand_seed_t)seed();
3206         }
3207         (void)seedDrand01(s);
3208         PL_srand_called = TRUE;
3209     }
3210     {
3211         dSP;
3212         NV value;
3213
3214         if (MAXARG < 1)
3215         {
3216             EXTEND(SP, 1);
3217             value = 1.0;
3218         }
3219         else {
3220             SV * const sv = POPs;
3221             if(!sv)
3222                 value = 1.0;
3223             else
3224                 value = SvNV(sv);
3225         }
3226     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3227 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3228         if (! Perl_isnan(value) && value == 0.0)
3229 #else
3230         if (value == 0.0)
3231 #endif
3232             value = 1.0;
3233         {
3234             dTARGET;
3235             PUSHs(TARG);
3236             PUTBACK;
3237             value *= Drand01();
3238             sv_setnv_mg(TARG, value);
3239         }
3240     }
3241     return NORMAL;
3242 }
3243
3244 PP_wrapped(pp_srand, MAXARG, 0)
3245 {
3246     dSP; dTARGET;
3247     UV anum;
3248
3249     if (MAXARG >= 1 && (TOPs || POPs)) {
3250         SV *top;
3251         char *pv;
3252         STRLEN len;
3253         int flags;
3254
3255         top = POPs;
3256         pv = SvPV(top, len);
3257         flags = grok_number(pv, len, &anum);
3258
3259         if (!(flags & IS_NUMBER_IN_UV)) {
3260             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3261                              "Integer overflow in srand");
3262             anum = UV_MAX;
3263         }
3264     }
3265     else {
3266         if (PL_srand_override) {
3267             /* env var PERL_RAND_SEED has been set so the user wants
3268              * consistent srand() initialization. */
3269             PERL_SRAND_OVERRIDE_GET(anum);
3270         } else {
3271             anum = seed();
3272         }
3273     }
3274
3275     (void)seedDrand01((Rand_seed_t)anum);
3276     PL_srand_called = TRUE;
3277     if (anum)
3278         XPUSHu(anum);
3279     else {
3280         /* Historically srand always returned true. We can avoid breaking
3281            that like this:  */
3282         sv_setpvs(TARG, "0 but true");
3283         XPUSHTARG;
3284     }
3285     RETURN;
3286 }
3287
3288 PP(pp_int)
3289 {
3290     dTARGET;
3291     if (rpp_try_AMAGIC_1(int_amg, AMGf_numeric))
3292         return NORMAL;
3293     {
3294       SV * const sv = *PL_stack_sp;
3295       const IV iv = SvIV_nomg(sv);
3296       /* XXX it's arguable that compiler casting to IV might be subtly
3297          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3298          else preferring IV has introduced a subtle behaviour change bug. OTOH
3299          relying on floating point to be accurate is a bug.  */
3300
3301       if (!SvOK(sv)) {
3302         TARGu(0, 1);
3303       }
3304       else if (SvIOK(sv)) {
3305         if (SvIsUV(sv))
3306             TARGu(SvUV_nomg(sv), 1);
3307         else
3308             TARGi(iv, 1);
3309       }
3310       else {
3311           const NV value = SvNV_nomg(sv);
3312           if (UNLIKELY(Perl_isinfnan(value)))
3313               TARGn(value, 1);
3314           else if (value >= 0.0) {
3315               if (value < (NV)UV_MAX + 0.5) {
3316                   TARGu(U_V(value), 1);
3317               } else {
3318                   TARGn(Perl_floor(value), 1);
3319               }
3320           }
3321           else {
3322               if (value > (NV)IV_MIN - 0.5) {
3323                   TARGi(I_V(value), 1);
3324               } else {
3325                   TARGn(Perl_ceil(value), 1);
3326               }
3327           }
3328       }
3329     }
3330     rpp_replace_1_1(TARG);
3331     return NORMAL;
3332 }
3333
3334 PP(pp_abs)
3335 {
3336     dTARGET;
3337     if (rpp_try_AMAGIC_1(abs_amg, AMGf_numeric))
3338         return NORMAL;
3339
3340     {
3341       SV * const sv = *PL_stack_sp;
3342       /* This will cache the NV value if string isn't actually integer  */
3343       const IV iv = SvIV_nomg(sv);
3344       UV uv;
3345
3346       if (!SvOK(sv)) {
3347         uv = 0;
3348         goto set_uv;
3349       }
3350       else if (SvIOK(sv)) {
3351         /* IVX is precise  */
3352         if (SvIsUV(sv)) {
3353           uv = SvUVX(sv);       /* force it to be numeric only */
3354         } else {
3355           if (iv >= 0) {
3356             uv = (UV)iv;
3357           } else {
3358               /* "(UV)-(iv + 1) + 1" below is mathematically "-iv", but
3359                  transformed so that every subexpression will never trigger
3360                  overflows even on 2's complement representation (note that
3361                  iv is always < 0 here), and modern compilers could optimize
3362                  this to a single negation.  */
3363               uv = (UV)-(iv + 1) + 1;
3364           }
3365         }
3366       set_uv:
3367         TARGu(uv, 1);
3368       } else{
3369         const NV value = SvNV_nomg(sv);
3370         TARGn(Perl_fabs(value), 1);
3371       }
3372     }
3373
3374     rpp_replace_1_1(TARG);
3375     return NORMAL;
3376 }
3377
3378
3379 /* also used for: pp_hex() */
3380
3381 PP(pp_oct)
3382 {
3383     dTARGET;
3384     const char *tmps;
3385     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3386     STRLEN len;
3387     NV result_nv;
3388     UV result_uv;
3389     SV* const sv = *PL_stack_sp;
3390
3391     tmps = (SvPV_const(sv, len));
3392     if (DO_UTF8(sv)) {
3393          /* If Unicode, try to downgrade
3394           * If not possible, croak. */
3395          SV* const tsv = sv_2mortal(newSVsv(sv));
3396
3397          SvUTF8_on(tsv);
3398          (void)sv_utf8_downgrade(tsv, FALSE);
3399          tmps = SvPV_const(tsv, len);
3400     }
3401     if (PL_op->op_type == OP_HEX)
3402         goto hex;
3403
3404     while (*tmps && len && isSPACE(*tmps))
3405         tmps++, len--;
3406     if (*tmps == '0')
3407         tmps++, len--;
3408     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3409         tmps++, len--;
3410         flags |= PERL_SCAN_DISALLOW_PREFIX;
3411     hex:
3412         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3413     }
3414     else if (isALPHA_FOLD_EQ(*tmps, 'b')) {
3415         tmps++, len--;
3416         flags |= PERL_SCAN_DISALLOW_PREFIX;
3417         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3418     }
3419     else {
3420         if (isALPHA_FOLD_EQ(*tmps, 'o')) {
3421             tmps++, len--;
3422         }
3423         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3424     }
3425
3426     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3427         TARGn(result_nv, 1);
3428     }
3429     else {
3430         TARGu(result_uv, 1);
3431     }
3432
3433     rpp_replace_1_1(TARG);
3434     return NORMAL;
3435 }
3436
3437 /* String stuff. */
3438
3439
3440 PP(pp_length)
3441 {
3442     dTARGET;
3443     SV * const sv = *PL_stack_sp;
3444
3445     U32 in_bytes = IN_BYTES;
3446     /* Simplest case shortcut:
3447      * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3448      * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3449      * set)
3450      */
3451     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3452
3453     STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3454
3455     if (LIKELY(svflags == SVf_POK))
3456         goto simple_pv;
3457
3458     if (svflags & SVs_GMG)
3459         mg_get(sv);
3460
3461     if (SvOK(sv)) {
3462         STRLEN len;
3463         if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3464             if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3465                 goto simple_pv;
3466             if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3467                 /* no need to convert from bytes to chars */
3468                 len = SvCUR(sv);
3469                 goto return_bool;
3470             }
3471             len = sv_len_utf8_nomg(sv);
3472         }
3473         else {
3474             /* unrolled SvPV_nomg_const(sv,len) */
3475             if (SvPOK_nog(sv)) {
3476               simple_pv:
3477                 len = SvCUR(sv);
3478                 if (PL_op->op_private & OPpTRUEBOOL) {
3479                   return_bool:
3480                     targ = (len ? &PL_sv_yes : &PL_sv_zero);
3481                     goto ret;
3482                 }
3483             }
3484             else {
3485                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3486             }
3487         }
3488         TARGi((IV)(len), 1);
3489     }
3490     else {
3491         if (!SvPADTMP(TARG)) {
3492             /* OPpTARGET_MY: targ is var in '$lex = length()' */
3493             sv_set_undef(TARG);
3494             SvSETMAGIC(TARG);
3495         }
3496         else
3497             targ = &PL_sv_undef;
3498     }
3499
3500   ret:
3501     rpp_replace_1_1(TARG);
3502     return NORMAL; /* no putback, SP didn't move in this opcode */
3503 }
3504
3505
3506 /* Returns false if substring is completely outside original string.
3507    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3508    always be true for an explicit 0.
3509 */
3510 bool
3511 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3512                                 bool pos1_is_uv, IV len_iv,
3513                                 bool len_is_uv, STRLEN *posp,
3514                                 STRLEN *lenp)
3515 {
3516     IV pos2_iv;
3517     int    pos2_is_uv;
3518
3519     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3520
3521     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3522         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3523         pos1_iv += curlen;
3524     }
3525     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3526         return FALSE;
3527
3528     if (len_iv || len_is_uv) {
3529         if (!len_is_uv && len_iv < 0) {
3530             pos2_iv = curlen + len_iv;
3531             if (curlen)
3532                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3533             else
3534                 pos2_is_uv = 0;
3535         } else {  /* len_iv >= 0 */
3536             if (!pos1_is_uv && pos1_iv < 0) {
3537                 pos2_iv = pos1_iv + len_iv;
3538                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3539             } else {
3540                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3541                     pos2_iv = curlen;
3542                 else
3543                     pos2_iv = pos1_iv+len_iv;
3544                 pos2_is_uv = 1;
3545             }
3546         }
3547     }
3548     else {
3549         pos2_iv = curlen;
3550         pos2_is_uv = 1;
3551     }
3552
3553     if (!pos2_is_uv && pos2_iv < 0) {
3554         if (!pos1_is_uv && pos1_iv < 0)
3555             return FALSE;
3556         pos2_iv = 0;
3557     }
3558     else if (!pos1_is_uv && pos1_iv < 0)
3559         pos1_iv = 0;
3560
3561     if ((UV)pos2_iv < (UV)pos1_iv)
3562         pos2_iv = pos1_iv;
3563     if ((UV)pos2_iv > curlen)
3564         pos2_iv = curlen;
3565
3566     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3567     *posp = (STRLEN)( (UV)pos1_iv );
3568     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3569
3570     return TRUE;
3571 }
3572
3573 PP_wrapped(pp_substr,
3574                 (PL_op->op_private & 7)
3575               + ((PL_op->op_private & OPpSUBSTR_REPL_FIRST) ? 1 : 0),
3576             0)
3577 {
3578     dSP; dTARGET;
3579     SV *sv;
3580     STRLEN curlen;
3581     STRLEN utf8_curlen;
3582     SV *   pos_sv;
3583     IV     pos1_iv;
3584     int    pos1_is_uv;
3585     SV *   len_sv;
3586     IV     len_iv = 0;
3587     int    len_is_uv = 0;
3588     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3589     const bool rvalue = (GIMME_V != G_VOID);
3590     const char *tmps;
3591     SV *repl_sv = NULL;
3592     const char *repl = NULL;
3593     STRLEN repl_len;
3594     int num_args = PL_op->op_private & 7;
3595     bool repl_need_utf8_upgrade = FALSE;
3596
3597     if (num_args > 2) {
3598         if (num_args > 3) {
3599           if(!(repl_sv = POPs)) num_args--;
3600         }
3601         if ((len_sv = POPs)) {
3602             len_iv    = SvIV(len_sv);
3603             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3604         }
3605         else num_args--;
3606     }
3607     pos_sv     = POPs;
3608     pos1_iv    = SvIV(pos_sv);
3609     pos1_is_uv = SvIOK_UV(pos_sv);
3610     sv = POPs;
3611     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3612         assert(!repl_sv);
3613         repl_sv = POPs;
3614     }
3615     if (lvalue && !repl_sv) {
3616         SV * ret;
3617         ret = newSV_type_mortal(SVt_PVLV);  /* Not TARG RT#67838 */
3618         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3619         LvTYPE(ret) = 'x';
3620         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3621         LvTARGOFF(ret) =
3622             pos1_is_uv || pos1_iv >= 0
3623                 ? (STRLEN)(UV)pos1_iv
3624                 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3625         LvTARGLEN(ret) =
3626             len_is_uv || len_iv > 0
3627                 ? (STRLEN)(UV)len_iv
3628                 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3629
3630         PUSHs(ret);    /* avoid SvSETMAGIC here */
3631         RETURN;
3632     }
3633     if (repl_sv) {
3634         repl = SvPV_const(repl_sv, repl_len);
3635         SvGETMAGIC(sv);
3636         if (SvROK(sv))
3637             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3638                             "Attempt to use reference as lvalue in substr"
3639             );
3640         tmps = SvPV_force_nomg(sv, curlen);
3641         if (DO_UTF8(repl_sv) && repl_len) {
3642             if (!DO_UTF8(sv)) {
3643                 /* Upgrade the dest, and recalculate tmps in case the buffer
3644                  * got reallocated; curlen may also have been changed */
3645                 sv_utf8_upgrade_nomg(sv);
3646                 tmps = SvPV_nomg(sv, curlen);
3647             }
3648         }
3649         else if (DO_UTF8(sv))
3650             repl_need_utf8_upgrade = TRUE;
3651     }
3652     else tmps = SvPV_const(sv, curlen);
3653     if (DO_UTF8(sv)) {
3654         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3655         if (utf8_curlen == curlen)
3656             utf8_curlen = 0;
3657         else
3658             curlen = utf8_curlen;
3659     }
3660     else
3661         utf8_curlen = 0;
3662
3663     {
3664         STRLEN pos, len, byte_len, byte_pos;
3665
3666         if (!translate_substr_offsets(
3667                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3668         )) goto bound_fail;
3669
3670         byte_len = len;
3671         byte_pos = utf8_curlen
3672             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3673
3674         tmps += byte_pos;
3675
3676         if (rvalue) {
3677             SvTAINTED_off(TARG);                        /* decontaminate */
3678             SvUTF8_off(TARG);                   /* decontaminate */
3679             sv_setpvn(TARG, tmps, byte_len);
3680 #ifdef USE_LOCALE_COLLATE
3681             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3682 #endif
3683             if (utf8_curlen)
3684                 SvUTF8_on(TARG);
3685         }
3686
3687         if (repl) {
3688             SV* repl_sv_copy = NULL;
3689
3690             if (repl_need_utf8_upgrade) {
3691                 repl_sv_copy = newSVsv(repl_sv);
3692                 sv_utf8_upgrade(repl_sv_copy);
3693                 repl = SvPV_const(repl_sv_copy, repl_len);
3694             }
3695             if (!SvOK(sv))
3696                 SvPVCLEAR(sv);
3697             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3698             SvREFCNT_dec(repl_sv_copy);
3699         }
3700     }
3701     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3702         SP++;
3703     else if (rvalue) {
3704         SvSETMAGIC(TARG);
3705         PUSHs(TARG);
3706     }
3707     RETURN;
3708
3709   bound_fail:
3710     if (repl)
3711         Perl_croak(aTHX_ "substr outside of string");
3712     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3713     RETPUSHUNDEF;
3714 }
3715
3716 PP_wrapped(pp_vec, 3, 0)
3717 {
3718     dSP;
3719     const IV size   = POPi;
3720     SV* offsetsv   = POPs;
3721     SV * const src = POPs;
3722     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3723     SV * ret;
3724     UV   retuv;
3725     STRLEN offset = 0;
3726     char errflags = 0;
3727
3728     /* extract a STRLEN-ranged integer value from offsetsv into offset,
3729      * or flag that its out of range */
3730     {
3731         IV iv = SvIV(offsetsv);
3732
3733         /* avoid a large UV being wrapped to a negative value */
3734         if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3735             errflags = LVf_OUT_OF_RANGE;
3736         else if (iv < 0)
3737             errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3738 #if PTRSIZE < IVSIZE
3739         else if (iv > Size_t_MAX)
3740             errflags = LVf_OUT_OF_RANGE;
3741 #endif
3742         else
3743             offset = (STRLEN)iv;
3744     }
3745
3746     retuv = errflags ? 0 : do_vecget(src, offset, size);
3747
3748     if (lvalue) {                       /* it's an lvalue! */
3749         ret = newSV_type_mortal(SVt_PVLV);  /* Not TARG RT#67838 */
3750         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3751         LvTYPE(ret) = 'v';
3752         LvTARG(ret) = SvREFCNT_inc_simple(src);
3753         LvTARGOFF(ret) = offset;
3754         LvTARGLEN(ret) = size;
3755         LvFLAGS(ret)   = errflags;
3756     }
3757     else {
3758         dTARGET;
3759         SvTAINTED_off(TARG);            /* decontaminate */
3760         ret = TARG;
3761     }
3762
3763     sv_setuv(ret, retuv);
3764     if (!lvalue)
3765         SvSETMAGIC(ret);
3766     PUSHs(ret);
3767     RETURN;
3768 }
3769
3770
3771 /* also used for: pp_rindex() */
3772
3773 PP_wrapped(pp_index, MAXARG, 0)
3774 {
3775     dSP; dTARGET;
3776     SV *big;
3777     SV *little;
3778     SV *temp = NULL;
3779     STRLEN biglen;
3780     STRLEN llen = 0;
3781     SSize_t offset = 0;
3782     SSize_t retval;
3783     const char *big_p;
3784     const char *little_p;
3785     bool big_utf8;
3786     bool little_utf8;
3787     const bool is_index = PL_op->op_type == OP_INDEX;
3788     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3789
3790     if (threeargs)
3791         offset = POPi;
3792     little = POPs;
3793     big = POPs;
3794     big_p = SvPV_const(big, biglen);
3795     little_p = SvPV_const(little, llen);
3796
3797     big_utf8 = DO_UTF8(big);
3798     little_utf8 = DO_UTF8(little);
3799     if (big_utf8 ^ little_utf8) {
3800         /* One needs to be upgraded.  */
3801         if (little_utf8) {
3802             /* Well, maybe instead we might be able to downgrade the small
3803                string?  */
3804             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3805                                                      &little_utf8);
3806             if (little_utf8) {
3807                 /* If the large string is ISO-8859-1, and it's not possible to
3808                    convert the small string to ISO-8859-1, then there is no
3809                    way that it could be found anywhere by index.  */
3810                 retval = -1;
3811                 goto push_result;
3812             }
3813
3814             /* At this point, pv is a malloc()ed string. So donate it to temp
3815                to ensure it will get free()d  */
3816             little = temp = newSV_type(SVt_NULL);
3817             sv_usepvn(temp, pv, llen);
3818             little_p = SvPVX(little);
3819         } else {
3820             temp = newSVpvn(little_p, llen);
3821
3822             sv_utf8_upgrade(temp);
3823             little = temp;
3824             little_p = SvPV_const(little, llen);
3825         }
3826     }
3827     if (SvGAMAGIC(big)) {
3828         /* Life just becomes a lot easier if I use a temporary here.
3829            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3830            will trigger magic and overloading again, as will fbm_instr()
3831         */
3832         big = newSVpvn_flags(big_p, biglen,
3833                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3834         big_p = SvPVX(big);
3835     }
3836     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3837         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3838            warn on undef, and we've already triggered a warning with the
3839            SvPV_const some lines above. We can't remove that, as we need to
3840            call some SvPV to trigger overloading early and find out if the
3841            string is UTF-8.
3842            This is all getting too messy. The API isn't quite clean enough,
3843            because data access has side effects.
3844         */
3845         little = newSVpvn_flags(little_p, llen,
3846                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3847         little_p = SvPVX(little);
3848     }
3849
3850     if (!threeargs)
3851         offset = is_index ? 0 : biglen;
3852     else {
3853         if (big_utf8 && offset > 0)
3854             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3855         if (!is_index)
3856             offset += llen;
3857     }
3858     if (offset < 0)
3859         offset = 0;
3860     else if (offset > (SSize_t)biglen)
3861         offset = biglen;
3862     if (!(little_p = is_index
3863           ? fbm_instr((unsigned char*)big_p + offset,
3864                       (unsigned char*)big_p + biglen, little, 0)
3865           : rninstr(big_p,  big_p  + offset,
3866                     little_p, little_p + llen)))
3867         retval = -1;
3868     else {
3869         retval = little_p - big_p;
3870         if (retval > 1 && big_utf8)
3871             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3872     }
3873     SvREFCNT_dec(temp);
3874
3875   push_result:
3876     /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3877     if (PL_op->op_private & OPpTRUEBOOL) {
3878         SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3879             ? &PL_sv_yes : &PL_sv_no;
3880         if (PL_op->op_private & OPpTARGET_MY) {
3881             /* $lex = (index() == -1) */
3882             sv_setsv_mg(TARG, result);
3883             PUSHs(TARG);
3884         }
3885         else {
3886             PUSHs(result);
3887         }
3888     }
3889     else
3890         PUSHi(retval);
3891     RETURN;
3892 }
3893
3894 PP_wrapped(pp_sprintf, 0, 1)
3895 {
3896     dSP; dMARK; dORIGMARK; dTARGET;
3897     SvTAINTED_off(TARG);
3898     do_sprintf(TARG, SP-MARK, MARK+1);
3899     TAINT_IF(SvTAINTED(TARG));
3900     SP = ORIGMARK;
3901     PUSHTARG;
3902     RETURN;
3903 }
3904
3905 PP(pp_ord)
3906 {
3907     dTARGET;
3908
3909     SV *argsv = *PL_stack_sp;
3910     STRLEN len;
3911     const U8 *s = (U8*)SvPV_const(argsv, len);
3912
3913     TARGu(DO_UTF8(argsv)
3914            ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3915            : (UV)(*s),
3916         1);
3917
3918     rpp_replace_1_1(TARG);
3919     return NORMAL;
3920 }
3921
3922 PP(pp_chr)
3923 {
3924     dTARGET;
3925     char *tmps;
3926     UV value;
3927     SV *top = *PL_stack_sp;
3928
3929     SvGETMAGIC(top);
3930     if (UNLIKELY(SvAMAGIC(top)))
3931         top = sv_2num(top);
3932     if (UNLIKELY(isinfnansv(top)))
3933         Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3934     else {
3935         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3936             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3937                 ||
3938                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3939                  && SvNV_nomg(top) < 0.0)))
3940         {
3941             if (ckWARN(WARN_UTF8)) {
3942                 if (SvGMAGICAL(top)) {
3943                     SV *top2 = sv_newmortal();
3944                     sv_setsv_nomg(top2, top);
3945                     top = top2;
3946                 }
3947                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3948                             "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3949             }
3950             value = UNICODE_REPLACEMENT;
3951         } else {
3952             value = SvUV_nomg(top);
3953         }
3954     }
3955
3956     SvUPGRADE(TARG,SVt_PV);
3957
3958     if (value > 255 && !IN_BYTES) {
3959         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3960         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3961         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3962         *tmps = '\0';
3963         (void)SvPOK_only(TARG);
3964         SvUTF8_on(TARG);
3965         goto ret;
3966     }
3967
3968     SvGROW(TARG,2);
3969     SvCUR_set(TARG, 1);
3970     tmps = SvPVX(TARG);
3971     *tmps++ = (char)value;
3972     *tmps = '\0';
3973     (void)SvPOK_only(TARG);
3974
3975   ret:
3976     SvSETMAGIC(TARG);
3977     rpp_replace_1_1(TARG);
3978     return NORMAL;
3979 }
3980
3981
3982 PP(pp_crypt)
3983 {
3984 #ifdef HAS_CRYPT
3985     dTARGET;
3986     SV *right = PL_stack_sp[0];
3987     SV *left  = PL_stack_sp[-1];
3988     STRLEN len;
3989     const char *tmps = SvPV_const(left, len);
3990
3991     if (DO_UTF8(left)) {
3992          /* If Unicode, try to downgrade.
3993           * If not possible, croak.
3994           * Yes, we made this up.  */
3995          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3996
3997          (void)sv_utf8_downgrade(tsv, FALSE);
3998          tmps = SvPV_const(tsv, len);
3999     }
4000 #  ifdef USE_ITHREADS
4001 #    ifdef HAS_CRYPT_R
4002     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
4003       /* This should be threadsafe because in ithreads there is only
4004        * one thread per interpreter.  If this would not be true,
4005        * we would need a mutex to protect this malloc. */
4006         PL_reentrant_buffer->_crypt_struct_buffer =
4007           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
4008 #      if defined(__GLIBC__) || defined(__EMX__)
4009         if (PL_reentrant_buffer->_crypt_struct_buffer) {
4010             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
4011         }
4012 #      endif
4013     }
4014 #    endif /* HAS_CRYPT_R */
4015 #  endif /* USE_ITHREADS */
4016
4017     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
4018
4019     SvUTF8_off(TARG);
4020     SvSETMAGIC(TARG);
4021     rpp_replace_2_1(targ);
4022     return NORMAL;
4023 #else
4024     DIE(aTHX_
4025       "The crypt() function is unimplemented due to excessive paranoia.");
4026 #endif
4027 }
4028
4029
4030 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
4031  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
4032
4033
4034 /* also used for: pp_lcfirst() */
4035
4036 PP_wrapped(pp_ucfirst, 1, 0)
4037 {
4038     /* Actually is both lcfirst() and ucfirst().  Only the first character
4039      * changes.  This means that possibly we can change in-place, ie., just
4040      * take the source and change that one character and store it back, but not
4041      * if read-only etc, or if the length changes */
4042
4043     dSP;
4044     SV *source = TOPs;
4045     STRLEN slen; /* slen is the byte length of the whole SV. */
4046     STRLEN need;
4047     SV *dest;
4048     bool inplace;   /* ? Convert first char only, in-place */
4049     bool doing_utf8 = FALSE;               /* ? using utf8 */
4050     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
4051     const int op_type = PL_op->op_type;
4052     const U8 *s;
4053     U8 *d;
4054     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4055     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
4056                      * stored as UTF-8 at s. */
4057     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
4058                      * lowercased) character stored in tmpbuf.  May be either
4059                      * UTF-8 or not, but in either case is the number of bytes */
4060     bool remove_dot_above = FALSE;
4061
4062     s = (const U8*)SvPV_const(source, slen);
4063
4064     /* We may be able to get away with changing only the first character, in
4065      * place, but not if read-only, etc.  Later we may discover more reasons to
4066      * not convert in-place. */
4067     inplace = !SvREADONLY(source) && SvPADTMP(source);
4068
4069 #ifdef USE_LOCALE_CTYPE
4070
4071     if (IN_LC_RUNTIME(LC_CTYPE)) {
4072         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
4073     }
4074
4075 #endif
4076
4077     /* First calculate what the changed first character should be.  This affects
4078      * whether we can just swap it out, leaving the rest of the string unchanged,
4079      * or even if have to convert the dest to UTF-8 when the source isn't */
4080
4081     if (! slen) {   /* If empty */
4082         need = 1; /* still need a trailing NUL */
4083         ulen = 0;
4084         *tmpbuf = '\0';
4085     }
4086     else if (DO_UTF8(source)) { /* Is the source utf8? */
4087         doing_utf8 = TRUE;
4088         ulen = UTF8SKIP(s);
4089
4090         if (op_type == OP_UCFIRST) {
4091 #ifdef USE_LOCALE_CTYPE
4092             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
4093 #else
4094             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
4095 #endif
4096         }
4097         else {
4098
4099 #ifdef USE_LOCALE_CTYPE
4100
4101             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
4102
4103             /* In turkic locales, lower casing an 'I' normally yields U+0131,
4104              * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also
4105              * contains a COMBINING DOT ABOVE.  Instead it is treated like
4106              * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'.  The
4107              * call to lowercase above has handled this.  But SpecialCasing.txt
4108              * says we are supposed to remove the COMBINING DOT ABOVE.  We can
4109              * tell if we have this situation if I ==> i in a turkic locale. */
4110             if (   UNLIKELY(IN_UTF8_TURKIC_LOCALE)
4111                 && IN_LC_RUNTIME(LC_CTYPE)
4112                 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')))
4113             {
4114                 /* Here, we know there was a COMBINING DOT ABOVE.  We won't be
4115                  * able to handle this in-place. */
4116                 inplace = FALSE;
4117
4118                 /* It seems likely that the DOT will immediately follow the
4119                  * 'I'.  If so, we can remove it simply by indicating to the
4120                  * code below to start copying the source just beyond the DOT.
4121                  * We know its length is 2 */
4122                 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) {
4123                     ulen += 2;
4124                 }
4125                 else {  /* But if it doesn't follow immediately, set a flag for
4126                            the code below */
4127                     remove_dot_above = TRUE;
4128                 }
4129             }
4130 #else
4131             PERL_UNUSED_VAR(remove_dot_above);
4132
4133             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
4134 #endif
4135
4136         }
4137
4138         /* we can't do in-place if the length changes.  */
4139         if (ulen != tculen) inplace = FALSE;
4140         need = slen + 1 - ulen + tculen;
4141     }
4142     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
4143             * latin1 is treated as caseless.  Note that a locale takes
4144             * precedence */
4145         ulen = 1;       /* Original character is 1 byte */
4146         tculen = 1;     /* Most characters will require one byte, but this will
4147                          * need to be overridden for the tricky ones */
4148         need = slen + 1;
4149
4150
4151 #ifdef USE_LOCALE_CTYPE
4152
4153         if (IN_LC_RUNTIME(LC_CTYPE)) {
4154             if (    UNLIKELY(IN_UTF8_TURKIC_LOCALE)
4155                 && (   (op_type == OP_LCFIRST && UNLIKELY(*s == 'I'))
4156                     || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i'))))
4157             {
4158                 if (*s == 'I') { /* lcfirst('I') */
4159                     tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4160                     tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4161                 }
4162                 else {  /* ucfirst('i') */
4163                     tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4164                     tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4165                 }
4166                 tculen = 2;
4167                 inplace = FALSE;
4168                 doing_utf8 = TRUE;
4169                 convert_source_to_utf8 = TRUE;
4170                 need += variant_under_utf8_count(s, s + slen);
4171             }
4172             else if (op_type == OP_LCFIRST) {
4173
4174                 /* For lc, there are no gotchas for UTF-8 locales (other than
4175                  * the turkish ones already handled above) */
4176                 *tmpbuf = toLOWER_LC(*s);
4177             }
4178             else { /* ucfirst */
4179
4180                 /* But for uc, some characters require special handling */
4181                 if (IN_UTF8_CTYPE_LOCALE) {
4182                     goto do_uni_rules;
4183                 }
4184
4185                 /* This would be a bug if any locales have upper and title case
4186                  * different */
4187                 *tmpbuf = (U8) toUPPER_LC(*s);
4188             }
4189         }
4190         else
4191 #endif
4192         /* Here, not in locale.  If not using Unicode rules, is a simple
4193          * lower/upper, depending */
4194         if (! IN_UNI_8_BIT) {
4195             *tmpbuf = (op_type == OP_LCFIRST)
4196                       ? toLOWER(*s)
4197                       : toUPPER(*s);
4198         }
4199         else if (op_type == OP_LCFIRST) {
4200             /* lower case the first letter: no trickiness for any character */
4201             *tmpbuf = toLOWER_LATIN1(*s);
4202         }
4203         else {
4204             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
4205              * non-turkic UTF-8, which we treat as not in locale), and cased
4206              * latin1 */
4207             UV title_ord;
4208 #ifdef USE_LOCALE_CTYPE
4209       do_uni_rules:
4210 #endif
4211
4212             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
4213             if (tculen > 1) {
4214                 assert(tculen == 2);
4215
4216                 /* If the result is an upper Latin1-range character, it can
4217                  * still be represented in one byte, which is its ordinal */
4218                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
4219                     *tmpbuf = (U8) title_ord;
4220                     tculen = 1;
4221                 }
4222                 else {
4223                     /* Otherwise it became more than one ASCII character (in
4224                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
4225                      * beyond Latin1, so the number of bytes changed, so can't
4226                      * replace just the first character in place. */
4227                     inplace = FALSE;
4228
4229                     /* If the result won't fit in a byte, the entire result
4230                      * will have to be in UTF-8.  Allocate enough space for the
4231                      * expanded first byte, and if UTF-8, the rest of the input
4232                      * string, some or all of which may also expand to two
4233                      * bytes, plus the terminating NUL. */
4234                     if (title_ord > 255) {
4235                         doing_utf8 = TRUE;
4236                         convert_source_to_utf8 = TRUE;
4237                         need = slen
4238                             + variant_under_utf8_count(s, s + slen)
4239                             + 1;
4240
4241                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
4242                          * characters whose title case is above 255 is
4243                          * 2. */
4244                         ulen = 2;
4245                     }
4246                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
4247                         need = slen + 1 + 1;
4248                     }
4249                 }
4250             }
4251         } /* End of use Unicode (Latin1) semantics */
4252     } /* End of changing the case of the first character */
4253
4254     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
4255      * generate the result */
4256     if (inplace) {
4257
4258         /* We can convert in place.  This means we change just the first
4259          * character without disturbing the rest; no need to grow */
4260         dest = source;
4261         s = d = (U8*)SvPV_force_nomg(source, slen);
4262     } else {
4263         dTARGET;
4264
4265         dest = TARG;
4266
4267         /* Here, we can't convert in place; we earlier calculated how much
4268          * space we will need, so grow to accommodate that */
4269         SvUPGRADE(dest, SVt_PV);
4270         d = (U8*)SvGROW(dest, need);
4271         (void)SvPOK_only(dest);
4272
4273         SETs(dest);
4274     }
4275
4276     if (doing_utf8) {
4277         if (! inplace) {
4278             if (! convert_source_to_utf8) {
4279
4280                 /* Here  both source and dest are in UTF-8, but have to create
4281                  * the entire output.  We initialize the result to be the
4282                  * title/lower cased first character, and then append the rest
4283                  * of the string. */
4284                 sv_setpvn(dest, (char*)tmpbuf, tculen);
4285                 if (slen > ulen) {
4286
4287                     /* But this boolean being set means we are in a turkic
4288                      * locale, and there is a DOT character that needs to be
4289                      * removed, and it isn't immediately after the current
4290                      * character.  Keep concatenating characters to the output
4291                      * one at a time, until we find the DOT, which we simply
4292                      * skip */
4293                     if (UNLIKELY(remove_dot_above)) {
4294                         do {
4295                             Size_t this_len = UTF8SKIP(s + ulen);
4296
4297                             sv_catpvn(dest, (char*)(s + ulen), this_len);
4298
4299                             ulen += this_len;
4300                             if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) {
4301                                 ulen += 2;
4302                                 break;
4303                             }
4304                         } while (s + ulen < s + slen);
4305                     }
4306
4307                     /* The rest of the string can be concatenated unchanged,
4308                      * all at once */
4309                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
4310                 }
4311             }
4312             else {
4313                 const U8 *const send = s + slen;
4314
4315                 /* Here the dest needs to be in UTF-8, but the source isn't,
4316                  * except we earlier UTF-8'd the first character of the source
4317                  * into tmpbuf.  First put that into dest, and then append the
4318                  * rest of the source, converting it to UTF-8 as we go. */
4319
4320                 /* Assert tculen is 2 here because the only characters that
4321                  * get to this part of the code have 2-byte UTF-8 equivalents */
4322                 assert(tculen == 2);
4323                 *d++ = *tmpbuf;
4324                 *d++ = *(tmpbuf + 1);
4325                 s++;    /* We have just processed the 1st char */
4326
4327                 while (s < send) {
4328                     append_utf8_from_native_byte(*s, &d);
4329                     s++;
4330                 }
4331
4332                 *d = '\0';
4333                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4334             }
4335             SvUTF8_on(dest);
4336         }
4337         else {   /* in-place UTF-8.  Just overwrite the first character */
4338             Copy(tmpbuf, d, tculen, U8);
4339             SvCUR_set(dest, need - 1);
4340         }
4341
4342     }
4343     else {  /* Neither source nor dest are, nor need to be UTF-8 */
4344         if (slen) {
4345             if (inplace) {  /* in-place, only need to change the 1st char */
4346                 *d = *tmpbuf;
4347             }
4348             else {      /* Not in-place */
4349
4350                 /* Copy the case-changed character(s) from tmpbuf */
4351                 Copy(tmpbuf, d, tculen, U8);
4352                 d += tculen - 1; /* Code below expects d to point to final
4353                                   * character stored */
4354             }
4355         }
4356         else {  /* empty source */
4357             /* See bug #39028: Don't taint if empty  */
4358             *d = *s;
4359         }
4360
4361         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4362          * the destination to retain that flag */
4363         if (DO_UTF8(source))
4364             SvUTF8_on(dest);
4365
4366         if (!inplace) { /* Finish the rest of the string, unchanged */
4367             /* This will copy the trailing NUL  */
4368             Copy(s + 1, d + 1, slen, U8);
4369             SvCUR_set(dest, need - 1);
4370         }
4371     }
4372 #ifdef USE_LOCALE_CTYPE
4373     if (IN_LC_RUNTIME(LC_CTYPE)) {
4374         TAINT;
4375         SvTAINTED_on(dest);
4376     }
4377 #endif
4378     if (dest != source && SvTAINTED(source))
4379         SvTAINT(dest);
4380     SvSETMAGIC(dest);
4381     return NORMAL;
4382 }
4383
4384
4385 PP_wrapped(pp_uc, 1, 0)
4386 {
4387     dSP;
4388     SV *source = TOPs;
4389     STRLEN len;
4390     STRLEN min;
4391     SV *dest;
4392     const U8 *s;
4393     U8 *d;
4394
4395     SvGETMAGIC(source);
4396
4397     if (   SvPADTMP(source)
4398         && !SvREADONLY(source) && SvPOK(source)
4399         && !DO_UTF8(source)
4400         && (
4401 #ifdef USE_LOCALE_CTYPE
4402             (IN_LC_RUNTIME(LC_CTYPE))
4403             ? ! IN_UTF8_CTYPE_LOCALE
4404             :
4405 #endif
4406               ! IN_UNI_8_BIT))
4407     {
4408
4409         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4410          * make the loop tight, so we overwrite the source with the dest before
4411          * looking at it, and we need to look at the original source
4412          * afterwards.  There would also need to be code added to handle
4413          * switching to not in-place in midstream if we run into characters
4414          * that change the length.  Since being in locale overrides UNI_8_BIT,
4415          * that latter becomes irrelevant in the above test; instead for
4416          * locale, the size can't normally change, except if the locale is a
4417          * UTF-8 one */
4418         dest = source;
4419         s = d = (U8*)SvPV_force_nomg(source, len);
4420         min = len + 1;
4421     } else {
4422         dTARGET;
4423
4424         dest = TARG;
4425
4426         s = (const U8*)SvPV_nomg_const(source, len);
4427         min = len + 1;
4428
4429         SvUPGRADE(dest, SVt_PV);
4430         d = (U8*)SvGROW(dest, min);
4431         (void)SvPOK_only(dest);
4432
4433         SETs(dest);
4434     }
4435
4436 #ifdef USE_LOCALE_CTYPE
4437
4438     if (IN_LC_RUNTIME(LC_CTYPE)) {
4439         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
4440     }
4441
4442 #endif
4443
4444     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4445        to check DO_UTF8 again here.  */
4446
4447     if (DO_UTF8(source)) {
4448         const U8 *const send = s + len;
4449         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4450
4451 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4452 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4453         /* All occurrences of these are to be moved to follow any other marks.
4454          * This is context-dependent.  We may not be passed enough context to
4455          * move the iota subscript beyond all of them, but we do the best we can
4456          * with what we're given.  The result is always better than if we
4457          * hadn't done this.  And, the problem would only arise if we are
4458          * passed a character without all its combining marks, which would be
4459          * the caller's mistake.  The information this is based on comes from a
4460          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4461          * itself) and so can't be checked properly to see if it ever gets
4462          * revised.  But the likelihood of it changing is remote */
4463         bool in_iota_subscript = FALSE;
4464
4465         while (s < send) {
4466             STRLEN u;
4467             STRLEN ulen;
4468             UV uv;
4469             if (UNLIKELY(in_iota_subscript)) {
4470                 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4471
4472                 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4473
4474                     /* A non-mark.  Time to output the iota subscript */
4475                     *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4476                     *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4477                     in_iota_subscript = FALSE;
4478                 }
4479             }
4480
4481             /* Then handle the current character.  Get the changed case value
4482              * and copy it to the output buffer */
4483
4484             u = UTF8SKIP(s);
4485 #ifdef USE_LOCALE_CTYPE
4486             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4487 #else
4488             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4489 #endif
4490             if (uv == GREEK_CAPITAL_LETTER_IOTA
4491                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4492             {
4493                 in_iota_subscript = TRUE;
4494             }
4495             else {
4496                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4497                     /* If the eventually required minimum size outgrows the
4498                      * available space, we need to grow. */
4499                     const UV o = d - (U8*)SvPVX_const(dest);
4500
4501                     /* If someone uppercases one million U+03B0s we SvGROW()
4502                      * one million times.  Or we could try guessing how much to
4503                      * allocate without allocating too much.  But we can't
4504                      * really guess without examining the rest of the string.
4505                      * Such is life.  See corresponding comment in lc code for
4506                      * another option */
4507                     d = o + (U8*) SvGROW(dest, min);
4508                 }
4509                 Copy(tmpbuf, d, ulen, U8);
4510                 d += ulen;
4511             }
4512             s += u;
4513         }
4514         if (in_iota_subscript) {
4515             *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4516             *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4517         }
4518         SvUTF8_on(dest);
4519         *d = '\0';
4520
4521         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4522     }
4523     else {      /* Not UTF-8 */
4524         if (len) {
4525             const U8 *const send = s + len;
4526
4527             /* Use locale casing if in locale; regular style if not treating
4528              * latin1 as having case; otherwise the latin1 casing.  Do the
4529              * whole thing in a tight loop, for speed, */
4530 #ifdef USE_LOCALE_CTYPE
4531             if (IN_LC_RUNTIME(LC_CTYPE)) {
4532                 if (IN_UTF8_CTYPE_LOCALE) {
4533                     goto do_uni_rules;
4534                 }
4535                 for (; s < send; d++, s++)
4536                     *d = (U8) toUPPER_LC(*s);
4537             }
4538             else
4539 #endif
4540                  if (! IN_UNI_8_BIT) {
4541                 for (; s < send; d++, s++) {
4542                     *d = toUPPER(*s);
4543                 }
4544             }
4545             else {
4546 #ifdef USE_LOCALE_CTYPE
4547           do_uni_rules:
4548 #endif
4549                 for (; s < send; d++, s++) {
4550                     Size_t extra;
4551
4552                     *d = toUPPER_LATIN1_MOD(*s);
4553                     if (   LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4554
4555 #ifdef USE_LOCALE_CTYPE
4556
4557                         && (LIKELY(   ! IN_UTF8_TURKIC_LOCALE
4558                                    || ! IN_LC_RUNTIME(LC_CTYPE))
4559                                    || *s != 'i')
4560 #endif
4561
4562                     ) {
4563                         continue;
4564                     }
4565
4566                     /* The mainstream case is the tight loop above.  To avoid
4567                      * extra tests in that, all three characters that always
4568                      * require special handling are mapped by the MOD to the
4569                      * one tested just above.  Use the source to distinguish
4570                      * between those cases */
4571
4572 #if    UNICODE_MAJOR_VERSION > 2                                        \
4573    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4574                                   && UNICODE_DOT_DOT_VERSION >= 8)
4575                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4576
4577                         /* uc() of this requires 2 characters, but they are
4578                          * ASCII.  If not enough room, grow the string */
4579                         if (SvLEN(dest) < ++min) {
4580                             const UV o = d - (U8*)SvPVX_const(dest);
4581                             d = o + (U8*) SvGROW(dest, min);
4582                         }
4583                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4584                         continue;   /* Back to the tight loop; still in ASCII */
4585                     }
4586 #endif
4587
4588                     /* The other special handling characters have their
4589                      * upper cases outside the latin1 range, hence need to be
4590                      * in UTF-8, so the whole result needs to be in UTF-8.
4591                      *
4592                      * So, here we are somewhere in the middle of processing a
4593                      * non-UTF-8 string, and realize that we will have to
4594                      * convert the whole thing to UTF-8.  What to do?  There
4595                      * are several possibilities.  The simplest to code is to
4596                      * convert what we have so far, set a flag, and continue on
4597                      * in the loop.  The flag would be tested each time through
4598                      * the loop, and if set, the next character would be
4599                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4600                      * to slow down the mainstream case at all for this fairly
4601                      * rare case, so I didn't want to add a test that didn't
4602                      * absolutely have to be there in the loop, besides the
4603                      * possibility that it would get too complicated for
4604                      * optimizers to deal with.  Another possibility is to just
4605                      * give up, convert the source to UTF-8, and restart the
4606                      * function that way.  Another possibility is to convert
4607                      * both what has already been processed and what is yet to
4608                      * come separately to UTF-8, then jump into the loop that
4609                      * handles UTF-8.  But the most efficient time-wise of the
4610                      * ones I could think of is what follows, and turned out to
4611                      * not require much extra code.
4612                      *
4613                      * First, calculate the extra space needed for the
4614                      * remainder of the source needing to be in UTF-8.  Except
4615                      * for the 'i' in Turkic locales, in UTF-8 strings, the
4616                      * uppercase of a character below 256 occupies the same
4617                      * number of bytes as the original.  Therefore, the space
4618                      * needed is the that number plus the number of characters
4619                      * that become two bytes when converted to UTF-8, plus, in
4620                      * turkish locales, the number of 'i's. */
4621
4622                     extra = send - s + variant_under_utf8_count(s, send);
4623
4624 #ifdef USE_LOCALE_CTYPE
4625
4626                     if (UNLIKELY(*s == 'i')) {  /* We wouldn't get an 'i' here
4627                                                    unless are in a Turkic
4628                                                    locale */
4629                         const U8 * s_peek = s;
4630
4631                         do {
4632                             extra++;
4633
4634                             s_peek = (U8 *) memchr(s_peek + 1, 'i',
4635                                                    send - (s_peek + 1));
4636                         } while (s_peek != NULL);
4637                     }
4638 #endif
4639
4640                     /* Convert what we have so far into UTF-8, telling the
4641                      * function that we know it should be converted, and to
4642                      * allow extra space for what we haven't processed yet.
4643                      *
4644                      * This may cause the string pointer to move, so need to
4645                      * save and re-find it. */
4646
4647                     len = d - (U8*)SvPVX_const(dest);
4648                     SvCUR_set(dest, len);
4649                     len = sv_utf8_upgrade_flags_grow(dest,
4650                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4651                                                 extra
4652                                               + 1 /* trailing NUL */ );
4653                     d = (U8*)SvPVX(dest) + len;
4654
4655                     /* Now process the remainder of the source, simultaneously
4656                      * converting to upper and UTF-8.
4657                      *
4658                      * To avoid extra tests in the loop body, and since the
4659                      * loop is so simple, split out the rare Turkic case into
4660                      * its own loop */
4661
4662 #ifdef USE_LOCALE_CTYPE
4663                     if (   UNLIKELY(IN_UTF8_TURKIC_LOCALE)
4664                         && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4665                     {
4666                         for (; s < send; s++) {
4667                             if (*s == 'i') {
4668                                 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4669                                 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4670                             }
4671                             else {
4672                                 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4673                                 d += len;
4674                             }
4675                         }
4676                     }
4677                     else
4678 #endif
4679                         for (; s < send; s++) {
4680                             (void) _to_upper_title_latin1(*s, d, &len, 'S');
4681                             d += len;
4682                         }
4683
4684                     /* Here have processed the whole source; no need to
4685                      * continue with the outer loop.  Each character has been
4686                      * converted to upper case and converted to UTF-8. */
4687                     break;
4688                 } /* End of processing all latin1-style chars */
4689             } /* End of processing all chars */
4690         } /* End of source is not empty */
4691
4692         if (source != dest) {
4693             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4694             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4695         }
4696     } /* End of isn't utf8 */
4697 #ifdef USE_LOCALE_CTYPE
4698     if (IN_LC_RUNTIME(LC_CTYPE)) {
4699         TAINT;
4700         SvTAINTED_on(dest);
4701     }
4702 #endif
4703     if (dest != source && SvTAINTED(source))
4704         SvTAINT(dest);
4705     SvSETMAGIC(dest);
4706     return NORMAL;
4707 }
4708
4709 PP_wrapped(pp_lc, 1, 0)
4710 {
4711     dSP;
4712     SV *source = TOPs;
4713     STRLEN len;
4714     STRLEN min;
4715     SV *dest;
4716     const U8 *s;
4717     U8 *d;
4718     bool has_turkic_I = FALSE;
4719
4720     SvGETMAGIC(source);
4721
4722     if (   SvPADTMP(source)
4723         && !SvREADONLY(source) && SvPOK(source)
4724         && !DO_UTF8(source)
4725
4726 #ifdef USE_LOCALE_CTYPE
4727
4728         && (   LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4729             || LIKELY(! IN_UTF8_TURKIC_LOCALE))
4730
4731 #endif
4732
4733     ) {
4734
4735         /* We can convert in place, as, outside of Turkic UTF-8 locales,
4736          * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4737          * been on) doesn't lengthen it. */
4738         dest = source;
4739         s = d = (U8*)SvPV_force_nomg(source, len);
4740         min = len + 1;
4741     } else {
4742         dTARGET;
4743
4744         dest = TARG;
4745
4746         s = (const U8*)SvPV_nomg_const(source, len);
4747         min = len + 1;
4748
4749         SvUPGRADE(dest, SVt_PV);
4750         d = (U8*)SvGROW(dest, min);
4751         (void)SvPOK_only(dest);
4752
4753         SETs(dest);
4754     }
4755
4756 #ifdef USE_LOCALE_CTYPE
4757
4758     if (IN_LC_RUNTIME(LC_CTYPE)) {
4759         const U8 * next_I;
4760
4761         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
4762
4763         /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4764          * UTF-8 for the single case of the character 'I' */
4765         if (     UNLIKELY(IN_UTF8_TURKIC_LOCALE)
4766             && ! DO_UTF8(source)
4767             &&   (next_I = (U8 *) memchr(s, 'I', len)))
4768         {
4769             Size_t I_count = 0;
4770             const U8 *const send = s + len;
4771
4772             do {
4773                 I_count++;
4774
4775                 next_I = (U8 *) memchr(next_I + 1, 'I',
4776                                         send - (next_I + 1));
4777             } while (next_I != NULL);
4778
4779             /* Except for the 'I', in UTF-8 strings, the lower case of a
4780              * character below 256 occupies the same number of bytes as the
4781              * original.  Therefore, the space needed is the original length
4782              * plus I_count plus the number of characters that become two bytes
4783              * when converted to UTF-8 */
4784             sv_utf8_upgrade_flags_grow(dest, 0, len
4785                                               + I_count
4786                                               + variant_under_utf8_count(s, send)
4787                                               + 1 /* Trailing NUL */ );
4788             d = (U8*)SvPVX(dest);
4789             has_turkic_I = TRUE;
4790         }
4791     }
4792
4793 #else
4794     PERL_UNUSED_VAR(has_turkic_I);
4795 #endif
4796
4797     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4798        to check DO_UTF8 again here.  */
4799
4800     if (DO_UTF8(source)) {
4801         const U8 *const send = s + len;
4802         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4803         bool remove_dot_above = FALSE;
4804
4805         while (s < send) {
4806             const STRLEN u = UTF8SKIP(s);
4807             STRLEN ulen;
4808
4809 #ifdef USE_LOCALE_CTYPE
4810
4811             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4812
4813             /* If we are in a Turkic locale, we have to do more work.  As noted
4814              * in the comments for lcfirst, there is a special case if a 'I'
4815              * is in a grapheme with COMBINING DOT ABOVE UTF8.  It turns into a
4816              * 'i', and the DOT must be removed.  We check for that situation,
4817              * and set a flag if the DOT is there.  Then each time through the
4818              * loop, we have to see if we need to remove the next DOT above,
4819              * and if so, do it.  We know that there is a DOT because
4820              * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4821              * was one in a proper position. */
4822             if (   UNLIKELY(IN_UTF8_TURKIC_LOCALE)
4823                 && IN_LC_RUNTIME(LC_CTYPE))
4824             {
4825                 if (   UNLIKELY(remove_dot_above)
4826                     && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4827                 {
4828                     s += u;
4829                     remove_dot_above = FALSE;
4830                     continue;
4831                 }
4832                 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4833                     remove_dot_above = TRUE;
4834                 }
4835             }
4836 #else
4837             PERL_UNUSED_VAR(remove_dot_above);
4838
4839             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4840 #endif
4841
4842             /* Here is where we would do context-sensitive actions for the
4843              * Greek final sigma.  See the commit message for 86510fb15 for why
4844              * there isn't any */
4845
4846             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4847
4848                 /* If the eventually required minimum size outgrows the
4849                  * available space, we need to grow. */
4850                 const UV o = d - (U8*)SvPVX_const(dest);
4851
4852                 /* If someone lowercases one million U+0130s we SvGROW() one
4853                  * million times.  Or we could try guessing how much to
4854                  * allocate without allocating too much.  Such is life.
4855                  * Another option would be to grow an extra byte or two more
4856                  * each time we need to grow, which would cut down the million
4857                  * to 500K, with little waste */
4858                 d = o + (U8*) SvGROW(dest, min);
4859             }
4860
4861             /* Copy the newly lowercased letter to the output buffer we're
4862              * building */
4863             Copy(tmpbuf, d, ulen, U8);
4864             d += ulen;
4865             s += u;
4866         }   /* End of looping through the source string */
4867         SvUTF8_on(dest);
4868         *d = '\0';
4869         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4870     } else {    /* 'source' not utf8 */
4871         if (len) {
4872             const U8 *const send = s + len;
4873
4874             /* Use locale casing if in locale; regular style if not treating
4875              * latin1 as having case; otherwise the latin1 casing.  Do the
4876              * whole thing in a tight loop, for speed, */
4877 #ifdef USE_LOCALE_CTYPE
4878             if (IN_LC_RUNTIME(LC_CTYPE)) {
4879                 if (LIKELY( ! has_turkic_I)) {
4880                     for (; s < send; d++, s++)
4881                         *d = toLOWER_LC(*s);
4882                 }
4883                 else {  /* This is the only case where lc() converts 'dest'
4884                            into UTF-8 from a non-UTF-8 'source' */
4885                     for (; s < send; s++) {
4886                         if (*s == 'I') {
4887                             *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4888                             *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4889                         }
4890                         else {
4891                             append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4892                         }
4893                     }
4894                 }
4895             }
4896             else
4897 #endif
4898             if (! IN_UNI_8_BIT) {
4899                 for (; s < send; d++, s++) {
4900                     *d = toLOWER(*s);
4901                 }
4902             }
4903             else {
4904                 for (; s < send; d++, s++) {
4905                     *d = toLOWER_LATIN1(*s);
4906                 }
4907             }
4908         }
4909         if (source != dest) {
4910             *d = '\0';
4911             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4912         }
4913     }
4914 #ifdef USE_LOCALE_CTYPE
4915     if (IN_LC_RUNTIME(LC_CTYPE)) {
4916         TAINT;
4917         SvTAINTED_on(dest);
4918     }
4919 #endif
4920     if (dest != source && SvTAINTED(source))
4921         SvTAINT(dest);
4922     SvSETMAGIC(dest);
4923     return NORMAL;
4924 }
4925
4926 PP(pp_quotemeta)
4927 {
4928     dTARGET;
4929     SV * const sv = *PL_stack_sp;
4930     STRLEN len;
4931     const char *s = SvPV_const(sv,len);
4932
4933     SvUTF8_off(TARG);                           /* decontaminate */
4934     if (len) {
4935         char *d;
4936         SvUPGRADE(TARG, SVt_PV);
4937         SvGROW(TARG, (len * 2) + 1);
4938         d = SvPVX(TARG);
4939         if (DO_UTF8(sv)) {
4940             while (len) {
4941                 STRLEN ulen = UTF8SKIP(s);
4942                 bool to_quote = FALSE;
4943
4944                 if (UTF8_IS_INVARIANT(*s)) {
4945                     if (_isQUOTEMETA(*s)) {
4946                         to_quote = TRUE;
4947                     }
4948                 }
4949                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4950                     if (
4951 #ifdef USE_LOCALE_CTYPE
4952                     /* In locale, we quote all non-ASCII Latin1 chars.
4953                      * Otherwise use the quoting rules */
4954
4955                     IN_LC_RUNTIME(LC_CTYPE)
4956                         ||
4957 #endif
4958                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4959                     {
4960                         to_quote = TRUE;
4961                     }
4962                 }
4963                 else if (is_QUOTEMETA_high(s)) {
4964                     to_quote = TRUE;
4965                 }
4966
4967                 if (to_quote) {
4968                     *d++ = '\\';
4969                 }
4970                 if (ulen > len)
4971                     ulen = len;
4972                 len -= ulen;
4973                 while (ulen--)
4974                     *d++ = *s++;
4975             }
4976             SvUTF8_on(TARG);
4977         }
4978         else if (IN_UNI_8_BIT) {
4979             while (len--) {
4980                 if (_isQUOTEMETA(*s))
4981                     *d++ = '\\';
4982                 *d++ = *s++;
4983             }
4984         }
4985         else {
4986             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4987              * including everything above ASCII */
4988             while (len--) {
4989                 if (!isWORDCHAR_A(*s))
4990                     *d++ = '\\';
4991                 *d++ = *s++;
4992             }
4993         }
4994         *d = '\0';
4995         SvCUR_set(TARG, d - SvPVX_const(TARG));
4996         (void)SvPOK_only_UTF8(TARG);
4997     }
4998     else
4999         sv_setpvn(TARG, s, len);
5000
5001     SvSETMAGIC(TARG);
5002     rpp_replace_1_1(TARG);
5003     return NORMAL;
5004 }
5005
5006 PP_wrapped(pp_fc, 1, 0)
5007 {
5008     dTARGET;
5009     dSP;
5010     SV *source = TOPs;
5011     STRLEN len;
5012     STRLEN min;
5013     SV *dest;
5014     const U8 *s;
5015     const U8 *send;
5016     U8 *d;
5017     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
5018 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
5019    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
5020                                       || UNICODE_DOT_DOT_VERSION > 0)
5021     const bool full_folding = TRUE; /* This variable is here so we can easily
5022                                        move to more generality later */
5023 #else
5024     const bool full_folding = FALSE;
5025 #endif
5026     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
5027 #ifdef USE_LOCALE_CTYPE
5028                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
5029 #endif
5030     ;
5031
5032     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
5033      * You are welcome(?) -Hugmeir
5034      */
5035
5036     SvGETMAGIC(source);
5037
5038     dest = TARG;
5039
5040     if (SvOK(source)) {
5041         s = (const U8*)SvPV_nomg_const(source, len);
5042     } else {
5043         if (ckWARN(WARN_UNINITIALIZED))
5044             report_uninit(source);
5045         s = (const U8*)"";
5046         len = 0;
5047     }
5048
5049     min = len + 1;
5050
5051     SvUPGRADE(dest, SVt_PV);
5052     d = (U8*)SvGROW(dest, min);
5053     (void)SvPOK_only(dest);
5054
5055     SETs(dest);
5056
5057     send = s + len;
5058
5059 #ifdef USE_LOCALE_CTYPE
5060
5061     if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
5062         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
5063     }
5064
5065 #endif
5066
5067     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
5068         while (s < send) {
5069             const STRLEN u = UTF8SKIP(s);
5070             STRLEN ulen;
5071
5072             _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
5073
5074             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
5075                 const UV o = d - (U8*)SvPVX_const(dest);
5076                 d = o + (U8*) SvGROW(dest, min);
5077             }
5078
5079             Copy(tmpbuf, d, ulen, U8);
5080             d += ulen;
5081             s += u;
5082         }
5083         SvUTF8_on(dest);
5084     } /* Unflagged string */
5085     else if (len) {
5086 #ifdef USE_LOCALE_CTYPE
5087         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
5088             if (IN_UTF8_CTYPE_LOCALE) {
5089                 goto do_uni_folding;
5090             }
5091             for (; s < send; d++, s++)
5092                 *d = (U8) toFOLD_LC(*s);
5093         }
5094         else
5095 #endif
5096         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
5097             for (; s < send; d++, s++)
5098                 *d = toFOLD(*s);
5099         }
5100         else {
5101 #ifdef USE_LOCALE_CTYPE
5102       do_uni_folding:
5103 #endif
5104             /* For ASCII and the Latin-1 range, there's potentially three
5105              * troublesome folds:
5106              *      \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
5107              *             casefolding becomes 'ss';
5108              *      \x{B5} (\N{MICRO SIGN}), which under any fold becomes
5109              *             \x{3BC} (\N{GREEK SMALL LETTER MU})
5110              *      I      only in Turkic locales, this folds to \x{131}
5111              *             \N{LATIN SMALL LETTER DOTLESS I}
5112              * For the rest, the casefold is their lowercase.  */
5113             for (; s < send; d++, s++) {
5114                 if (    UNLIKELY(*s == MICRO_SIGN)
5115 #ifdef USE_LOCALE_CTYPE
5116                     || (   UNLIKELY(IN_UTF8_TURKIC_LOCALE)
5117                         && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))
5118                         && UNLIKELY(*s == 'I'))
5119 #endif
5120                 ) {
5121                     Size_t extra = send - s
5122                                  + variant_under_utf8_count(s, send);
5123
5124                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
5125                      * and 'I' in Turkic locales is \N{LATIN SMALL LETTER
5126                      * DOTLESS I} both of which are outside of the latin-1
5127                      * range. There's a couple of ways to deal with this -- khw
5128                      * discusses them in pp_lc/uc, so go there :) What we do
5129                      * here is upgrade what we had already casefolded, then
5130                      * enter an inner loop that appends the rest of the
5131                      * characters as UTF-8.
5132                      *
5133                      * First we calculate the needed size of the upgraded dest
5134                      * beyond what's been processed already (the upgrade
5135                      * function figures that out).  Except for the 'I' in
5136                      * Turkic locales, in UTF-8 strings, the fold case of a
5137                      * character below 256 occupies the same number of bytes as
5138                      * the original (even the Sharp S).  Therefore, the space
5139                      * needed is the number of bytes remaining plus the number
5140                      * of characters that become two bytes when converted to
5141                      * UTF-8 plus, in turkish locales, the number of 'I's */
5142
5143                     if (UNLIKELY(*s == 'I')) {
5144                         const U8 * s_peek = s;
5145
5146                         do {
5147                             extra++;
5148
5149                             s_peek = (U8 *) memchr(s_peek + 1, 'I',
5150                                                    send - (s_peek + 1));
5151                         } while (s_peek != NULL);
5152                     }
5153
5154                     /* Growing may move things, so have to save and recalculate
5155                      * 'd' */
5156                     len = d - (U8*)SvPVX_const(dest);
5157                     SvCUR_set(dest, len);
5158                     len = sv_utf8_upgrade_flags_grow(dest,
5159                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
5160                                                 extra
5161                                               + 1 /* Trailing NUL */ );
5162                     d = (U8*)SvPVX(dest) + len;
5163
5164                     if (*s == 'I') {
5165                         *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
5166                         *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
5167                     }
5168                     else {
5169                         *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
5170                         *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
5171                     }
5172                     s++;
5173
5174                     for (; s < send; s++) {
5175                         STRLEN ulen;
5176                         _to_uni_fold_flags(*s, d, &ulen, flags);
5177                         d += ulen;
5178                     }
5179                     break;
5180                 }
5181                 else if (   UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S)
5182                          && full_folding)
5183                 {
5184                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
5185                      * becomes "ss", which may require growing the SV. */
5186                     if (SvLEN(dest) < ++min) {
5187                         const UV o = d - (U8*)SvPVX_const(dest);
5188                         d = o + (U8*) SvGROW(dest, min);
5189                      }
5190                     *(d)++ = 's';
5191                     *d = 's';
5192                 }
5193                 else { /* Else, the fold is the lower case */
5194                     *d = toLOWER_LATIN1(*s);
5195                 }
5196              }
5197         }
5198     }
5199     *d = '\0';
5200     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
5201
5202 #ifdef USE_LOCALE_CTYPE
5203     if (IN_LC_RUNTIME(LC_CTYPE)) {
5204         TAINT;
5205         SvTAINTED_on(dest);
5206     }
5207 #endif
5208     if (SvTAINTED(source))
5209         SvTAINT(dest);
5210     SvSETMAGIC(dest);
5211     RETURN;
5212 }
5213
5214 /* Arrays. */
5215
5216
5217 PP(pp_aslice)
5218 {
5219     dMARK; dORIGMARK;
5220     AV *const av = MUTABLE_AV(*PL_stack_sp);
5221     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5222
5223     if (SvTYPE(av) == SVt_PVAV) {
5224         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5225         bool can_preserve = FALSE;
5226
5227         if (localizing) {
5228             MAGIC *mg;
5229             HV *stash;
5230
5231             can_preserve = SvCANEXISTDELETE(av);
5232         }
5233
5234         if (lval && localizing) {
5235             SV **svp;
5236             SSize_t max = -1;
5237             for (svp = MARK + 1; svp < PL_stack_sp; svp++) {
5238                 const SSize_t elem = SvIV(*svp);
5239                 if (elem > max)
5240                     max = elem;
5241             }
5242             if (max > AvMAX(av))
5243                 av_extend(av, max);
5244         }
5245
5246         while (++MARK < PL_stack_sp) {
5247             SV **svp;
5248             SSize_t elem = SvIV(*MARK);
5249             bool preeminent = TRUE;
5250
5251             if (localizing && can_preserve) {
5252                 /* If we can determine whether the element exist,
5253                  * Try to preserve the existenceness of a tied array
5254                  * element by using EXISTS and DELETE if possible.
5255                  * Fallback to FETCH and STORE otherwise. */
5256                 preeminent = av_exists(av, elem);
5257             }
5258
5259             svp = av_fetch(av, elem, lval);
5260             if (lval) {
5261                 if (!svp || !*svp)
5262                     DIE(aTHX_ PL_no_aelem, elem);
5263                 if (localizing) {
5264                     if (preeminent)
5265                         save_aelem(av, elem, svp);
5266                     else
5267                         SAVEADELETE(av, elem);
5268                 }
5269             }
5270
5271             rpp_replace_at(MARK, svp ? *svp : &PL_sv_undef);
5272         }
5273     }
5274
5275     rpp_context(ORIGMARK, GIMME_V, 1);
5276     return NORMAL;
5277 }
5278
5279
5280 /*  %ary[1,3,5] */
5281
5282 PP(pp_kvaslice)
5283 {
5284     dMARK; dORIGMARK;
5285     /* leave av on stack for now to avoid leak on croak */
5286     AV *const av = MUTABLE_AV(*PL_stack_sp);
5287     I32 lval = (PL_op->op_flags & OPf_MOD);
5288     SSize_t items = PL_stack_sp - MARK - 1;
5289
5290     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5291        const I32 flags = is_lvalue_sub();
5292        if (flags) {
5293            if (!(flags & OPpENTERSUB_INARGS))
5294                /* diag_listed_as: Can't modify %s in %s */
5295                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
5296            lval = flags;
5297        }
5298     }
5299
5300     rpp_extend(items);
5301     MARK = ORIGMARK;
5302
5303     /* move av from old top-of-stack to new top-of-stack */
5304     PL_stack_sp[items] = PL_stack_sp[0];
5305     PL_stack_sp[0] = NULL;
5306
5307     /* spread the index SVs out to every second location */
5308     SSize_t i = items;
5309     while (i > 1) {
5310         *(MARK+i*2-1) = *(MARK+i);
5311         *(MARK+i*2)   = NULL;
5312         *(MARK+i)     = NULL;
5313         i--;
5314     }
5315     PL_stack_sp += items;
5316
5317     while (++MARK < PL_stack_sp) {
5318         SV **svp;
5319
5320         svp = av_fetch(av, SvIV(*MARK), lval);
5321         if (lval) {
5322             if (!svp || !*svp || *svp == &PL_sv_undef) {
5323                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
5324             }
5325             /* replace key SV with a copy */
5326             SV *oldsv = *MARK;
5327             SV *newsv = newSVsv(oldsv);
5328 #ifdef PERL_RC_STACK
5329             *MARK = newsv;
5330             SvREFCNT_dec(oldsv);
5331 #else
5332             *MARK = sv_2mortal(newsv);
5333 #endif
5334         }
5335
5336         MARK++;
5337         rpp_replace_at(MARK, svp ? *svp : &PL_sv_undef);
5338     }
5339
5340     /* pop AV, then apply void/scalar/list context to stack above mark */
5341     rpp_context(ORIGMARK, GIMME_V, 1);
5342     return NORMAL;
5343 }
5344
5345
5346
5347 PP_wrapped(pp_aeach, 1, 0)
5348 {
5349     dSP;
5350     AV *array = MUTABLE_AV(POPs);
5351     const U8 gimme = GIMME_V;
5352     IV *iterp = Perl_av_iter_p(aTHX_ array);
5353     const IV current = (*iterp)++;
5354
5355     if (current > av_top_index(array)) {
5356         *iterp = 0;
5357         if (gimme == G_SCALAR)
5358             RETPUSHUNDEF;
5359         else
5360             RETURN;
5361     }
5362
5363     EXTEND(SP, 2);
5364     mPUSHi(current);
5365     if (gimme == G_LIST) {
5366         SV **const element = av_fetch(array, current, 0);
5367         PUSHs(element ? *element : &PL_sv_undef);
5368     }
5369     RETURN;
5370 }
5371
5372 /* also used for: pp_avalues()*/
5373 PP_wrapped(pp_akeys, 1, 0)
5374 {
5375     dSP;
5376     AV *array = MUTABLE_AV(POPs);
5377     const U8 gimme = GIMME_V;
5378
5379     *Perl_av_iter_p(aTHX_ array) = 0;
5380
5381     if (gimme == G_SCALAR) {
5382         dTARGET;
5383         PUSHi(av_count(array));
5384     }
5385     else if (gimme == G_LIST) {
5386       if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
5387         const I32 flags = is_lvalue_sub();
5388         if (flags && !(flags & OPpENTERSUB_INARGS))
5389             /* diag_listed_as: Can't modify %s in %s */
5390             Perl_croak(aTHX_
5391                       "Can't modify keys on array in list assignment");
5392       }
5393       {
5394         IV n = av_top_index(array);
5395         IV i;
5396
5397         EXTEND(SP, n + 1);
5398
5399         if (  PL_op->op_type == OP_AKEYS
5400            || (  PL_op->op_type == OP_AVHVSWITCH
5401               && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS  ))
5402         {
5403             for (i = 0;  i <= n;  i++) {
5404                 mPUSHi(i);
5405             }
5406         }
5407         else {
5408             for (i = 0;  i <= n;  i++) {
5409                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
5410                 PUSHs(elem ? *elem : &PL_sv_undef);
5411             }
5412         }
5413       }
5414     }
5415     RETURN;
5416 }
5417
5418 /* Associative arrays. */
5419
5420 PP_wrapped(pp_each, 1, 0)
5421 {
5422     dSP;
5423     HV * hash = MUTABLE_HV(POPs);
5424     HE *entry;
5425     const U8 gimme = GIMME_V;
5426
5427     entry = hv_iternext(hash);
5428
5429     EXTEND(SP, 2);
5430     if (entry) {
5431         SV* const sv = hv_iterkeysv(entry);
5432         PUSHs(sv);
5433         if (gimme == G_LIST) {
5434             SV *val;
5435             val = hv_iterval(hash, entry);
5436             PUSHs(val);
5437         }
5438     }
5439     else if (gimme == G_SCALAR)
5440         RETPUSHUNDEF;
5441
5442     RETURN;
5443 }
5444
5445 STATIC OP *
5446 S_do_delete_local(pTHX)
5447 {
5448     dSP;
5449     const U8 gimme = GIMME_V;
5450     const MAGIC *mg;
5451     HV *stash;
5452     const bool sliced = cBOOL(PL_op->op_private & OPpSLICE);
5453     SV **unsliced_keysv = sliced ? NULL : sp--;
5454     SV * const osv = POPs;
5455     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
5456     dORIGMARK;
5457     const bool tied = SvRMAGICAL(osv)
5458                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
5459     const bool can_preserve = SvCANEXISTDELETE(osv);
5460     const U32 type = SvTYPE(osv);
5461     SV ** const end = sliced ? SP : unsliced_keysv;
5462
5463     if (type == SVt_PVHV) {                     /* hash element */
5464             HV * const hv = MUTABLE_HV(osv);
5465             while (++MARK <= end) {
5466                 SV * const keysv = *MARK;
5467                 SV *sv = NULL;
5468                 bool preeminent = TRUE;
5469                 if (can_preserve)
5470                     preeminent = hv_exists_ent(hv, keysv, 0);
5471                 if (tied) {
5472                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5473                     if (he)
5474                         sv = HeVAL(he);
5475                     else
5476                         preeminent = FALSE;
5477                 }
5478                 else {
5479                     sv = hv_delete_ent(hv, keysv, 0, 0);
5480                     if (preeminent)
5481                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5482                 }
5483                 if (preeminent) {
5484                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5485                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5486                     if (tied) {
5487                         *MARK = sv_mortalcopy(sv);
5488                         mg_clear(sv);
5489                     } else
5490                         *MARK = sv;
5491                 }
5492                 else {
5493                     SAVEHDELETE(hv, keysv);
5494                     *MARK = &PL_sv_undef;
5495                 }
5496             }
5497     }
5498     else if (type == SVt_PVAV) {                  /* array element */
5499             if (PL_op->op_flags & OPf_SPECIAL) {
5500                 AV * const av = MUTABLE_AV(osv);
5501                 while (++MARK <= end) {
5502                     SSize_t idx = SvIV(*MARK);
5503                     SV *sv = NULL;
5504                     bool preeminent = TRUE;
5505                     if (can_preserve)
5506                         preeminent = av_exists(av, idx);
5507                     if (tied) {
5508                         SV **svp = av_fetch(av, idx, 1);
5509                         if (svp)
5510                             sv = *svp;
5511                         else
5512                             preeminent = FALSE;
5513                     }
5514                     else {
5515                         sv = av_delete(av, idx, 0);
5516                         if (preeminent)
5517                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5518                     }
5519                     if (preeminent) {
5520                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5521                         if (tied) {
5522                             *MARK = sv_mortalcopy(sv);
5523                             mg_clear(sv);
5524                         } else
5525                             *MARK = sv;
5526                     }
5527                     else {
5528                         SAVEADELETE(av, idx);
5529                         *MARK = &PL_sv_undef;
5530                     }
5531                 }
5532             }
5533             else
5534                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5535     }
5536     else
5537             DIE(aTHX_ "Not a HASH reference");
5538     if (sliced) {
5539         if (gimme == G_VOID)
5540             SP = ORIGMARK;
5541         else if (gimme == G_SCALAR) {
5542             MARK = ORIGMARK;
5543             if (SP > MARK)
5544                 *++MARK = *SP;
5545             else
5546                 *++MARK = &PL_sv_undef;
5547             SP = MARK;
5548         }
5549     }
5550     else if (gimme != G_VOID)
5551         PUSHs(*unsliced_keysv);
5552
5553     RETURN;
5554 }
5555
5556 PP_wrapped(pp_delete,
5557                 ((PL_op->op_private & (OPpSLICE|OPpKVSLICE)) ? 0 : 2),
5558                 ((PL_op->op_private & (OPpSLICE|OPpKVSLICE)) ? 1 : 0))
5559 {
5560     dSP;
5561     U8 gimme;
5562     I32 discard;
5563
5564     if (PL_op->op_private & OPpLVAL_INTRO)
5565         return do_delete_local();
5566
5567     gimme = GIMME_V;
5568     discard = (gimme == G_VOID) ? G_DISCARD : 0;
5569
5570     if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5571         dMARK; dORIGMARK;
5572         HV * const hv = MUTABLE_HV(POPs);
5573         const U32 hvtype = SvTYPE(hv);
5574         int skip = 0;
5575         if (PL_op->op_private & OPpKVSLICE) {
5576             SSize_t items = SP - MARK;
5577
5578             MEXTEND(SP,items);
5579             while (items > 1) {
5580                 *(MARK+items*2-1) = *(MARK+items);
5581                 items--;
5582             }
5583             items = SP - MARK;
5584             SP += items;
5585             skip = 1;
5586         }
5587         if (hvtype == SVt_PVHV) {                       /* hash element */
5588             while ((MARK += (1+skip)) <= SP) {
5589                 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5590                 *MARK = sv ? sv : &PL_sv_undef;
5591             }
5592         }
5593         else if (hvtype == SVt_PVAV) {                  /* array element */
5594             if (PL_op->op_flags & OPf_SPECIAL) {
5595                 while ((MARK += (1+skip)) <= SP) {
5596                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5597                     *MARK = sv ? sv : &PL_sv_undef;
5598                 }
5599             }
5600         }
5601         else
5602             DIE(aTHX_ "Not a HASH reference");
5603         if (discard)
5604             SP = ORIGMARK;
5605         else if (gimme == G_SCALAR) {
5606             MARK = ORIGMARK;
5607             if (SP > MARK)
5608                 *++MARK = *SP;
5609             else
5610                 *++MARK = &PL_sv_undef;
5611             SP = MARK;
5612         }
5613     }
5614     else {
5615         SV *keysv = POPs;
5616         HV * const hv = MUTABLE_HV(POPs);
5617         SV *sv = NULL;
5618         if (SvTYPE(hv) == SVt_PVHV)
5619             sv = hv_delete_ent(hv, keysv, discard, 0);
5620         else if (SvTYPE(hv) == SVt_PVAV) {
5621             if (PL_op->op_flags & OPf_SPECIAL)
5622                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5623             else
5624                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5625         }
5626         else
5627             DIE(aTHX_ "Not a HASH reference");
5628         if (!sv)
5629             sv = &PL_sv_undef;
5630         if (!discard)
5631             PUSHs(sv);
5632     }
5633     RETURN;
5634 }
5635
5636 PP_wrapped(pp_exists, ((PL_op->op_private & OPpEXISTS_SUB) ? 1 : 2), 0)
5637 {
5638     dSP;
5639     SV *tmpsv;
5640     HV *hv;
5641
5642     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5643         GV *gv;
5644         SV * const sv = POPs;
5645         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5646         if (cv)
5647             RETPUSHYES;
5648         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5649             RETPUSHYES;
5650         RETPUSHNO;
5651     }
5652     tmpsv = POPs;
5653     hv = MUTABLE_HV(POPs);
5654     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5655         if (hv_exists_ent(hv, tmpsv, 0))
5656             RETPUSHYES;
5657     }
5658     else if (SvTYPE(hv) == SVt_PVAV) {
5659         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
5660             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5661                 RETPUSHYES;
5662         }
5663     }
5664     else {
5665         DIE(aTHX_ "Not a HASH reference");
5666     }
5667     RETPUSHNO;
5668 }
5669
5670 /* OP_HELEMEXISTSOR is a LOGOP not currently available to pure Perl code, but
5671  * is defined for use by the core for new features, optimisations, or XS
5672  * modules.
5673  *
5674  * Constructing it consumes two optrees, the first of which must be an
5675  * OP_HELEM.
5676  *
5677  *   OP *o = newLOGOP(OP_HELEMEXISTSOR, 0, helemop, otherop);
5678  *
5679  * If the hash element exists (by the same rules as OP_EXISTS would find
5680  * true) the op pushes it to the stack in the same way as a regular OP_HELEM
5681  * and invokes op_next. If the element does not exist, then op_other is
5682  * invoked instead. This is roughly equivalent to the perl code
5683  *
5684  *   exists $hash{$key} ? $hash{$key} : OTHER
5685  *
5686  * Except that any expressions or side-effects involved in obtaining the HV
5687  * or the key are only invoked once, and it is a little more efficient when
5688  * run on regular (non-magical) HVs.
5689  *
5690  * Combined with the OPpHELEMEXISTSOR_DELETE flag in op_private, this
5691  * additionally deletes the element if found.
5692  *
5693  * On a tied HV, the 'EXISTS' method will be run as expected. If the method
5694  * returns true then either the 'FETCH' or 'DELETE' method will also be run
5695  * as required.
5696  */
5697
5698 PP(pp_helemexistsor)
5699 {
5700     SV *keysv = PL_stack_sp[0];
5701     HV *hv = MUTABLE_HV(PL_stack_sp[-1]);
5702     bool is_delete = PL_op->op_private & OPpHELEMEXISTSOR_DELETE;
5703
5704     assert(SvTYPE(hv) == SVt_PVHV);
5705
5706     bool hv_is_magical = UNLIKELY(SvMAGICAL(hv));
5707
5708     SV *val = NULL;
5709
5710     /* For magical HVs we have to ensure we invoke the EXISTS method first.
5711      * For regular HVs we can just skip this and use the "pointer or NULL"
5712      * result of the real hv_* functions
5713      */
5714     if(hv_is_magical && !hv_exists_ent(hv, keysv, 0))
5715         goto other;
5716
5717     if(is_delete) {
5718         val = hv_delete_ent(hv, keysv, 0, 0);
5719     }
5720     else {
5721         HE *he = hv_fetch_ent(hv, keysv, 0, 0);
5722         val = he ? HeVAL(he) : NULL;
5723
5724         /* A magical HV hasn't yet actually invoked the FETCH method. We must
5725          * ask it to do so now
5726          */
5727         if(hv_is_magical && val)
5728             SvGETMAGIC(val);
5729     }
5730
5731     if(!val) {
5732 other:
5733         rpp_popfree_2();
5734         return cLOGOP->op_other;
5735     }
5736
5737     rpp_replace_2_1(val);
5738     return NORMAL;
5739 }
5740
5741
5742 /* @hash{'foo', 'bar'} */
5743
5744 PP(pp_hslice)
5745 {
5746     dMARK; dORIGMARK;
5747     HV * const hv = MUTABLE_HV(*PL_stack_sp);
5748     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5749     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5750     bool can_preserve = FALSE;
5751
5752     if (localizing) {
5753         MAGIC *mg;
5754         HV *stash;
5755
5756         if (SvCANEXISTDELETE(hv))
5757             can_preserve = TRUE;
5758     }
5759
5760     while (++MARK < PL_stack_sp) {
5761         SV * const keysv = *MARK;
5762         SV **svp;
5763         HE *he;
5764         bool preeminent = TRUE;
5765
5766         if (localizing && can_preserve) {
5767             /* If we can determine whether the element exist,
5768              * try to preserve the existenceness of a tied hash
5769              * element by using EXISTS and DELETE if possible.
5770              * Fallback to FETCH and STORE otherwise. */
5771             preeminent = hv_exists_ent(hv, keysv, 0);
5772         }
5773
5774         he = hv_fetch_ent(hv, keysv, lval, 0);
5775         svp = he ? &HeVAL(he) : NULL;
5776
5777         if (lval) {
5778             if (!svp || !*svp || *svp == &PL_sv_undef) {
5779                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5780             }
5781             if (localizing) {
5782                 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5783                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5784                 else if (preeminent)
5785                     save_helem_flags(hv, keysv, svp,
5786                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5787                 else
5788                     SAVEHDELETE(hv, keysv);
5789             }
5790         }
5791
5792         rpp_replace_at(MARK, svp && *svp ? *svp : &PL_sv_undef);
5793     }
5794
5795     rpp_context(ORIGMARK, GIMME_V, 1);
5796     return NORMAL;
5797 }
5798
5799
5800 /* %hash{'foo', 'bar'} */
5801
5802 PP(pp_kvhslice)
5803 {
5804     dMARK; dORIGMARK;
5805     /* leave hv on stack for now to avoid leak on croak */
5806     HV * const hv = MUTABLE_HV(*PL_stack_sp);
5807     I32 lval = (PL_op->op_flags & OPf_MOD);
5808     SSize_t items = PL_stack_sp - MARK - 1;
5809
5810     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5811        const I32 flags = is_lvalue_sub();
5812        if (flags) {
5813            if (!(flags & OPpENTERSUB_INARGS))
5814                /* diag_listed_as: Can't modify %s in %s */
5815                Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5816                                  GIMME_V == G_LIST ? "list" : "scalar");
5817            lval = flags;
5818        }
5819     }
5820
5821     rpp_extend(items);
5822     MARK = ORIGMARK;
5823
5824     /* move hv from old top-of-stack to new top-of-stack */
5825     PL_stack_sp[items] = PL_stack_sp[0];
5826     PL_stack_sp[0] = NULL;
5827
5828     /* spread the key SVs out to every second location */
5829     SSize_t i = items;
5830     while (i > 1) {
5831         *(MARK+i*2-1) = *(MARK+i);
5832         *(MARK+i*2)   = NULL;
5833         *(MARK+i)     = NULL;
5834         i--;
5835     }
5836     PL_stack_sp += items;
5837
5838     while (++MARK < PL_stack_sp) {
5839         SV * const keysv = *MARK;
5840         SV **svp;
5841         HE *he;
5842
5843         he = hv_fetch_ent(hv, keysv, lval, 0);
5844         svp = he ? &HeVAL(he) : NULL;
5845
5846         if (lval) {
5847             if (!svp || !*svp || *svp == &PL_sv_undef) {
5848                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5849             }
5850             /* replace key SV with a copy */
5851             SV *oldsv = *MARK;
5852             SV *newsv = newSVsv(oldsv);
5853 #ifdef PERL_RC_STACK
5854             *MARK = newsv;
5855             SvREFCNT_dec(oldsv);
5856 #else
5857             *MARK = sv_2mortal(newsv);
5858 #endif
5859         }
5860
5861         MARK++;
5862         rpp_replace_at(MARK, (svp  && *svp) ? *svp : &PL_sv_undef);
5863     }
5864
5865     /* pop HV, then apply void/scalar/list context to stack above mark */
5866     rpp_context(ORIGMARK, GIMME_V, 1);
5867     return NORMAL;
5868 }
5869
5870 /* List operators. */
5871
5872 PP_wrapped(pp_list, 0, 1)
5873 {
5874     I32 markidx = POPMARK;
5875     if (GIMME_V != G_LIST) {
5876         /* don't initialize mark here, EXTEND() may move the stack */
5877         SV **mark;
5878         dSP;
5879         EXTEND(SP, 1);          /* in case no arguments, as in @empty */
5880         mark = PL_stack_base + markidx;
5881         if (++MARK <= SP)
5882             *MARK = *SP;                /* unwanted list, return last item */
5883         else
5884             *MARK = &PL_sv_undef;
5885         SP = MARK;
5886         PUTBACK;
5887     }
5888     return NORMAL;
5889 }
5890
5891 PP_wrapped(pp_lslice, 0, 2)
5892 {
5893     dSP;
5894     SV ** const lastrelem = PL_stack_sp;
5895     SV ** const lastlelem = PL_stack_base + POPMARK;
5896     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5897     SV ** const firstrelem = lastlelem + 1;
5898     const U8 mod = PL_op->op_flags & OPf_MOD;
5899
5900     const I32 max = lastrelem - lastlelem;
5901     SV **lelem;
5902
5903     if (GIMME_V != G_LIST) {
5904         if (lastlelem < firstlelem) {
5905             EXTEND(SP, 1);
5906             *firstlelem = &PL_sv_undef;
5907         }
5908         else {
5909             I32 ix = SvIV(*lastlelem);
5910             if (ix < 0)
5911                 ix += max;
5912             if (ix < 0 || ix >= max)
5913                 *firstlelem = &PL_sv_undef;
5914             else
5915                 *firstlelem = firstrelem[ix];
5916         }
5917         SP = firstlelem;
5918         RETURN;
5919     }
5920
5921     if (max == 0) {
5922         SP = firstlelem - 1;
5923         RETURN;
5924     }
5925
5926     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5927         I32 ix = SvIV(*lelem);
5928         if (ix < 0)
5929             ix += max;
5930         if (ix < 0 || ix >= max)
5931             *lelem = &PL_sv_undef;
5932         else {
5933             if (!(*lelem = firstrelem[ix]))
5934                 *lelem = &PL_sv_undef;
5935             else if (mod && SvPADTMP(*lelem)) {
5936                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5937             }
5938         }
5939     }
5940     SP = lastlelem;
5941     RETURN;
5942 }
5943
5944
5945 PP(pp_anonlist)
5946 {
5947     dMARK;
5948     const I32 items = PL_stack_sp - MARK;
5949     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5950     /* attach new SV to stack before freeing everything else,
5951      * so no leak on croak */
5952     rpp_extend(1);
5953     SV *sv = (PL_op->op_flags & OPf_SPECIAL) ? newRV_noinc(av) : (SV*)av;
5954     rpp_push_1_norc(sv); /* this handles ref count and/or mortalising */
5955     PL_stack_sp[0] = PL_stack_sp[-items];
5956     PL_stack_sp[-items] = sv;
5957     rpp_popfree_to(PL_stack_sp - items);
5958     return NORMAL;
5959 }
5960
5961
5962 /* When an anonlist or anonhash will (1) be empty and (2) return an RV
5963  * pointing to the new AV/HV, the peephole optimizer can swap in this
5964  * simpler function and op_null the originally associated PUSHMARK. */
5965 PP_wrapped(pp_emptyavhv, 0,0)
5966 {
5967     dSP;
5968     OP * const op = PL_op;
5969     SV * rv;
5970     SV * const sv = MUTABLE_SV( newSV_type(
5971                                 (op->op_private & OPpEMPTYAVHV_IS_HV) ?
5972                                     SVt_PVHV :
5973                                     SVt_PVAV ) );
5974
5975     /* Is it an assignment, just a stack push, or both?*/
5976     if (op->op_private & OPpTARGET_MY) {
5977         SV** const padentry = &PAD_SVl(op->op_targ);
5978         rv = *padentry;
5979         /* Since the op_targ is very likely to be an undef SVt_IV from
5980          * a previous iteration, converting it to a live RV can
5981          * typically be special-cased.*/
5982         if (SvTYPE(rv) == SVt_IV && !SvOK(rv)) {
5983             SvFLAGS(rv) = (SVt_IV | SVf_ROK);
5984             SvRV_set(rv, sv);
5985         } else {
5986            sv_setrv_noinc_mg(rv, sv);
5987         }
5988         if ((op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
5989             save_clearsv(padentry);
5990         }
5991         if (GIMME_V == G_VOID) {
5992             RETURN; /* skip extending and pushing */
5993         }
5994     } else {
5995         /* Inlined newRV_noinc */
5996         SV * refsv = newSV_type_mortal(SVt_IV);
5997         SvRV_set(refsv, sv);
5998         SvROK_on(refsv);
5999
6000         rv = refsv;
6001     }
6002
6003     XPUSHs(rv);
6004     RETURN;
6005 }
6006
6007 PP_wrapped(pp_anonhash, 0, 1)
6008 {
6009     dSP; dMARK; dORIGMARK;
6010     HV* const hv = newHV();
6011     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
6012                                     ? newRV_noinc(MUTABLE_SV(hv))
6013                                     : MUTABLE_SV(hv) );
6014     /* This isn't quite true for an odd sized list (it's one too few) but it's
6015        not worth the runtime +1 just to optimise for the warning case. */
6016     SSize_t pairs = (SP - MARK) >> 1;
6017     if (pairs > PERL_HASH_DEFAULT_HvMAX) {
6018         hv_ksplit(hv, pairs);
6019     }
6020
6021     while (MARK < SP) {
6022         SV * const key =
6023             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
6024         SV *val;
6025         if (MARK < SP)
6026         {
6027             MARK++;
6028             SvGETMAGIC(*MARK);
6029             val = newSV_type(SVt_NULL);
6030             sv_setsv_nomg(val, *MARK);
6031         }
6032         else
6033         {
6034             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
6035             val = newSV_type(SVt_NULL);
6036         }
6037         (void)hv_store_ent(hv,key,val,0);
6038     }
6039     SP = ORIGMARK;
6040     XPUSHs(retval);
6041     RETURN;
6042 }
6043
6044 PP_wrapped(pp_splice, 0, 1)
6045 {
6046     dSP; dMARK; dORIGMARK;
6047     int num_args = (SP - MARK);
6048     AV *ary = MUTABLE_AV(*++MARK);
6049     SV **src;
6050     SV **dst;
6051     SSize_t i;
6052     SSize_t offset;
6053     SSize_t length;
6054     SSize_t newlen;
6055     SSize_t after;
6056     SSize_t diff;
6057     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
6058
6059     if (mg) {
6060         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
6061                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
6062                                     sp - mark);
6063     }
6064
6065     if (SvREADONLY(ary))
6066         Perl_croak_no_modify();
6067
6068     SP++;
6069
6070     if (++MARK < SP) {
6071         offset = i = SvIV(*MARK);
6072         if (offset < 0)
6073             offset += AvFILLp(ary) + 1;
6074         if (offset < 0)
6075             DIE(aTHX_ PL_no_aelem, i);
6076         if (++MARK < SP) {
6077             length = SvIVx(*MARK++);
6078             if (length < 0) {
6079                 length += AvFILLp(ary) - offset + 1;
6080                 if (length < 0)
6081                     length = 0;
6082             }
6083         }
6084         else
6085             length = AvMAX(ary) + 1;            /* close enough to infinity */
6086     }
6087     else {
6088         offset = 0;
6089         length = AvMAX(ary) + 1;
6090     }
6091     if (offset > AvFILLp(ary) + 1) {
6092         if (num_args > 2)
6093             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
6094         offset = AvFILLp(ary) + 1;
6095     }
6096     after = AvFILLp(ary) + 1 - (offset + length);
6097     if (after < 0) {                            /* not that much array */
6098         length += after;                        /* offset+length now in array */
6099         after = 0;
6100         if (!AvALLOC(ary))
6101             av_extend(ary, 0);
6102     }
6103
6104     /* At this point, MARK .. SP-1 is our new LIST */
6105
6106     newlen = SP - MARK;
6107     diff = newlen - length;
6108     if (newlen && !AvREAL(ary) && AvREIFY(ary))
6109         av_reify(ary);
6110
6111     /* make new elements SVs now: avoid problems if they're from the array */
6112     for (dst = MARK, i = newlen; i; i--) {
6113         SV * const h = *dst;
6114         *dst++ = newSVsv(h);
6115     }
6116
6117     if (diff < 0) {                             /* shrinking the area */
6118         SV **tmparyval = NULL;
6119         if (newlen) {
6120             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
6121             Copy(MARK, tmparyval, newlen, SV*);
6122         }
6123
6124         MARK = ORIGMARK + 1;
6125         if (GIMME_V == G_LIST) {                /* copy return vals to stack */
6126             const bool real = cBOOL(AvREAL(ary));
6127             MEXTEND(MARK, length);
6128             if (real)
6129                 EXTEND_MORTAL(length);
6130             for (i = 0, dst = MARK; i < length; i++) {
6131                 if ((*dst = AvARRAY(ary)[i+offset])) {
6132                   if (real)
6133                     sv_2mortal(*dst);   /* free them eventually */
6134                 }
6135                 else
6136                     *dst = &PL_sv_undef;
6137                 dst++;
6138             }
6139             MARK += length - 1;
6140         }
6141         else {
6142             *MARK = AvARRAY(ary)[offset+length-1];
6143             if (AvREAL(ary)) {
6144                 sv_2mortal(*MARK);
6145                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
6146                     SvREFCNT_dec(*dst++);       /* free them now */
6147             }
6148             if (!*MARK)
6149                 *MARK = &PL_sv_undef;
6150         }
6151         AvFILLp(ary) += diff;
6152
6153         /* pull up or down? */
6154
6155         if (offset < after) {                   /* easier to pull up */
6156             if (offset) {                       /* esp. if nothing to pull */
6157                 src = &AvARRAY(ary)[offset-1];
6158                 dst = src - diff;               /* diff is negative */
6159                 for (i = offset; i > 0; i--)    /* can't trust Copy */
6160                     *dst-- = *src--;
6161             }
6162             dst = AvARRAY(ary);
6163             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
6164             AvMAX(ary) += diff;
6165         }
6166         else {
6167             if (after) {                        /* anything to pull down? */
6168                 src = AvARRAY(ary) + offset + length;
6169                 dst = src + diff;               /* diff is negative */
6170                 Move(src, dst, after, SV*);
6171             }
6172             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
6173                                                 /* avoid later double free */
6174         }
6175         i = -diff;
6176         while (i)
6177             dst[--i] = NULL;
6178
6179         if (newlen) {
6180             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
6181             Safefree(tmparyval);
6182         }
6183     }
6184     else {                                      /* no, expanding (or same) */
6185         SV** tmparyval = NULL;
6186         if (length) {
6187             Newx(tmparyval, length, SV*);       /* so remember deletion */
6188             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
6189         }
6190
6191         if (diff > 0) {                         /* expanding */
6192             /* push up or down? */
6193             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
6194                 if (offset) {
6195                     src = AvARRAY(ary);
6196                     dst = src - diff;
6197                     Move(src, dst, offset, SV*);
6198                 }
6199                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
6200                 AvMAX(ary) += diff;
6201                 AvFILLp(ary) += diff;
6202             }
6203             else {
6204                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
6205                     av_extend(ary, AvFILLp(ary) + diff);
6206                 AvFILLp(ary) += diff;
6207
6208                 if (after) {
6209                     dst = AvARRAY(ary) + AvFILLp(ary);
6210                     src = dst - diff;
6211                     for (i = after; i; i--) {
6212                         *dst-- = *src--;
6213                     }
6214                 }
6215             }
6216         }
6217
6218         if (newlen) {
6219             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
6220         }
6221
6222         MARK = ORIGMARK + 1;
6223         if (GIMME_V == G_LIST) {                /* copy return vals to stack */
6224             if (length) {
6225                 const bool real = cBOOL(AvREAL(ary));
6226                 if (real)
6227                     EXTEND_MORTAL(length);
6228                 for (i = 0, dst = MARK; i < length; i++) {
6229                     if ((*dst = tmparyval[i])) {
6230                       if (real)
6231                         sv_2mortal(*dst);       /* free them eventually */
6232                     }
6233                     else *dst = &PL_sv_undef;
6234                     dst++;
6235                 }
6236             }
6237             MARK += length - 1;
6238         }
6239         else if (length--) {
6240             *MARK = tmparyval[length];
6241             if (AvREAL(ary)) {
6242                 sv_2mortal(*MARK);
6243                 while (length-- > 0)
6244                     SvREFCNT_dec(tmparyval[length]);
6245             }
6246             if (!*MARK)
6247                 *MARK = &PL_sv_undef;
6248         }
6249         else
6250             *MARK = &PL_sv_undef;
6251         Safefree(tmparyval);
6252     }
6253
6254     if (SvMAGICAL(ary))
6255         mg_set(MUTABLE_SV(ary));
6256
6257     SP = MARK;
6258     RETURN;
6259 }
6260
6261
6262 PP(pp_push)
6263 {
6264     dMARK; dORIGMARK; dTARGET;
6265     AV * const ary = MUTABLE_AV(*++MARK);
6266     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
6267
6268     if (mg) {
6269         ENTER_with_name("call_PUSH");
6270         SV *obj = SvTIED_obj(MUTABLE_SV(ary), mg);
6271 #ifdef PERL_RC_STACK
6272         /* keep ary alive as it's replaced on the stack with obj */
6273         SAVEFREESV(MUTABLE_SV(ary));
6274         SvREFCNT_inc_simple_void(obj);
6275 #endif
6276         *MARK-- = obj;
6277         PUSHMARK(MARK);
6278         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6279         LEAVE_with_name("call_PUSH");
6280     }
6281     else {
6282         /* PL_delaymagic is restored by JMPENV_POP on dieing, so we
6283          * only need to save locally, not on the save stack */
6284         U16 old_delaymagic = PL_delaymagic;
6285
6286         if (SvREADONLY(ary) && MARK < PL_stack_sp)
6287             Perl_croak_no_modify();
6288         PL_delaymagic = DM_DELAY;
6289         for (++MARK; MARK <= PL_stack_sp; MARK++) {
6290             SV *sv;
6291             if (*MARK) SvGETMAGIC(*MARK);
6292             sv = newSV_type(SVt_NULL);
6293             if (*MARK)
6294                 sv_setsv_nomg(sv, *MARK);
6295             av_store(ary, AvFILLp(ary)+1, sv);
6296         }
6297         if (PL_delaymagic & DM_ARRAY_ISA)
6298             mg_set(MUTABLE_SV(ary));
6299         PL_delaymagic = old_delaymagic;
6300     }
6301     rpp_popfree_to(ORIGMARK);
6302     if (OP_GIMME(PL_op, 0) != G_VOID) {
6303         TARGi(AvFILL(ary) + 1, 1);
6304         rpp_push_1(targ);
6305     }
6306     return NORMAL;
6307 }
6308
6309
6310 /* also used for: pp_pop()*/
6311 PP_wrapped(pp_shift, (PL_op->op_flags & OPf_SPECIAL ? 0 : 1), 0)
6312 {
6313     dSP;
6314     AV * const av = PL_op->op_flags & OPf_SPECIAL
6315         ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
6316     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
6317     EXTEND(SP, 1);
6318     assert (sv);
6319     if (AvREAL(av))
6320         (void)sv_2mortal(sv);
6321     PUSHs(sv);
6322     RETURN;
6323 }
6324
6325 PP_wrapped(pp_unshift, 0, 1)
6326 {
6327     dSP; dMARK; dORIGMARK; dTARGET;
6328     AV *ary = MUTABLE_AV(*++MARK);
6329     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
6330
6331     if (mg) {
6332         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
6333         PUSHMARK(MARK);
6334         PUTBACK;
6335         ENTER_with_name("call_UNSHIFT");
6336         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6337         LEAVE_with_name("call_UNSHIFT");
6338         /* SPAGAIN; not needed: SP is assigned to immediately below */
6339     }
6340     else {
6341         /* PL_delaymagic is restored by JMPENV_POP on dieing, so we
6342          * only need to save locally, not on the save stack */
6343         U16 old_delaymagic = PL_delaymagic;
6344         SSize_t i = 0;
6345
6346         av_unshift(ary, SP - MARK);
6347         PL_delaymagic = DM_DELAY;
6348
6349         if (!SvMAGICAL(ary)) {
6350             /* The av_unshift above means that many of the checks inside
6351              * av_store are unnecessary. If ary does not have magic attached
6352              * then a simple direct assignment is possible here. */
6353             while (MARK < SP) {
6354                 SV * const sv = newSVsv(*++MARK);
6355                 assert( !SvTIED_mg((const SV *)ary, PERL_MAGIC_tied) );
6356                 assert( i >= 0 );
6357                 assert( !SvREADONLY(ary) );
6358                 assert( AvREAL(ary) || !AvREIFY(ary) );
6359                 assert( i <= AvMAX(ary) );
6360                 assert( i <= AvFILLp(ary) );
6361                 if (AvREAL(ary))
6362                     SvREFCNT_dec(AvARRAY(ary)[i]);
6363                 AvARRAY(ary)[i] = sv;
6364                 i++;
6365             }
6366         } else {
6367             while (MARK < SP) {
6368                 SV * const sv = newSVsv(*++MARK);
6369                 (void)av_store(ary, i++, sv);
6370             }
6371         }
6372
6373         if (PL_delaymagic & DM_ARRAY_ISA)
6374             mg_set(MUTABLE_SV(ary));
6375         PL_delaymagic = old_delaymagic;
6376     }
6377     SP = ORIGMARK;
6378     if (OP_GIMME(PL_op, 0) != G_VOID) {
6379         PUSHi( AvFILL(ary) + 1 );
6380     }
6381     RETURN;
6382 }
6383
6384 PP_wrapped(pp_reverse, 0, 1)
6385 {
6386     dSP; dMARK;
6387
6388     if (GIMME_V == G_LIST) {
6389         if (PL_op->op_private & OPpREVERSE_INPLACE) {
6390             AV *av;
6391
6392             /* See pp_sort() */
6393             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
6394             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
6395             av = MUTABLE_AV((*SP));
6396             /* In-place reversing only happens in void context for the array
6397              * assignment. We don't need to push anything on the stack. */
6398             SP = MARK;
6399
6400             if (SvMAGICAL(av)) {
6401                 SSize_t i, j;
6402                 SV *tmp = sv_newmortal();
6403                 /* For SvCANEXISTDELETE */
6404                 HV *stash;
6405                 const MAGIC *mg;
6406                 bool can_preserve = SvCANEXISTDELETE(av);
6407
6408                 for (i = 0, j = av_top_index(av); i < j; ++i, --j) {
6409                     SV *begin, *end;
6410
6411                     if (can_preserve) {
6412                         if (!av_exists(av, i)) {
6413                             if (av_exists(av, j)) {
6414                                 SV *sv = av_delete(av, j, 0);
6415                                 begin = *av_fetch(av, i, TRUE);
6416                                 sv_setsv_mg(begin, sv);
6417                             }
6418                             continue;
6419                         }
6420                         else if (!av_exists(av, j)) {
6421                             SV *sv = av_delete(av, i, 0);
6422                             end = *av_fetch(av, j, TRUE);
6423                             sv_setsv_mg(end, sv);
6424                             continue;
6425                         }
6426                     }
6427
6428                     begin = *av_fetch(av, i, TRUE);
6429                     end   = *av_fetch(av, j, TRUE);
6430                     sv_setsv(tmp,      begin);
6431                     sv_setsv_mg(begin, end);
6432                     sv_setsv_mg(end,   tmp);
6433                 }
6434             }
6435             else {
6436                 SV **begin = AvARRAY(av);
6437
6438                 if (begin) {
6439                     SV **end   = begin + AvFILLp(av);
6440
6441                     while (begin < end) {
6442                         SV * const tmp = *begin;
6443                         *begin++ = *end;
6444                         *end--   = tmp;
6445                     }
6446                 }
6447             }
6448         }
6449         else {
6450             SV **oldsp = SP;
6451             MARK++;
6452             while (MARK < SP) {
6453                 SV * const tmp = *MARK;
6454                 *MARK++ = *SP;
6455                 *SP--   = tmp;
6456             }
6457             /* safe as long as stack cannot get extended in the above */
6458             SP = oldsp;
6459         }
6460     }
6461     else {
6462         char *up;
6463         dTARGET;
6464         STRLEN len;
6465
6466         SvUTF8_off(TARG);                               /* decontaminate */
6467         if (SP - MARK > 1) {
6468             do_join(TARG, &PL_sv_no, MARK, SP);
6469             SP = MARK + 1;
6470             SETs(TARG);
6471         } else if (SP > MARK) {
6472             sv_setsv(TARG, *SP);
6473             SETs(TARG);
6474         } else {
6475             sv_setsv(TARG, DEFSV);
6476             XPUSHs(TARG);
6477         }
6478         SvSETMAGIC(TARG); /* remove any utf8 length magic */
6479
6480         up = SvPV_force(TARG, len);
6481         if (len > 1) {
6482             char *down;
6483             if (DO_UTF8(TARG)) {        /* first reverse each character */
6484                 U8* s = (U8*)SvPVX(TARG);
6485                 const U8* send = (U8*)(s + len);
6486                 while (s < send) {
6487                     if (UTF8_IS_INVARIANT(*s)) {
6488                         s++;
6489                         continue;
6490                     }
6491                     else {
6492                         if (!utf8_to_uvchr_buf(s, send, 0))
6493                             break;
6494                         up = (char*)s;
6495                         s += UTF8SKIP(s);
6496                         down = (char*)(s - 1);
6497                         /* reverse this character */
6498                         while (down > up) {
6499                             const char tmp = *up;
6500                             *up++ = *down;
6501                             *down-- = tmp;
6502                         }
6503                     }
6504                 }
6505                 up = SvPVX(TARG);
6506             }
6507             down = SvPVX(TARG) + len - 1;
6508             while (down > up) {
6509                 const char tmp = *up;
6510                 *up++ = *down;
6511                 *down-- = tmp;
6512             }
6513             (void)SvPOK_only_UTF8(TARG);
6514         }
6515     }
6516     RETURN;
6517 }
6518
6519 PP_wrapped(pp_split,
6520               (   (PL_op->op_private & OPpSPLIT_ASSIGN)
6521                && (PL_op->op_flags & OPf_STACKED))
6522               ? 3 : 2,
6523                0)
6524 {
6525     dSP; dTARG;
6526     AV *ary = (   (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
6527                && (PL_op->op_flags & OPf_STACKED))      /* @{expr} = split */
6528                ? (AV *)POPs : NULL;
6529     IV limit = POPi;                    /* note, negative is forever */
6530     SV * const sv = POPs;
6531     STRLEN len;
6532     const char *s = SvPV_const(sv, len);
6533     const bool do_utf8 = DO_UTF8(sv);
6534     const bool in_uni_8_bit = IN_UNI_8_BIT;
6535     const char *strend = s + len;
6536     PMOP *pm = cPMOP;
6537     REGEXP *rx;
6538     SV *dstr;
6539     const char *m;
6540     SSize_t iters = 0;
6541     const STRLEN slen = do_utf8
6542                         ? utf8_length((U8*)s, (U8*)strend)
6543                         : (STRLEN)(strend - s);
6544     SSize_t maxiters = slen + 10;
6545     I32 trailing_empty = 0;
6546     const char *orig;
6547     const IV origlimit = limit;
6548     bool realarray = 0;
6549     I32 base;
6550     const U8 gimme = GIMME_V;
6551     bool gimme_scalar;
6552     I32 oldsave = PL_savestack_ix;
6553     U32 flags = (do_utf8 ? SVf_UTF8 : 0) |
6554          SVs_TEMP; /* Make mortal SVs by default */
6555     MAGIC *mg = NULL;
6556
6557     rx = PM_GETRE(pm);
6558
6559     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
6560              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
6561
6562     /* handle @ary = split(...) optimisation */
6563     if (PL_op->op_private & OPpSPLIT_ASSIGN) {
6564         realarray = 1;
6565         if (!(PL_op->op_flags & OPf_STACKED)) {
6566             if (PL_op->op_private & OPpSPLIT_LEX) {
6567                 if (PL_op->op_private & OPpLVAL_INTRO)
6568                     SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6569                 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
6570             }
6571             else {
6572                 GV *gv =
6573 #ifdef USE_ITHREADS
6574                         MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6575 #else
6576                         pm->op_pmreplrootu.op_pmtargetgv;
6577 #endif
6578                 if (PL_op->op_private & OPpLVAL_INTRO)
6579                     ary = save_ary(gv);
6580                 else
6581                     ary = GvAVn(gv);
6582             }
6583             /* skip anything pushed by OPpLVAL_INTRO above */
6584             oldsave = PL_savestack_ix;
6585         }
6586
6587         /* Some defence against stack-not-refcounted bugs */
6588         (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary));
6589
6590         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
6591             PUSHMARK(SP);
6592             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
6593         } else {
6594             flags &= ~SVs_TEMP; /* SVs will not be mortal */
6595         }
6596     }
6597
6598     base = SP - PL_stack_base;
6599     orig = s;
6600     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
6601         if (do_utf8) {
6602             while (s < strend && isSPACE_utf8_safe(s, strend))
6603                 s += UTF8SKIP(s);
6604         }
6605         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
6606             while (s < strend && isSPACE_LC(*s))
6607                 s++;
6608         }
6609         else if (in_uni_8_bit) {
6610             while (s < strend && isSPACE_L1(*s))
6611                 s++;
6612         }
6613         else {
6614             while (s < strend && isSPACE(*s))
6615                 s++;
6616         }
6617     }
6618
6619     gimme_scalar = gimme == G_SCALAR && !ary;
6620
6621     if (!limit)
6622         limit = maxiters + 2;
6623     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
6624         while (--limit) {
6625             m = s;
6626             /* this one uses 'm' and is a negative test */
6627             if (do_utf8) {
6628                 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
6629                     const int t = UTF8SKIP(m);
6630                     /* isSPACE_utf8_safe returns FALSE for malform utf8 */
6631                     if (strend - m < t)
6632                         m = strend;
6633                     else
6634                         m += t;
6635                 }
6636             }
6637             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6638             {
6639                 while (m < strend && !isSPACE_LC(*m))
6640                     ++m;
6641             }
6642             else if (in_uni_8_bit) {
6643                 while (m < strend && !isSPACE_L1(*m))
6644                     ++m;
6645             } else {
6646                 while (m < strend && !isSPACE(*m))
6647                     ++m;
6648             }
6649             if (m >= strend)
6650                 break;
6651
6652             if (gimme_scalar) {
6653                 iters++;
6654                 if (m-s == 0)
6655                     trailing_empty++;
6656                 else
6657                     trailing_empty = 0;
6658             } else {
6659                 dstr = newSVpvn_flags(s, m-s, flags);
6660                 XPUSHs(dstr);
6661             }
6662
6663             /* skip the whitespace found last */
6664             if (do_utf8)
6665                 s = m + UTF8SKIP(m);
6666             else
6667                 s = m + 1;
6668
6669             /* this one uses 's' and is a positive test */
6670             if (do_utf8) {
6671                 while (s < strend && isSPACE_utf8_safe(s, strend) )
6672                     s +=  UTF8SKIP(s);
6673             }
6674             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6675             {
6676                 while (s < strend && isSPACE_LC(*s))
6677                     ++s;
6678             }
6679             else if (in_uni_8_bit) {
6680                 while (s < strend && isSPACE_L1(*s))
6681                     ++s;
6682             } else {
6683                 while (s < strend && isSPACE(*s))
6684                     ++s;
6685             }
6686         }
6687     }
6688     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6689         while (--limit) {
6690             for (m = s; m < strend && *m != '\n'; m++)
6691                 ;
6692             m++;
6693             if (m >= strend)
6694                 break;
6695
6696             if (gimme_scalar) {
6697                 iters++;
6698                 if (m-s == 0)
6699                     trailing_empty++;
6700                 else
6701                     trailing_empty = 0;
6702             } else {
6703                 dstr = newSVpvn_flags(s, m-s, flags);
6704                 XPUSHs(dstr);
6705             }
6706             s = m;
6707         }
6708     }
6709     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6710         /* This case boils down to deciding which is the smaller of:
6711          * limit - effectively a number of characters
6712          * slen - which already contains the number of characters in s
6713          *
6714          * The resulting number is the number of iters (for gimme_scalar)
6715          * or the number of SVs to create (!gimme_scalar). */
6716
6717         /* setting it to -1 will trigger a panic in EXTEND() */
6718         const SSize_t sslen = slen > SSize_t_MAX ?  -1 : (SSize_t)slen;
6719         const IV items = limit - 1;
6720         if (sslen < items || items < 0) {
6721             iters = slen -1;
6722             limit = slen + 1;
6723             /* Note: The same result is returned if the following block
6724              * is removed, because of the "keep field after final delim?"
6725              * adjustment, but having the following makes the "correct"
6726              * behaviour more apparent. */
6727             if (gimme_scalar) {
6728                 s = strend;
6729                 iters++;
6730             }
6731         } else {
6732             iters = items;
6733         }
6734         if (!gimme_scalar) {
6735             /*
6736               Pre-extend the stack, either the number of bytes or
6737               characters in the string or a limited amount, triggered by:
6738               my ($x, $y) = split //, $str;
6739                 or
6740               split //, $str, $i;
6741             */
6742             EXTEND(SP, limit);
6743             if (do_utf8) {
6744                 while (--limit) {
6745                     m = s;
6746                     s += UTF8SKIP(s);
6747                     dstr = newSVpvn_flags(m, s-m, flags);
6748                     PUSHs(dstr);
6749                 }
6750             } else {
6751                 while (--limit) {
6752                     dstr = newSVpvn_flags(s, 1, flags);
6753                     PUSHs(dstr);
6754                     s++;
6755                 }
6756             }
6757         }
6758     }
6759     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6760              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6761              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6762              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6763         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6764         SV * const csv = CALLREG_INTUIT_STRING(rx);
6765
6766         len = RX_MINLENRET(rx);
6767         if (len == 1 && !RX_UTF8(rx) && !tail) {
6768             const char c = *SvPV_nolen_const(csv);
6769             while (--limit) {
6770                 for (m = s; m < strend && *m != c; m++)
6771                     ;
6772                 if (m >= strend)
6773                     break;
6774                 if (gimme_scalar) {
6775                     iters++;
6776                     if (m-s == 0)
6777                         trailing_empty++;
6778                     else
6779                         trailing_empty = 0;
6780                 } else {
6781                     dstr = newSVpvn_flags(s, m-s, flags);
6782                     XPUSHs(dstr);
6783                 }
6784                 /* The rx->minlen is in characters but we want to step
6785                  * s ahead by bytes. */
6786                 if (do_utf8)
6787                     s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend);
6788                 else
6789                     s = m + len; /* Fake \n at the end */
6790             }
6791         }
6792         else {
6793             const bool multiline = (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) ? 1 : 0;
6794
6795             while (s < strend && --limit &&
6796               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6797                              csv, multiline ? FBMrf_MULTILINE : 0)) )
6798             {
6799                 if (gimme_scalar) {
6800                     iters++;
6801                     if (m-s == 0)
6802                         trailing_empty++;
6803                     else
6804                         trailing_empty = 0;
6805                 } else {
6806                     dstr = newSVpvn_flags(s, m-s, flags);
6807                     XPUSHs(dstr);
6808                 }
6809                 /* The rx->minlen is in characters but we want to step
6810                  * s ahead by bytes. */
6811                 if (do_utf8)
6812                     s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend);
6813                 else
6814                     s = m + len; /* Fake \n at the end */
6815             }
6816         }
6817     }
6818     else {
6819         maxiters += slen * RX_NPARENS(rx);
6820         while (s < strend && --limit)
6821         {
6822             I32 rex_return;
6823             PUTBACK;
6824             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6825                                      sv, NULL, 0);
6826             SPAGAIN;
6827             if (rex_return == 0)
6828                 break;
6829             TAINT_IF(RX_MATCH_TAINTED(rx));
6830             /* we never pass the REXEC_COPY_STR flag, so it should
6831              * never get copied */
6832             assert(!RX_MATCH_COPIED(rx));
6833             m = RX_OFFS_START(rx,0) + orig;
6834
6835             if (gimme_scalar) {
6836                 iters++;
6837                 if (m-s == 0)
6838                     trailing_empty++;
6839                 else
6840                     trailing_empty = 0;
6841             } else {
6842                 dstr = newSVpvn_flags(s, m-s, flags);
6843                 XPUSHs(dstr);
6844             }
6845             if (RX_NPARENS(rx)) {
6846                 I32 i;
6847                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6848                     s = orig + RX_OFFS_START(rx,i);
6849                     m = orig + RX_OFFS_END(rx,i);
6850
6851                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6852                        parens that didn't match -- they should be set to
6853                        undef, not the empty string */
6854                     if (gimme_scalar) {
6855                         iters++;
6856                         if (m-s == 0)
6857                             trailing_empty++;
6858                         else
6859                             trailing_empty = 0;
6860                     } else {
6861                         if (m >= orig && s >= orig) {
6862                             dstr = newSVpvn_flags(s, m-s, flags);
6863                         }
6864                         else
6865                             dstr = &PL_sv_undef;  /* undef, not "" */
6866                         XPUSHs(dstr);
6867                     }
6868
6869                 }
6870             }
6871             s = RX_OFFS_END(rx,0) + orig;
6872         }
6873     }
6874
6875     if (!gimme_scalar) {
6876         iters = (SP - PL_stack_base) - base;
6877     }
6878     if (iters > maxiters)
6879         DIE(aTHX_ "Split loop");
6880
6881     /* keep field after final delim? */
6882     if (s < strend || (iters && origlimit)) {
6883         if (!gimme_scalar) {
6884             const STRLEN l = strend - s;
6885             dstr = newSVpvn_flags(s, l, flags);
6886             XPUSHs(dstr);
6887         }
6888         iters++;
6889     }
6890     else if (!origlimit) {
6891         if (gimme_scalar) {
6892             iters -= trailing_empty;
6893         } else {
6894             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6895                 if (TOPs && !(flags & SVs_TEMP))
6896                     sv_2mortal(TOPs);
6897                 *SP-- = NULL;
6898                 iters--;
6899             }
6900         }
6901     }
6902
6903     PUTBACK;
6904     LEAVE_SCOPE(oldsave);
6905     SPAGAIN;
6906     if (realarray) {
6907         if (!mg) {
6908             PUTBACK;
6909             if(AvREAL(ary)) {
6910                 if (av_count(ary) > 0)
6911                     av_clear(ary);
6912             } else {
6913                 AvREAL_on(ary);
6914                 AvREIFY_off(ary);
6915
6916                 if (AvMAX(ary) > -1) {
6917                     /* don't free mere refs */
6918                     Zero(AvARRAY(ary), AvMAX(ary), SV*);
6919                 }
6920             }
6921             if(AvMAX(ary) < iters)
6922                 av_extend(ary,iters);
6923             SPAGAIN;
6924
6925             /* Need to copy the SV*s from the stack into ary */
6926             Copy(SP + 1 - iters, AvARRAY(ary), iters, SV*);
6927             AvFILLp(ary) = iters - 1;
6928
6929             if (SvSMAGICAL(ary)) {
6930                 PUTBACK;
6931                 mg_set(MUTABLE_SV(ary));
6932                 SPAGAIN;
6933             }
6934
6935             if (gimme != G_LIST) {
6936                 /* SP points to the final SV* pushed to the stack. But the SV*  */
6937                 /* are not going to be used from the stack. Point SP to below   */
6938                 /* the first of these SV*.                                      */
6939                 SP -= iters;
6940                 PUTBACK;
6941             }
6942         }
6943         else {
6944             PUTBACK;
6945             av_extend(ary,iters);
6946             av_clear(ary);
6947
6948             ENTER_with_name("call_PUSH");
6949             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6950             LEAVE_with_name("call_PUSH");
6951             SPAGAIN;
6952
6953             if (gimme == G_LIST) {
6954                 SSize_t i;
6955                 /* EXTEND should not be needed - we just popped them */
6956                 EXTEND_SKIP(SP, iters);
6957                 for (i=0; i < iters; i++) {
6958                     SV **svp = av_fetch(ary, i, FALSE);
6959                     PUSHs((svp) ? *svp : &PL_sv_undef);
6960                 }
6961                 RETURN;
6962             }
6963         }
6964     }
6965
6966     if (gimme != G_LIST) {
6967         GETTARGET;
6968         XPUSHi(iters);
6969      }
6970
6971     RETURN;
6972 }
6973
6974 PP(pp_once)
6975 {
6976     SV *const sv = PAD_SVl(PL_op->op_targ);
6977
6978     if (SvPADSTALE(sv)) {
6979         /* First time. */
6980         SvPADSTALE_off(sv);
6981         return cLOGOP->op_other;
6982     }
6983     return cLOGOP->op_next;
6984 }
6985
6986 PP(pp_lock)
6987 {
6988     SV *sv = *PL_stack_sp;
6989     SV *retsv = sv;
6990     SvLOCK(sv);
6991     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6992      || SvTYPE(retsv) == SVt_PVCV) {
6993         retsv = refto(retsv);
6994     }
6995     rpp_replace_1_1(retsv);
6996     return NORMAL;
6997 }
6998
6999
7000 /* used for: pp_padany(), pp_custom(); plus any system ops
7001  * that aren't implemented on a particular platform */
7002
7003 PP(unimplemented_op)
7004 {
7005     const Optype op_type = PL_op->op_type;
7006     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
7007        with out of range op numbers - it only "special" cases op_custom.
7008        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
7009        if we get here for a custom op then that means that the custom op didn't
7010        have an implementation. Given that OP_NAME() looks up the custom op
7011        by its op_ppaddr, likely it will return NULL, unless someone (unhelpfully)
7012        registers &Perl_unimplemented_op as the address of their custom op.
7013        NULL doesn't generate a useful error message. "custom" does. */
7014     const char *const name = op_type >= OP_max
7015         ? "[out of range]" : PL_op_name[op_type];
7016     if(OP_IS_SOCKET(op_type))
7017         DIE(aTHX_ PL_no_sock_func, name);
7018     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
7019 }
7020
7021 static void
7022 S_maybe_unwind_defav(pTHX)
7023 {
7024     if (CX_CUR()->cx_type & CXp_HASARGS) {
7025         PERL_CONTEXT *cx = CX_CUR();
7026
7027         assert(CxHASARGS(cx));
7028         cx_popsub_args(cx);
7029         cx->cx_type &= ~CXp_HASARGS;
7030     }
7031 }
7032
7033 /* For sorting out arguments passed to a &CORE:: subroutine */
7034 PP_wrapped(pp_coreargs, 0, 0)
7035 {
7036     dSP;
7037     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
7038     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
7039     AV * const at_ = GvAV(PL_defgv);
7040     SV **svp = at_ ? AvARRAY(at_) : NULL;
7041     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
7042     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
7043     bool seen_question = 0;
7044     const char *err = NULL;
7045     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
7046
7047     /* Count how many args there are first, to get some idea how far to
7048        extend the stack. */
7049     while (oa) {
7050         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
7051         maxargs++;
7052         if (oa & OA_OPTIONAL) seen_question = 1;
7053         if (!seen_question) minargs++;
7054         oa >>= 4;
7055     }
7056
7057     if(numargs < minargs) err = "Not enough";
7058     else if(numargs > maxargs) err = "Too many";
7059     if (err)
7060         /* diag_listed_as: Too many arguments for %s */
7061         Perl_croak(aTHX_
7062           "%s arguments for %s", err,
7063            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
7064         );
7065
7066     /* Reset the stack pointer.  Without this, we end up returning our own
7067        arguments in list context, in addition to the values we are supposed
7068        to return.  nextstate usually does this on sub entry, but we need
7069        to run the next op with the caller's hints, so we cannot have a
7070        nextstate. */
7071     SP = PL_stack_base + CX_CUR()->blk_oldsp;
7072
7073     if(!maxargs) RETURN;
7074
7075     /* We do this here, rather than with a separate pushmark op, as it has
7076        to come in between two things this function does (stack reset and
7077        arg pushing).  This seems the easiest way to do it. */
7078     if (pushmark) {
7079         PUSHMARK(SP);
7080     }
7081
7082     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
7083     PUTBACK; /* The code below can die in various places. */
7084
7085     oa = PL_opargs[opnum] >> OASHIFT;
7086     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
7087         whicharg++;
7088         switch (oa & 7) {
7089         case OA_SCALAR:
7090           try_defsv:
7091             if (!numargs && defgv && whicharg == minargs + 1) {
7092                 PUSHs(DEFSV);
7093             }
7094             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
7095             break;
7096         case OA_LIST:
7097             while (numargs--) {
7098                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
7099                 svp++;
7100             }
7101             RETURN;
7102         case OA_AVREF:
7103             if (!numargs) {
7104                 GV *gv;
7105                 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
7106                     gv = PL_argvgv;
7107                 else {
7108                     S_maybe_unwind_defav(aTHX);
7109                     gv = PL_defgv;
7110                 }
7111                 PUSHs((SV *)GvAVn(gv));
7112                 break;
7113             }
7114             if (!svp || !*svp || !SvROK(*svp)
7115              || SvTYPE(SvRV(*svp)) != SVt_PVAV)
7116                 DIE(aTHX_
7117                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
7118                  "Type of arg %d to &CORE::%s must be array reference",
7119                   whicharg, PL_op_desc[opnum]
7120                 );
7121             PUSHs(SvRV(*svp));
7122             break;
7123         case OA_HVREF:
7124             if (!svp || !*svp || !SvROK(*svp)
7125              || (  SvTYPE(SvRV(*svp)) != SVt_PVHV
7126                 && (  opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
7127                    || SvTYPE(SvRV(*svp)) != SVt_PVAV  )))
7128                 DIE(aTHX_
7129                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
7130                  "Type of arg %d to &CORE::%s must be hash%s reference",
7131                   whicharg, PL_op_desc[opnum],
7132                   opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
7133                      ? ""
7134                      : " or array"
7135                 );
7136             PUSHs(SvRV(*svp));
7137             break;
7138         case OA_FILEREF:
7139             if (!numargs) PUSHs(NULL);
7140             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
7141                 /* no magic here, as the prototype will have added an extra
7142                    refgen and we just want what was there before that */
7143                 PUSHs(SvRV(*svp));
7144             else {
7145                 const bool constr = PL_op->op_private & whicharg;
7146                 PUSHs(S_rv2gv(aTHX_
7147                     svp && *svp ? *svp : &PL_sv_undef,
7148                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
7149                     !constr
7150                 ));
7151             }
7152             break;
7153         case OA_SCALARREF:
7154           if (!numargs) goto try_defsv;
7155           else {
7156             const bool wantscalar =
7157                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
7158             if (!svp || !*svp || !SvROK(*svp)
7159                 /* We have to permit globrefs even for the \$ proto, as
7160                    *foo is indistinguishable from ${\*foo}, and the proto-
7161                    type permits the latter. */
7162              || SvTYPE(SvRV(*svp)) > (
7163                      wantscalar       ? SVt_PVLV
7164                    : opnum == OP_LOCK || opnum == OP_UNDEF
7165                                       ? SVt_PVCV
7166                    :                    SVt_PVHV
7167                 )
7168                )
7169                 DIE(aTHX_
7170                  "Type of arg %d to &CORE::%s must be %s",
7171                   whicharg, PL_op_name[opnum],
7172                   wantscalar
7173                     ? "scalar reference"
7174                     : opnum == OP_LOCK || opnum == OP_UNDEF
7175                        ? "reference to one of [$@%&*]"
7176                        : "reference to one of [$@%*]"
7177                 );
7178             PUSHs(SvRV(*svp));
7179             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
7180                 /* Undo @_ localisation, so that sub exit does not undo
7181                    part of our undeffing. */
7182                 S_maybe_unwind_defav(aTHX);
7183             }
7184           }
7185           break;
7186         default:
7187             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
7188         }
7189         oa = oa >> 4;
7190     }
7191
7192     RETURN;
7193 }
7194
7195 /* Implement CORE::keys(),values(),each().
7196  *
7197  * We won't know until run-time whether the arg is an array or hash,
7198  * so this op calls
7199  *
7200  *    pp_keys/pp_values/pp_each
7201  * or
7202  *    pp_akeys/pp_avalues/pp_aeach
7203  *
7204  * as appropriate (or whatever pp function actually implements the OP_FOO
7205  * functionality for each FOO).
7206  */
7207
7208 PP(pp_avhvswitch)
7209 {
7210     return PL_ppaddr[
7211                 (SvTYPE(*PL_stack_sp) == SVt_PVAV ? OP_AEACH : OP_EACH)
7212                     + (PL_op->op_private & OPpAVHVSWITCH_MASK)
7213            ](aTHX);
7214 }
7215
7216 PP(pp_runcv)
7217 {
7218     CV *cv;
7219     if (PL_op->op_private & OPpOFFBYONE) {
7220         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
7221     }
7222     else cv = find_runcv(NULL);
7223
7224     rpp_extend(1);
7225     if (CvEVAL(cv))
7226         rpp_push_1(&PL_sv_undef);
7227     else
7228         rpp_push_1_norc(newRV((SV *)cv));
7229
7230     return NORMAL;
7231 }
7232
7233 static void
7234 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
7235                             const bool can_preserve)
7236 {
7237     const SSize_t ix = SvIV(keysv);
7238     if (can_preserve ? av_exists(av, ix) : TRUE) {
7239         SV ** const svp = av_fetch(av, ix, 1);
7240         if (!svp || !*svp)
7241             Perl_croak(aTHX_ PL_no_aelem, ix);
7242         save_aelem(av, ix, svp);
7243     }
7244     else
7245         SAVEADELETE(av, ix);
7246 }
7247
7248 static void
7249 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
7250                             const bool can_preserve)
7251 {
7252     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
7253         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
7254         SV ** const svp = he ? &HeVAL(he) : NULL;
7255         if (!svp || !*svp)
7256             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
7257         save_helem_flags(hv, keysv, svp, 0);
7258     }
7259     else
7260         SAVEHDELETE(hv, keysv);
7261 }
7262
7263 static void
7264 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
7265 {
7266     if (type == OPpLVREF_SV) {
7267         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
7268         GvSV(gv) = 0;
7269     }
7270     else if (type == OPpLVREF_AV)
7271         /* XXX Inefficient, as it creates a new AV, which we are
7272                about to clobber.  */
7273         save_ary(gv);
7274     else {
7275         assert(type == OPpLVREF_HV);
7276         /* XXX Likewise inefficient.  */
7277         save_hash(gv);
7278     }
7279 }
7280
7281
7282 PP_wrapped(pp_refassign,
7283       !!(PL_op->op_private & OPpLVREF_ELEM)
7284     + !!(PL_op->op_flags & OPf_STACKED)
7285     +1,
7286     0)
7287 {
7288     dSP;
7289     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
7290     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
7291     dTOPss;
7292     const char *bad = NULL;
7293     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
7294     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
7295     switch (type) {
7296     case OPpLVREF_SV:
7297         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
7298             bad = " SCALAR";
7299         break;
7300     case OPpLVREF_AV:
7301         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
7302             bad = "n ARRAY";
7303         break;
7304     case OPpLVREF_HV:
7305         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
7306             bad = " HASH";
7307         break;
7308     case OPpLVREF_CV:
7309         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
7310             bad = " CODE";
7311     }
7312     if (bad)
7313         /* diag_listed_as: Assigned value is not %s reference */
7314         DIE(aTHX_ "Assigned value is not a%s reference", bad);
7315     {
7316     MAGIC *mg;
7317     HV *stash;
7318     switch (left ? SvTYPE(left) : 0) {
7319     case 0:
7320     {
7321         SV * const old = PAD_SV(ARGTARG);
7322         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
7323         SvREFCNT_dec(old);
7324         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
7325                 == OPpLVAL_INTRO)
7326             SAVECLEARSV(PAD_SVl(ARGTARG));
7327         break;
7328     }
7329     case SVt_PVGV:
7330         if (PL_op->op_private & OPpLVAL_INTRO) {
7331             S_localise_gv_slot(aTHX_ (GV *)left, type);
7332         }
7333         gv_setref(left, sv);
7334         SvSETMAGIC(left);
7335         break;
7336     case SVt_PVAV:
7337         assert(key);
7338         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
7339             S_localise_aelem_lval(aTHX_ (AV *)left, key,
7340                                         SvCANEXISTDELETE(left));
7341         }
7342         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
7343         break;
7344     case SVt_PVHV:
7345         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
7346             assert(key);
7347             S_localise_helem_lval(aTHX_ (HV *)left, key,
7348                                         SvCANEXISTDELETE(left));
7349         }
7350         (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
7351     }
7352     if (PL_op->op_flags & OPf_MOD)
7353         SETs(sv_2mortal(newSVsv(sv)));
7354     /* XXX else can weak references go stale before they are read, e.g.,
7355        in leavesub?  */
7356     RETURN;
7357     }
7358 }
7359
7360 PP_wrapped(pp_lvref,
7361     !!(PL_op->op_private & OPpLVREF_ELEM) + !!(PL_op->op_flags & OPf_STACKED),
7362     0)
7363 {
7364     dSP;
7365     SV * const ret = newSV_type_mortal(SVt_PVMG);
7366     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
7367     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
7368     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
7369                                    &PL_vtbl_lvref, (char *)elem,
7370                                    elem ? HEf_SVKEY : (I32)ARGTARG);
7371     mg->mg_private = PL_op->op_private;
7372     if (PL_op->op_private & OPpLVREF_ITER)
7373         mg->mg_flags |= MGf_PERSIST;
7374     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
7375       if (elem) {
7376         MAGIC *mg;
7377         HV *stash;
7378         assert(arg);
7379         {
7380             const bool can_preserve = SvCANEXISTDELETE(arg);
7381             if (SvTYPE(arg) == SVt_PVAV)
7382               S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
7383             else
7384               S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
7385         }
7386       }
7387       else if (arg) {
7388         S_localise_gv_slot(aTHX_ (GV *)arg,
7389                                  PL_op->op_private & OPpLVREF_TYPE);
7390       }
7391       else if (!(PL_op->op_private & OPpPAD_STATE))
7392         SAVECLEARSV(PAD_SVl(ARGTARG));
7393     }
7394     XPUSHs(ret);
7395     RETURN;
7396 }
7397
7398 PP_wrapped(pp_lvrefslice, 0, 1)
7399 {
7400     dSP; dMARK;
7401     AV * const av = (AV *)POPs;
7402     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
7403     bool can_preserve = FALSE;
7404
7405     if (UNLIKELY(localizing)) {
7406         MAGIC *mg;
7407         HV *stash;
7408         SV **svp;
7409
7410         can_preserve = SvCANEXISTDELETE(av);
7411
7412         if (SvTYPE(av) == SVt_PVAV) {
7413             SSize_t max = -1;
7414
7415             for (svp = MARK + 1; svp <= SP; svp++) {
7416                 const SSize_t elem = SvIV(*svp);
7417                 if (elem > max)
7418                     max = elem;
7419             }
7420             if (max > AvMAX(av))
7421                 av_extend(av, max);
7422         }
7423     }
7424
7425     while (++MARK <= SP) {
7426         SV * const elemsv = *MARK;
7427         if (UNLIKELY(localizing)) {
7428             if (SvTYPE(av) == SVt_PVAV)
7429                 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
7430             else
7431                 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
7432         }
7433         *MARK = newSV_type_mortal(SVt_PVMG);
7434         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
7435     }
7436     RETURN;
7437 }
7438
7439 PP(pp_lvavref)
7440 {
7441     if (PL_op->op_flags & OPf_STACKED)
7442         Perl_pp_rv2av(aTHX);
7443     else
7444         Perl_pp_padav(aTHX);
7445     {
7446         /* shift the return value up one and insert below it a special
7447          * alias marker that aassign recognises */
7448         rpp_extend(1);
7449         PL_stack_sp[1] = PL_stack_sp[0];
7450         PL_stack_sp[0] = NULL;
7451         PL_stack_sp++;
7452         return NORMAL;
7453     }
7454 }
7455
7456 PP(pp_anonconst)
7457 {
7458     SV *sv = *PL_stack_sp;
7459
7460     CV* constsub = newCONSTSUB(
7461         SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV ? CopSTASH(PL_curcop) : NULL,
7462         NULL,
7463         SvREFCNT_inc_simple_NN(sv)
7464     );
7465
7466     SV* ret_sv = sv_2mortal((SV *)constsub);
7467
7468     /* Prior to Perl 5.38 anonconst ops always fed into srefgen.
7469        5.38 redefined anonconst to create the reference without srefgen.
7470        OPf_REF was added to the op. In case some XS code out there creates
7471        anonconst the old way, we accommodate OPf_REF's absence here.
7472     */
7473     if (LIKELY(PL_op->op_flags & OPf_REF)) {
7474         ret_sv = refto(ret_sv);
7475     }
7476
7477     rpp_replace_1_1(ret_sv);
7478     return NORMAL;
7479 }
7480
7481
7482 /* process one subroutine argument - typically when the sub has a signature:
7483  * introduce PL_curpad[op_targ] and assign to it the value
7484  *  for $:   (OPf_STACKED ? *sp : $_[N])
7485  *  for @/%: @_[N..$#_]
7486  *
7487  * It's equivalent to
7488  *    my $foo = $_[N];
7489  * or
7490  *    my $foo = (value-on-stack)
7491  * or
7492  *    my @foo = @_[N..$#_]
7493  * etc
7494  */
7495
7496 PP_wrapped(pp_argelem,
7497         !!(      (PL_op->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV
7498             &&   (PL_op->op_flags & OPf_STACKED)),
7499         0)
7500 {
7501     dTARG;
7502     SV *val;
7503     SV ** padentry;
7504     OP *o = PL_op;
7505     AV *defav = GvAV(PL_defgv); /* @_ */
7506     IV ix = PTR2IV(cUNOP_AUXo->op_aux);
7507     IV argc;
7508
7509     /* do 'my $var, @var or %var' action */
7510     padentry = &(PAD_SVl(o->op_targ));
7511     save_clearsv(padentry);
7512     targ = *padentry;
7513
7514     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
7515         if (o->op_flags & OPf_STACKED) {
7516             dSP;
7517             val = POPs;
7518             PUTBACK;
7519         }
7520         else {
7521             SV **svp;
7522             /* should already have been checked */
7523             assert(ix >= 0);
7524 #if IVSIZE > PTRSIZE
7525             assert(ix <= SSize_t_MAX);
7526 #endif
7527
7528             svp = av_fetch(defav, ix, FALSE);
7529             val = svp ? *svp : &PL_sv_undef;
7530         }
7531
7532         /* $var = $val */
7533
7534         /* cargo-culted from pp_sassign */
7535         assert(TAINTING_get || !TAINT_get);
7536         if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
7537             TAINT_NOT;
7538
7539         SvSetMagicSV(targ, val);
7540         return o->op_next;
7541     }
7542
7543     /* must be AV or HV */
7544
7545     assert(!(o->op_flags & OPf_STACKED));
7546     argc = ((IV)AvFILL(defav) + 1) - ix;
7547
7548     /* This is a copy of the relevant parts of pp_aassign().
7549      */
7550     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
7551         IV i;
7552
7553         if (AvFILL((AV*)targ) > -1) {
7554             /* target should usually be empty. If we get get
7555              * here, someone's been doing some weird closure tricks.
7556              * Make a copy of all args before clearing the array,
7557              * to avoid the equivalent of @a = ($a[0]) prematurely freeing
7558              * elements. See similar code in pp_aassign.
7559              */
7560             for (i = 0; i < argc; i++) {
7561                 SV **svp = av_fetch(defav, ix + i, FALSE);
7562                 SV *newsv = newSVsv_flags(svp ? *svp : &PL_sv_undef,
7563                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7564                 if (!av_store(defav, ix + i, newsv))
7565                     SvREFCNT_dec_NN(newsv);
7566             }
7567             av_clear((AV*)targ);
7568         }
7569
7570         if (argc <= 0)
7571             return o->op_next;
7572
7573         av_extend((AV*)targ, argc);
7574
7575         i = 0;
7576         while (argc--) {
7577             SV *tmpsv;
7578             SV **svp = av_fetch(defav, ix + i, FALSE);
7579             SV *val = svp ? *svp : &PL_sv_undef;
7580             tmpsv = newSV_type(SVt_NULL);
7581             sv_setsv(tmpsv, val);
7582             av_store((AV*)targ, i++, tmpsv);
7583             TAINT_NOT;
7584         }
7585
7586     }
7587     else {
7588         IV i;
7589
7590         assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
7591
7592         if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
7593             /* see "target should usually be empty" comment above */
7594             for (i = 0; i < argc; i++) {
7595                 SV **svp = av_fetch(defav, ix + i, FALSE);
7596                 SV *newsv = newSV_type(SVt_NULL);
7597                 sv_setsv_flags(newsv,
7598                                 svp ? *svp : &PL_sv_undef,
7599                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7600                 if (!av_store(defav, ix + i, newsv))
7601                     SvREFCNT_dec_NN(newsv);
7602             }
7603             hv_clear((HV*)targ);
7604         }
7605
7606         if (argc <= 0)
7607             return o->op_next;
7608         assert(argc % 2 == 0);
7609
7610         i = 0;
7611         while (argc) {
7612             SV *tmpsv;
7613             SV **svp;
7614             SV *key;
7615             SV *val;
7616
7617             svp = av_fetch(defav, ix + i++, FALSE);
7618             key = svp ? *svp : &PL_sv_undef;
7619             svp = av_fetch(defav, ix + i++, FALSE);
7620             val = svp ? *svp : &PL_sv_undef;
7621
7622             argc -= 2;
7623             if (UNLIKELY(SvGMAGICAL(key)))
7624                 key = sv_mortalcopy(key);
7625             tmpsv = newSV_type(SVt_NULL);
7626             sv_setsv(tmpsv, val);
7627             hv_store_ent((HV*)targ, key, tmpsv, 0);
7628             TAINT_NOT;
7629         }
7630     }
7631
7632     return o->op_next;
7633 }
7634
7635 /* Handle a default value for one subroutine argument (typically as part
7636  * of a subroutine signature).
7637  * It's equivalent to
7638  *    @_ > op_targ ? $_[op_targ] : result_of(op_other)
7639  *
7640  * Intended to be used where op_next is an OP_ARGELEM
7641  *
7642  * We abuse the op_targ field slightly: it's an index into @_ rather than
7643  * into PL_curpad.
7644  */
7645
7646 PP(pp_argdefelem)
7647 {
7648     OP * const o = PL_op;
7649     AV *defav = GvAV(PL_defgv); /* @_ */
7650     IV ix = (IV)o->op_targ;
7651
7652     assert(ix >= 0);
7653 #if IVSIZE > PTRSIZE
7654     assert(ix <= SSize_t_MAX);
7655 #endif
7656
7657     if (AvFILL(defav) < ix)
7658         return cLOGOPo->op_other;
7659
7660     SV **svp = av_fetch(defav, ix, FALSE);
7661     SV  *val = svp ? *svp : &PL_sv_undef;
7662
7663     if ((PL_op->op_private & OPpARG_IF_UNDEF) && !SvOK(val))
7664         return cLOGOPo->op_other;
7665     if ((PL_op->op_private & OPpARG_IF_FALSE) && !SvTRUE(val))
7666         return cLOGOPo->op_other;
7667
7668     rpp_xpush_1(val);
7669     return NORMAL;
7670 }
7671
7672
7673 static SV *
7674 S_find_runcv_name(void)
7675 {
7676     dTHX;
7677     CV *cv;
7678     GV *gv;
7679     SV *sv;
7680
7681     cv = find_runcv(0);
7682     if (!cv)
7683         return &PL_sv_no;
7684
7685     gv = CvGV(cv);
7686     if (!gv)
7687         return &PL_sv_no;
7688
7689     sv = sv_newmortal();
7690     gv_fullname4(sv, gv, NULL, TRUE);
7691     return sv;
7692 }
7693
7694 /* Check a sub's arguments - i.e. that it has the correct number of args
7695  * (and anything else we might think of in future). Typically used with
7696  * signatured subs.
7697  */
7698
7699 PP(pp_argcheck)
7700 {
7701     OP * const o       = PL_op;
7702     struct op_argcheck_aux *aux = (struct op_argcheck_aux *)cUNOP_AUXo->op_aux;
7703     UV   params        = aux->params;
7704     UV   opt_params    = aux->opt_params;
7705     char slurpy        = aux->slurpy;
7706     AV  *defav         = GvAV(PL_defgv); /* @_ */
7707     UV   argc;
7708     bool too_few;
7709
7710     assert(!SvMAGICAL(defav));
7711     argc = (UV)(AvFILLp(defav) + 1);
7712     too_few = (argc < (params - opt_params));
7713
7714     if (UNLIKELY(too_few || (!slurpy && argc > params)))
7715
7716         /* diag_listed_as: Too few arguments for subroutine '%s' (got %d; expected %d) */
7717         /* diag_listed_as: Too few arguments for subroutine '%s' (got %d; expected at least %d) */
7718         /* diag_listed_as: Too many arguments for subroutine '%s' (got %d; expected %d) */
7719         /* diag_listed_as: Too many arguments for subroutine '%s' (got %d; expected at most %d)*/
7720         Perl_croak_caller("Too %s arguments for subroutine '%" SVf "' (got %" UVuf "; expected %s%" UVuf ")",
7721                           too_few ? "few" : "many",
7722                           S_find_runcv_name(),
7723                           argc,
7724                           too_few ? (slurpy || opt_params ? "at least " : "") : (opt_params ? "at most " : ""),
7725                           too_few ? (params - opt_params) : params);
7726
7727     if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
7728         /* diag_listed_as: Odd name/value argument for subroutine '%s' */
7729         Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
7730                           S_find_runcv_name());
7731
7732     return NORMAL;
7733 }
7734
7735 PP_wrapped(pp_isa, 2, 0)
7736 {
7737     dSP;
7738     SV *left, *right;
7739
7740     right = POPs;
7741     left  = TOPs;
7742
7743     SETs(boolSV(sv_isa_sv(left, right)));
7744     RETURN;
7745 }
7746
7747
7748 PP(pp_cmpchain_and)
7749 {
7750     SV *result = PL_stack_sp[0];
7751     if (SvTRUE_NN(result)) {
7752         rpp_popfree_1();
7753         return cLOGOP->op_other;
7754     } else {
7755         rpp_replace_2_1(result);
7756         return NORMAL;
7757     }
7758 }
7759
7760
7761 PP(pp_cmpchain_dup)
7762 {
7763     SV *right = PL_stack_sp[0];
7764     SV *left  = PL_stack_sp[-1];
7765     PL_stack_sp[-1] = right;
7766     PL_stack_sp[0]  = left;
7767     rpp_xpush_1(right);
7768     return NORMAL;
7769 }
7770
7771
7772 PP(pp_is_bool)
7773 {
7774     SV *arg = *PL_stack_sp;
7775
7776     SvGETMAGIC(arg);
7777
7778     rpp_replace_1_1(boolSV(SvIsBOOL(arg)));
7779     return NORMAL;
7780 }
7781
7782 PP(pp_is_weak)
7783 {
7784     SV *arg = *PL_stack_sp;
7785
7786     SvGETMAGIC(arg);
7787
7788     rpp_replace_1_1(boolSV(SvWEAKREF(arg)));
7789     return NORMAL;
7790 }
7791
7792 PP(pp_weaken)
7793 {
7794     sv_rvweaken(*PL_stack_sp);
7795     rpp_popfree_1();
7796     return NORMAL;
7797 }
7798
7799 PP(pp_unweaken)
7800 {
7801     sv_rvunweaken(*PL_stack_sp);
7802     rpp_popfree_1();
7803     return NORMAL;
7804 }
7805
7806 PP(pp_blessed)
7807 {
7808     SV *arg = *PL_stack_sp;
7809     SV *rv, *ret;
7810
7811     SvGETMAGIC(arg);
7812
7813     if(!SvROK(arg) || !SvOBJECT((rv = SvRV(arg)))) {
7814         ret = &PL_sv_undef;
7815         goto ret;
7816     }
7817
7818     if((PL_op->op_private & OPpTRUEBOOL) ||
7819             ((PL_op->op_private & OPpMAYBE_TRUEBOOL) && (block_gimme() == G_VOID))) {
7820         /* We only care about the boolean truth, not the specific string value.
7821          * We just have to check for the annoying cornercase of the package
7822          * named "0" */
7823         HV *stash = SvSTASH(rv);
7824         HEK *hek = HvNAME_HEK(stash);
7825         if(!hek)
7826             goto fallback;
7827         I32 len = HEK_LEN(hek);
7828         if(UNLIKELY(len == HEf_SVKEY || (len == 1 && HEK_KEY(hek)[0] == '0')))
7829             goto fallback;
7830
7831         ret = &PL_sv_yes;
7832         goto ret;
7833     }
7834     else {
7835 fallback:
7836         ret = (sv_ref(NULL, rv, TRUE));
7837     }
7838
7839   ret:
7840     rpp_replace_1_1(ret);
7841     return NORMAL;
7842 }
7843
7844 PP(pp_refaddr)
7845 {
7846     dTARGET;
7847     SV *arg = *PL_stack_sp;
7848
7849     SvGETMAGIC(arg);
7850
7851     if(SvROK(arg))
7852         sv_setuv_mg(TARG, PTR2UV(SvRV(arg)));
7853     else
7854         sv_setsv(TARG, &PL_sv_undef);
7855
7856     rpp_replace_1_1(TARG);
7857     return NORMAL;
7858 }
7859
7860 PP(pp_reftype)
7861 {
7862     dTARGET;
7863     SV *arg = *PL_stack_sp;
7864
7865     SvGETMAGIC(arg);
7866
7867     if(SvROK(arg))
7868         sv_setpv_mg(TARG, sv_reftype(SvRV(arg), FALSE));
7869     else
7870         sv_setsv(TARG, &PL_sv_undef);
7871
7872     rpp_replace_1_1(TARG);
7873     return NORMAL;
7874 }
7875
7876 PP(pp_ceil)
7877 {
7878     dTARGET;
7879     TARGn(Perl_ceil(SvNVx(*PL_stack_sp)), 1);
7880     rpp_replace_1_1(TARG);
7881     return NORMAL;
7882 }
7883
7884 PP(pp_floor)
7885 {
7886     dTARGET;
7887     TARGn(Perl_floor(SvNVx(*PL_stack_sp)), 1);
7888     rpp_replace_1_1(TARG);
7889     return NORMAL;
7890 }
7891
7892 PP(pp_is_tainted)
7893 {
7894     SV *arg = *PL_stack_sp;
7895
7896     SvGETMAGIC(arg);
7897
7898     rpp_replace_1_1(boolSV(SvTAINTED(arg)));
7899     return NORMAL;
7900 }
7901
7902 /*
7903  * ex: set ts=8 sts=4 sw=4 et:
7904  */