[perl5.git] / pp.c

/*    pp.c
 *
 *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
 *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * 'It's a big house this, and very peculiar.  Always a bit more
 *  to discover, and no knowing what you'll find round a corner.
 *  And Elves, sir!'                            --Samwise Gamgee
 *
 *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
 */

/* This file contains general pp ("push/pop") functions that execute the
 * opcodes that make up a perl program. A typical pp function expects to
 * find its arguments on the stack, and usually pushes its results onto
 * the stack, hence the 'pp' terminology. Each OP structure contains
 * a pointer to the relevant pp_foo() function.
 */

#include "EXTERN.h"
#define PERL_IN_PP_C
#include "perl.h"
#include "keywords.h"

#include "invlist_inline.h"
#include "reentr.h"
#include "regcharclass.h"

/* variations on pp_null */

PP(pp_stub)
{
    dSP;
    if (GIMME_V == G_SCALAR)
	XPUSHs(&PL_sv_undef);
    RETURN;
}

/* Pushy stuff. */


PP(pp_padcv)
{
    dSP; dTARGET;
    assert(SvTYPE(TARG) == SVt_PVCV);
    XPUSHs(TARG);
    RETURN;
}

PP(pp_introcv)
{
    dTARGET;
    SvPADSTALE_off(TARG);
    return NORMAL;
}

PP(pp_clonecv)
{
    dTARGET;
    CV * const protocv = PadnamePROTOCV(
	PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
    );
    assert(SvTYPE(TARG) == SVt_PVCV);
    assert(protocv);
    if (CvISXSUB(protocv)) { /* constant */
	/* XXX Should we clone it here? */
	/* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
	   to introcv and remove the SvPADSTALE_off. */
	SAVEPADSVANDMORTALIZE(ARGTARG);
	PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
    }
    else {
	if (CvROOT(protocv)) {
	    assert(CvCLONE(protocv));
	    assert(!CvCLONED(protocv));
	}
	cv_clone_into(protocv,(CV *)TARG);
	SAVECLEARSV(PAD_SVl(ARGTARG));
    }
    return NORMAL;
}

/* Translations. */

/* In some cases this function inspects PL_op.  If this function is called
   for new op types, more bool parameters may need to be added in place of
   the checks.

   When noinit is true, the absence of a gv will cause a retval of undef.
   This is unrelated to the cv-to-gv assignment case.
*/

static SV *
S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
              const bool noinit)
{
    if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
    if (SvROK(sv)) {
	if (SvAMAGIC(sv)) {
	    sv = amagic_deref_call(sv, to_gv_amg);
	}
      wasref:
	sv = SvRV(sv);
	if (SvTYPE(sv) == SVt_PVIO) {
	    GV * const gv = MUTABLE_GV(sv_newmortal());
	    gv_init(gv, 0, "__ANONIO__", 10, 0);
	    GvIOp(gv) = MUTABLE_IO(sv);
	    SvREFCNT_inc_void_NN(sv);
	    sv = MUTABLE_SV(gv);
	}
	else if (!isGV_with_GP(sv)) {
	    Perl_die(aTHX_ "Not a GLOB reference");
        }
    }
    else {
	if (!isGV_with_GP(sv)) {
	    if (!SvOK(sv)) {
		/* If this is a 'my' scalar and flag is set then vivify
		 * NI-S 1999/05/07
		 */
		if (vivify_sv && sv != &PL_sv_undef) {
		    GV *gv;
		    HV *stash;
		    if (SvREADONLY(sv))
			Perl_croak_no_modify();
		    gv = MUTABLE_GV(newSV(0));
		    stash = CopSTASH(PL_curcop);
		    if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
		    if (cUNOP->op_targ) {
			SV * const namesv = PAD_SV(cUNOP->op_targ);
			gv_init_sv(gv, stash, namesv, 0);
		    }
		    else {
			gv_init_pv(gv, stash, "__ANONIO__", 0);
		    }
		    prepare_SV_for_RV(sv);
		    SvRV_set(sv, MUTABLE_SV(gv));
		    SvROK_on(sv);
		    SvSETMAGIC(sv);
		    goto wasref;
		}
		if (PL_op->op_flags & OPf_REF || strict) {
		    Perl_die(aTHX_ PL_no_usym, "a symbol");
                }
		if (ckWARN(WARN_UNINITIALIZED))
		    report_uninit(sv);
		return &PL_sv_undef;
	    }
	    if (noinit)
	    {
		if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
		           sv, GV_ADDMG, SVt_PVGV
		   ))))
		    return &PL_sv_undef;
	    }
	    else {
		if (strict) {
                    Perl_die(aTHX_
                             PL_no_symref_sv,
                             sv,
                             (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
                             "a symbol"
                             );
                }
		if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
		    == OPpDONT_INIT_GV) {
		    /* We are the target of a coderef assignment.  Return
		       the scalar unchanged, and let pp_sasssign deal with
		       things.  */
		    return sv;
		}
		sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
	    }
	    /* FAKE globs in the symbol table cause weird bugs (#77810) */
	    SvFAKE_off(sv);
	}
    }
    if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
	SV *newsv = sv_newmortal();
	sv_setsv_flags(newsv, sv, 0);
	SvFAKE_off(newsv);
	sv = newsv;
    }
    return sv;
}

PP(pp_rv2gv)
{
    dSP; dTOPss;

    sv = S_rv2gv(aTHX_
          sv, PL_op->op_private & OPpDEREF,
          PL_op->op_private & HINT_STRICT_REFS,
          ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
             || PL_op->op_type == OP_READLINE
         );
    if (PL_op->op_private & OPpLVAL_INTRO)
	save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
    SETs(sv);
    RETURN;
}

/* Helper function for pp_rv2sv and pp_rv2av  */
GV *
Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
		const svtype type, SV ***spp)
{
    GV *gv;

    PERL_ARGS_ASSERT_SOFTREF2XV;

    if (PL_op->op_private & HINT_STRICT_REFS) {
	if (SvOK(sv))
	    Perl_die(aTHX_ PL_no_symref_sv, sv,
		     (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
	else
	    Perl_die(aTHX_ PL_no_usym, what);
    }
    if (!SvOK(sv)) {
	if (
	  PL_op->op_flags & OPf_REF
	)
	    Perl_die(aTHX_ PL_no_usym, what);
	if (ckWARN(WARN_UNINITIALIZED))
	    report_uninit(sv);
	if (type != SVt_PV && GIMME_V == G_ARRAY) {
	    (*spp)--;
	    return NULL;
	}
	**spp = &PL_sv_undef;
	return NULL;
    }
    if ((PL_op->op_flags & OPf_SPECIAL) &&
	!(PL_op->op_flags & OPf_MOD))
	{
	    if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
		{
		    **spp = &PL_sv_undef;
		    return NULL;
		}
	}
    else {
	gv = gv_fetchsv_nomg(sv, GV_ADD, type);
    }
    return gv;
}

PP(pp_rv2sv)
{
    dSP; dTOPss;
    GV *gv = NULL;

    SvGETMAGIC(sv);
    if (SvROK(sv)) {
	if (SvAMAGIC(sv)) {
	    sv = amagic_deref_call(sv, to_sv_amg);
	}

	sv = SvRV(sv);
	if (SvTYPE(sv) >= SVt_PVAV)
	    DIE(aTHX_ "Not a SCALAR reference");
    }
    else {
	gv = MUTABLE_GV(sv);

	if (!isGV_with_GP(gv)) {
	    gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
	    if (!gv)
		RETURN;
	}
	sv = GvSVn(gv);
    }
    if (PL_op->op_flags & OPf_MOD) {
	if (PL_op->op_private & OPpLVAL_INTRO) {
	    if (cUNOP->op_first->op_type == OP_NULL)
		sv = save_scalar(MUTABLE_GV(TOPs));
	    else if (gv)
		sv = save_scalar(gv);
	    else
		Perl_croak(aTHX_ "%s", PL_no_localize_ref);
	}
	else if (PL_op->op_private & OPpDEREF)
	    sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
    }
    SPAGAIN; /* in case chasing soft refs reallocated the stack */
    SETs(sv);
    RETURN;
}

PP(pp_av2arylen)
{
    dSP;
    AV * const av = MUTABLE_AV(TOPs);
    const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
    if (lvalue) {
	SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
	if (!*svp) {
	    *svp = newSV_type(SVt_PVMG);
	    sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
	}
	SETs(*svp);
    } else {
	SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
    }
    RETURN;
}

PP(pp_pos)
{
    dSP; dTOPss;

    if (PL_op->op_flags & OPf_MOD || LVRET) {
	SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
	sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
	LvTYPE(ret) = '.';
	LvTARG(ret) = SvREFCNT_inc_simple(sv);
	SETs(ret);    /* no SvSETMAGIC */
    }
    else {
	    const MAGIC * const mg = mg_find_mglob(sv);
	    if (mg && mg->mg_len != -1) {
		STRLEN i = mg->mg_len;
                if (PL_op->op_private & OPpTRUEBOOL)
                    SETs(i ? &PL_sv_yes : &PL_sv_zero);
                else {
                    dTARGET;
                    if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
                        i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
                    SETu(i);
                }
		return NORMAL;
	    }
	    SETs(&PL_sv_undef);
    }
    return NORMAL;
}

PP(pp_rv2cv)
{
    dSP;
    GV *gv;
    HV *stash_unused;
    const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
	? GV_ADDMG
	: ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
                                                    == OPpMAY_RETURN_CONSTANT)
	    ? GV_ADD|GV_NOEXPAND
	    : GV_ADD;
    /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
    /* (But not in defined().) */

    CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
    if (cv) NOOP;
    else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
	cv = SvTYPE(SvRV(gv)) == SVt_PVCV
	    ? MUTABLE_CV(SvRV(gv))
	    : MUTABLE_CV(gv);
    }
    else
	cv = MUTABLE_CV(&PL_sv_undef);
    SETs(MUTABLE_SV(cv));
    return NORMAL;
}

PP(pp_prototype)
{
    dSP;
    CV *cv;
    HV *stash;
    GV *gv;
    SV *ret = &PL_sv_undef;

    if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
    if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
	const char * s = SvPVX_const(TOPs);
        if (memBEGINs(s, SvCUR(TOPs), "CORE::")) {
	    const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
	    if (!code)
		DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
		   UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
	    {
		SV * const sv = core_prototype(NULL, s + 6, code, NULL);
		if (sv) ret = sv;
	    }
	    goto set;
	}
    }
    cv = sv_2cv(TOPs, &stash, &gv, 0);
    if (cv && SvPOK(cv))
	ret = newSVpvn_flags(
	    CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
	);
  set:
    SETs(ret);
    RETURN;
}

PP(pp_anoncode)
{
    dSP;
    CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
    if (CvCLONE(cv))
	cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
    EXTEND(SP,1);
    PUSHs(MUTABLE_SV(cv));
    RETURN;
}

PP(pp_srefgen)
{
    dSP;
    *SP = refto(*SP);
    return NORMAL;
}

PP(pp_refgen)
{
    dSP; dMARK;
    if (GIMME_V != G_ARRAY) {
	if (++MARK <= SP)
	    *MARK = *SP;
	else
	{
	    MEXTEND(SP, 1);
	    *MARK = &PL_sv_undef;
	}
	*MARK = refto(*MARK);
	SP = MARK;
	RETURN;
    }
    EXTEND_MORTAL(SP - MARK);
    while (++MARK <= SP)
	*MARK = refto(*MARK);
    RETURN;
}

STATIC SV*
S_refto(pTHX_ SV *sv)
{
    SV* rv;

    PERL_ARGS_ASSERT_REFTO;

    if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
	if (LvTARGLEN(sv))
	    vivify_defelem(sv);
	if (!(sv = LvTARG(sv)))
	    sv = &PL_sv_undef;
	else
	    SvREFCNT_inc_void_NN(sv);
    }
    else if (SvTYPE(sv) == SVt_PVAV) {
	if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
	    av_reify(MUTABLE_AV(sv));
	SvTEMP_off(sv);
	SvREFCNT_inc_void_NN(sv);
    }
    else if (SvPADTMP(sv)) {
        sv = newSVsv(sv);
    }
    else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem)))
        sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem);
    else {
	SvTEMP_off(sv);
	SvREFCNT_inc_void_NN(sv);
    }
    rv = sv_newmortal();
    sv_upgrade(rv, SVt_IV);
    SvRV_set(rv, sv);
    SvROK_on(rv);
    return rv;
}

PP(pp_ref)
{
    dSP;
    SV * const sv = TOPs;

    SvGETMAGIC(sv);
    if (!SvROK(sv)) {
	SETs(&PL_sv_no);
        return NORMAL;
    }

    /* op is in boolean context? */
    if (   (PL_op->op_private & OPpTRUEBOOL)
        || (   (PL_op->op_private & OPpMAYBE_TRUEBOOL)
            && block_gimme() == G_VOID))
    {
        /* refs are always true - unless it's to an object blessed into a
         * class with a false name, i.e. "0". So we have to check for
         * that remote possibility. The following is is basically an
         * unrolled SvTRUE(sv_reftype(rv)) */
        SV * const rv = SvRV(sv);
        if (SvOBJECT(rv)) {
            HV *stash = SvSTASH(rv);
            HEK *hek = HvNAME_HEK(stash);
            if (hek) {
                I32 len = HEK_LEN(hek);
                /* bail out and do it the hard way? */
                if (UNLIKELY(
                       len == HEf_SVKEY
                    || (len == 1 && HEK_KEY(hek)[0] == '0')
                ))
                    goto do_sv_ref;
            }
        }
        SETs(&PL_sv_yes);
        return NORMAL;
    }

  do_sv_ref:
    {
	dTARGET;
	SETs(TARG);
	sv_ref(TARG, SvRV(sv), TRUE);
	SvSETMAGIC(TARG);
	return NORMAL;
    }

}


PP(pp_bless)
{
    dSP;
    HV *stash;

    if (MAXARG == 1)
    {
      curstash:
	stash = CopSTASH(PL_curcop);
	if (SvTYPE(stash) != SVt_PVHV)
	    Perl_croak(aTHX_ "Attempt to bless into a freed package");
    }
    else {
	SV * const ssv = POPs;
	STRLEN len;
	const char *ptr;

	if (!ssv) goto curstash;
	SvGETMAGIC(ssv);
	if (SvROK(ssv)) {
	  if (!SvAMAGIC(ssv)) {
	   frog:
	    Perl_croak(aTHX_ "Attempt to bless into a reference");
	  }
	  /* SvAMAGIC is on here, but it only means potentially overloaded,
	     so after stringification: */
	  ptr = SvPV_nomg_const(ssv,len);
	  /* We need to check the flag again: */
	  if (!SvAMAGIC(ssv)) goto frog;
	}
	else ptr = SvPV_nomg_const(ssv,len);
	if (len == 0)
	    Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
			   "Explicit blessing to '' (assuming package main)");
	stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
    }

    (void)sv_bless(TOPs, stash);
    RETURN;
}

PP(pp_gelem)
{
    dSP;

    SV *sv = POPs;
    STRLEN len;
    const char * const elem = SvPV_const(sv, len);
    GV * const gv = MUTABLE_GV(TOPs);
    SV * tmpRef = NULL;

    sv = NULL;
    if (elem) {
	/* elem will always be NUL terminated.  */
	switch (*elem) {
	case 'A':
	    if (memEQs(elem, len, "ARRAY"))
	    {
		tmpRef = MUTABLE_SV(GvAV(gv));
		if (tmpRef && !AvREAL((const AV *)tmpRef)
		 && AvREIFY((const AV *)tmpRef))
		    av_reify(MUTABLE_AV(tmpRef));
	    }
	    break;
	case 'C':
	    if (memEQs(elem, len, "CODE"))
		tmpRef = MUTABLE_SV(GvCVu(gv));
	    break;
	case 'F':
	    if (memEQs(elem, len, "FILEHANDLE")) {
		tmpRef = MUTABLE_SV(GvIOp(gv));
	    }
	    else
		if (memEQs(elem, len, "FORMAT"))
		    tmpRef = MUTABLE_SV(GvFORM(gv));
	    break;
	case 'G':
	    if (memEQs(elem, len, "GLOB"))
		tmpRef = MUTABLE_SV(gv);
	    break;
	case 'H':
	    if (memEQs(elem, len, "HASH"))
		tmpRef = MUTABLE_SV(GvHV(gv));
	    break;
	case 'I':
	    if (memEQs(elem, len, "IO"))
		tmpRef = MUTABLE_SV(GvIOp(gv));
	    break;
	case 'N':
	    if (memEQs(elem, len, "NAME"))
		sv = newSVhek(GvNAME_HEK(gv));
	    break;
	case 'P':
	    if (memEQs(elem, len, "PACKAGE")) {
		const HV * const stash = GvSTASH(gv);
		const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
		sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
	    }
	    break;
	case 'S':
	    if (memEQs(elem, len, "SCALAR"))
		tmpRef = GvSVn(gv);
	    break;
	}
    }
    if (tmpRef)
	sv = newRV(tmpRef);
    if (sv)
	sv_2mortal(sv);
    else
	sv = &PL_sv_undef;
    SETs(sv);
    RETURN;
}

/* Pattern matching */

PP(pp_study)
{
    dSP; dTOPss;
    STRLEN len;

    (void)SvPV(sv, len);
    if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
	/* Historically, study was skipped in these cases. */
	SETs(&PL_sv_no);
	return NORMAL;
    }

    /* Make study a no-op. It's no longer useful and its existence
       complicates matters elsewhere. */
    SETs(&PL_sv_yes);
    return NORMAL;
}


/* also used for: pp_transr() */

PP(pp_trans)
{
    dSP;
    SV *sv;

    if (PL_op->op_flags & OPf_STACKED)
	sv = POPs;
    else {
	EXTEND(SP,1);
	if (ARGTARG)
	    sv = PAD_SV(ARGTARG);
	else {
	    sv = DEFSV;
	}
    }
    if(PL_op->op_type == OP_TRANSR) {
	STRLEN len;
	const char * const pv = SvPV(sv,len);
	SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
	do_trans(newsv);
	PUSHs(newsv);
    }
    else {
	Size_t i = do_trans(sv);
	mPUSHi((UV)i);
    }
    RETURN;
}

/* Lvalue operators. */

static size_t
S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
{
    STRLEN len;
    char *s;
    size_t count = 0;

    PERL_ARGS_ASSERT_DO_CHOMP;

    if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
	return 0;
    if (SvTYPE(sv) == SVt_PVAV) {
	I32 i;
	AV *const av = MUTABLE_AV(sv);
	const I32 max = AvFILL(av);

	for (i = 0; i <= max; i++) {
	    sv = MUTABLE_SV(av_fetch(av, i, FALSE));
	    if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
		count += do_chomp(retval, sv, chomping);
	}
        return count;
    }
    else if (SvTYPE(sv) == SVt_PVHV) {
	HV* const hv = MUTABLE_HV(sv);
	HE* entry;
        (void)hv_iterinit(hv);
        while ((entry = hv_iternext(hv)))
            count += do_chomp(retval, hv_iterval(hv,entry), chomping);
	return count;
    }
    else if (SvREADONLY(sv)) {
            Perl_croak_no_modify();
    }

    s = SvPV(sv, len);
    if (chomping) {
	if (s && len) {
	    char *temp_buffer = NULL;
	    SV *svrecode = NULL;
	    s += --len;
	    if (RsPARA(PL_rs)) {
		if (*s != '\n')
		    goto nope_free_nothing;
		++count;
		while (len && s[-1] == '\n') {
		    --len;
		    --s;
		    ++count;
		}
	    }
	    else {
		STRLEN rslen, rs_charlen;
		const char *rsptr = SvPV_const(PL_rs, rslen);

		rs_charlen = SvUTF8(PL_rs)
		    ? sv_len_utf8(PL_rs)
		    : rslen;

		if (SvUTF8(PL_rs) != SvUTF8(sv)) {
		    /* Assumption is that rs is shorter than the scalar.  */
		    if (SvUTF8(PL_rs)) {
			/* RS is utf8, scalar is 8 bit.  */
			bool is_utf8 = TRUE;
			temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
							     &rslen, &is_utf8);
			if (is_utf8) {
			    /* Cannot downgrade, therefore cannot possibly match.
			       At this point, temp_buffer is not alloced, and
			       is the buffer inside PL_rs, so dont free it.
			     */
			    assert (temp_buffer == rsptr);
			    goto nope_free_sv;
			}
			rsptr = temp_buffer;
		    }
		    else {
			/* RS is 8 bit, scalar is utf8.  */
			temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
			rsptr = temp_buffer;
		    }
		}
		if (rslen == 1) {
		    if (*s != *rsptr)
			goto nope_free_all;
		    ++count;
		}
		else {
		    if (len < rslen - 1)
			goto nope_free_all;
		    len -= rslen - 1;
		    s -= rslen - 1;
		    if (memNE(s, rsptr, rslen))
			goto nope_free_all;
		    count += rs_charlen;
		}
	    }
	    SvPV_force_nomg_nolen(sv);
	    SvCUR_set(sv, len);
	    *SvEND(sv) = '\0';
	    SvNIOK_off(sv);
	    SvSETMAGIC(sv);

	    nope_free_all:
	    Safefree(temp_buffer);
	    nope_free_sv:
	    SvREFCNT_dec(svrecode);
	    nope_free_nothing: ;
	}
    } else {
	if (len && (!SvPOK(sv) || SvIsCOW(sv)))
	    s = SvPV_force_nomg(sv, len);
	if (DO_UTF8(sv)) {
	    if (s && len) {
		char * const send = s + len;
		char * const start = s;
		s = send - 1;
		while (s > start && UTF8_IS_CONTINUATION(*s))
		    s--;
		if (is_utf8_string((U8*)s, send - s)) {
		    sv_setpvn(retval, s, send - s);
		    *s = '\0';
		    SvCUR_set(sv, s - start);
		    SvNIOK_off(sv);
		    SvUTF8_on(retval);
		}
	    }
	    else
                SvPVCLEAR(retval);
	}
	else if (s && len) {
	    s += --len;
	    sv_setpvn(retval, s, 1);
	    *s = '\0';
	    SvCUR_set(sv, len);
	    SvUTF8_off(sv);
	    SvNIOK_off(sv);
	}
	else
            SvPVCLEAR(retval);
	SvSETMAGIC(sv);
    }
    return count;
}


/* also used for: pp_schomp() */

PP(pp_schop)
{
    dSP; dTARGET;
    const bool chomping = PL_op->op_type == OP_SCHOMP;

    const size_t count = do_chomp(TARG, TOPs, chomping);
    if (chomping)
	sv_setiv(TARG, count);
    SETTARG;
    return NORMAL;
}


/* also used for: pp_chomp() */

PP(pp_chop)
{
    dSP; dMARK; dTARGET; dORIGMARK;
    const bool chomping = PL_op->op_type == OP_CHOMP;
    size_t count = 0;

    while (MARK < SP)
	count += do_chomp(TARG, *++MARK, chomping);
    if (chomping)
	sv_setiv(TARG, count);
    SP = ORIGMARK;
    XPUSHTARG;
    RETURN;
}

PP(pp_undef)
{
    dSP;
    SV *sv;

    if (!PL_op->op_private) {
	EXTEND(SP, 1);
	RETPUSHUNDEF;
    }

    sv = TOPs;
    if (!sv)
    {
	SETs(&PL_sv_undef);
	return NORMAL;
    }

    if (SvTHINKFIRST(sv))
	sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);

    switch (SvTYPE(sv)) {
    case SVt_NULL:
	break;
    case SVt_PVAV:
	av_undef(MUTABLE_AV(sv));
	break;
    case SVt_PVHV:
	hv_undef(MUTABLE_HV(sv));
	break;
    case SVt_PVCV:
	if (cv_const_sv((const CV *)sv))
	    Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
                          "Constant subroutine %" SVf " undefined",
			   SVfARG(CvANON((const CV *)sv)
                             ? newSVpvs_flags("(anonymous)", SVs_TEMP)
                             : sv_2mortal(newSVhek(
                                CvNAMED(sv)
                                 ? CvNAME_HEK((CV *)sv)
                                 : GvENAME_HEK(CvGV((const CV *)sv))
                               ))
                           ));
	/* FALLTHROUGH */
    case SVt_PVFM:
	    /* let user-undef'd sub keep its identity */
	cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
	break;
    case SVt_PVGV:
	assert(isGV_with_GP(sv));
	assert(!SvFAKE(sv));
	{
	    GP *gp;
            HV *stash;

            /* undef *Pkg::meth_name ... */
            bool method_changed
             =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
	      && HvENAME_get(stash);
            /* undef *Foo:: */
            if((stash = GvHV((const GV *)sv))) {
                if(HvENAME_get(stash))
                    SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
                else stash = NULL;
            }

	    SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
	    gp_free(MUTABLE_GV(sv));
	    Newxz(gp, 1, GP);
	    GvGP_set(sv, gp_ref(gp));
#ifndef PERL_DONT_CREATE_GVSV
	    GvSV(sv) = newSV(0);
#endif
	    GvLINE(sv) = CopLINE(PL_curcop);
	    GvEGV(sv) = MUTABLE_GV(sv);
	    GvMULTI_on(sv);

            if(stash)
                mro_package_moved(NULL, stash, (const GV *)sv, 0);
            stash = NULL;
            /* undef *Foo::ISA */
            if( strEQ(GvNAME((const GV *)sv), "ISA")
             && (stash = GvSTASH((const GV *)sv))
             && (method_changed || HvENAME(stash)) )
                mro_isa_changed_in(stash);
            else if(method_changed)
                mro_method_changed_in(
                 GvSTASH((const GV *)sv)
                );

	    break;
	}
    default:
	if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
	    SvPV_free(sv);
	    SvPV_set(sv, NULL);
	    SvLEN_set(sv, 0);
	}
	SvOK_off(sv);
	SvSETMAGIC(sv);
    }

    SETs(&PL_sv_undef);
    return NORMAL;
}


/* common "slow" code for pp_postinc and pp_postdec */

static OP *
S_postincdec_common(pTHX_ SV *sv, SV *targ)
{
    dSP;
    const bool inc =
	PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;

    if (SvROK(sv))
	TARG = sv_newmortal();
    sv_setsv(TARG, sv);
    if (inc)
	sv_inc_nomg(sv);
    else
        sv_dec_nomg(sv);
    SvSETMAGIC(sv);
    /* special case for undef: see thread at 2003-03/msg00536.html in archive */
    if (inc && !SvOK(TARG))
	sv_setiv(TARG, 0);
    SETTARG;
    return NORMAL;
}


/* also used for: pp_i_postinc() */

PP(pp_postinc)
{
    dSP; dTARGET;
    SV *sv = TOPs;

    /* special-case sv being a simple integer */
    if (LIKELY(((sv->sv_flags &
                        (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
                         SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
                == SVf_IOK))
        && SvIVX(sv) != IV_MAX)
    {
        IV iv = SvIVX(sv);
	SvIV_set(sv,  iv + 1);
        TARGi(iv, 0); /* arg not GMG, so can't be tainted */
        SETs(TARG);
        return NORMAL;
    }

    return S_postincdec_common(aTHX_ sv, TARG);
}


/* also used for: pp_i_postdec() */

PP(pp_postdec)
{
    dSP; dTARGET;
    SV *sv = TOPs;

    /* special-case sv being a simple integer */
    if (LIKELY(((sv->sv_flags &
                        (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
                         SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
                == SVf_IOK))
        && SvIVX(sv) != IV_MIN)
    {
        IV iv = SvIVX(sv);
	SvIV_set(sv,  iv - 1);
        TARGi(iv, 0); /* arg not GMG, so can't be tainted */
        SETs(TARG);
        return NORMAL;
    }

    return S_postincdec_common(aTHX_ sv, TARG);
}


/* Ordinary operators. */

PP(pp_pow)
{
    dSP; dATARGET; SV *svl, *svr;
#ifdef PERL_PRESERVE_IVUV
    bool is_int = 0;
#endif
    tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
    svr = TOPs;
    svl = TOPm1s;
#ifdef PERL_PRESERVE_IVUV
    /* For integer to integer power, we do the calculation by hand wherever
       we're sure it is safe; otherwise we call pow() and try to convert to
       integer afterwards. */
    if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
		UV power;
		bool baseuok;
		UV baseuv;

		if (SvUOK(svr)) {
		    power = SvUVX(svr);
		} else {
		    const IV iv = SvIVX(svr);
		    if (iv >= 0) {
			power = iv;
		    } else {
			goto float_it; /* Can't do negative powers this way.  */
		    }
		}

		baseuok = SvUOK(svl);
		if (baseuok) {
		    baseuv = SvUVX(svl);
		} else {
		    const IV iv = SvIVX(svl);
		    if (iv >= 0) {
			baseuv = iv;
			baseuok = TRUE; /* effectively it's a UV now */
		    } else {
			baseuv = -iv; /* abs, baseuok == false records sign */
		    }
		}
                /* now we have integer ** positive integer. */
                is_int = 1;

                /* foo & (foo - 1) is zero only for a power of 2.  */
                if (!(baseuv & (baseuv - 1))) {
                    /* We are raising power-of-2 to a positive integer.
                       The logic here will work for any base (even non-integer
                       bases) but it can be less accurate than
                       pow (base,power) or exp (power * log (base)) when the
                       intermediate values start to spill out of the mantissa.
                       With powers of 2 we know this can't happen.
                       And powers of 2 are the favourite thing for perl
                       programmers to notice ** not doing what they mean. */
                    NV result = 1.0;
                    NV base = baseuok ? baseuv : -(NV)baseuv;

		    if (power & 1) {
			result *= base;
		    }
		    while (power >>= 1) {
			base *= base;
			if (power & 1) {
			    result *= base;
			}
		    }
                    SP--;
                    SETn( result );
                    SvIV_please_nomg(svr);
                    RETURN;
		} else {
		    unsigned int highbit = 8 * sizeof(UV);
		    unsigned int diff = 8 * sizeof(UV);
		    while (diff >>= 1) {
			highbit -= diff;
			if (baseuv >> highbit) {
			    highbit += diff;
			}
		    }
		    /* we now have baseuv < 2 ** highbit */
		    if (power * highbit <= 8 * sizeof(UV)) {
			/* result will definitely fit in UV, so use UV math
			   on same algorithm as above */
			UV result = 1;
			UV base = baseuv;
			const bool odd_power = cBOOL(power & 1);
			if (odd_power) {
			    result *= base;
			}
			while (power >>= 1) {
			    base *= base;
			    if (power & 1) {
				result *= base;
			    }
			}
			SP--;
			if (baseuok || !odd_power)
			    /* answer is positive */
			    SETu( result );
			else if (result <= (UV)IV_MAX)
			    /* answer negative, fits in IV */
			    SETi( -(IV)result );
			else if (result == (UV)IV_MIN)
			    /* 2's complement assumption: special case IV_MIN */
			    SETi( IV_MIN );
			else
			    /* answer negative, doesn't fit */
			    SETn( -(NV)result );
			RETURN;
		    }
		}
    }
  float_it:
#endif
    {
	NV right = SvNV_nomg(svr);
	NV left  = SvNV_nomg(svl);
	(void)POPs;

#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
    /*
    We are building perl with long double support and are on an AIX OS
    afflicted with a powl() function that wrongly returns NaNQ for any
    negative base.  This was reported to IBM as PMR #23047-379 on
    03/06/2006.  The problem exists in at least the following versions
    of AIX and the libm fileset, and no doubt others as well:

	AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
	AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
	AIX 5.2.0           bos.adt.libm 5.2.0.85

    So, until IBM fixes powl(), we provide the following workaround to
    handle the problem ourselves.  Our logic is as follows: for
    negative bases (left), we use fmod(right, 2) to check if the
    exponent is an odd or even integer:

	- if odd,  powl(left, right) == -powl(-left, right)
	- if even, powl(left, right) ==  powl(-left, right)

    If the exponent is not an integer, the result is rightly NaNQ, so
    we just return that (as NV_NAN).
    */

	if (left < 0.0) {
	    NV mod2 = Perl_fmod( right, 2.0 );
	    if (mod2 == 1.0 || mod2 == -1.0) {	/* odd integer */
		SETn( -Perl_pow( -left, right) );
	    } else if (mod2 == 0.0) {		/* even integer */
		SETn( Perl_pow( -left, right) );
	    } else {				/* fractional power */
		SETn( NV_NAN );
	    }
	} else {
	    SETn( Perl_pow( left, right) );
	}
#else
	SETn( Perl_pow( left, right) );
#endif  /* HAS_AIX_POWL_NEG_BASE_BUG */

#ifdef PERL_PRESERVE_IVUV
	if (is_int)
	    SvIV_please_nomg(svr);
#endif
	RETURN;
    }
}

PP(pp_multiply)
{
    dSP; dATARGET; SV *svl, *svr;
    tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
    svr = TOPs;
    svl = TOPm1s;

#ifdef PERL_PRESERVE_IVUV

    /* special-case some simple common cases */
    if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
        IV il, ir;
        U32 flags = (svl->sv_flags & svr->sv_flags);
        if (flags & SVf_IOK) {
            /* both args are simple IVs */
            UV topl, topr;
            il = SvIVX(svl);
            ir = SvIVX(svr);
          do_iv:
            topl = ((UV)il) >> (UVSIZE * 4 - 1);
            topr = ((UV)ir) >> (UVSIZE * 4 - 1);

            /* if both are in a range that can't under/overflow, do a
             * simple integer multiply: if the top halves(*) of both numbers
             * are 00...00  or 11...11, then it's safe.
             * (*) for 32-bits, the "top half" is the top 17 bits,
             *     for 64-bits, its 33 bits */
            if (!(
                      ((topl+1) | (topr+1))
                    & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
            )) {
                SP--;
                TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
                SETs(TARG);
                RETURN;
            }
            goto generic;
        }
        else if (flags & SVf_NOK) {
            /* both args are NVs */
            NV nl = SvNVX(svl);
            NV nr = SvNVX(svr);
            NV result;

            if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
                /* nothing was lost by converting to IVs */
                goto do_iv;
            }
            SP--;
            result = nl * nr;
#  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
            if (Perl_isinf(result)) {
                Zero((U8*)&result + 8, 8, U8);
            }
#  endif
            TARGn(result, 0); /* args not GMG, so can't be tainted */
            SETs(TARG);
            RETURN;
        }
    }

  generic:

    if (SvIV_please_nomg(svr)) {
	/* Unless the left argument is integer in range we are going to have to
	   use NV maths. Hence only attempt to coerce the right argument if
	   we know the left is integer.  */
	/* Left operand is defined, so is it IV? */
	if (SvIV_please_nomg(svl)) {
	    bool auvok = SvUOK(svl);
	    bool buvok = SvUOK(svr);
	    const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
	    const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
	    UV alow;
	    UV ahigh;
	    UV blow;
	    UV bhigh;

	    if (auvok) {
		alow = SvUVX(svl);
	    } else {
		const IV aiv = SvIVX(svl);
		if (aiv >= 0) {
		    alow = aiv;
		    auvok = TRUE; /* effectively it's a UV now */
		} else {
                    /* abs, auvok == false records sign; Using 0- here and
                     * later to silence bogus warning from MS VC */
		    alow = (UV) (0 - (UV) aiv);
		}
	    }
	    if (buvok) {
		blow = SvUVX(svr);
	    } else {
		const IV biv = SvIVX(svr);
		if (biv >= 0) {
		    blow = biv;
		    buvok = TRUE; /* effectively it's a UV now */
		} else {
                    /* abs, buvok == false records sign */
		    blow = (UV) (0 - (UV) biv);
		}
	    }

	    /* If this does sign extension on unsigned it's time for plan B  */
	    ahigh = alow >> (4 * sizeof (UV));
	    alow &= botmask;
	    bhigh = blow >> (4 * sizeof (UV));
	    blow &= botmask;
	    if (ahigh && bhigh) {
		NOOP;
		/* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
		   which is overflow. Drop to NVs below.  */
	    } else if (!ahigh && !bhigh) {
		/* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
		   so the unsigned multiply cannot overflow.  */
		const UV product = alow * blow;
		if (auvok == buvok) {
		    /* -ve * -ve or +ve * +ve gives a +ve result.  */
		    SP--;
		    SETu( product );
		    RETURN;
		} else if (product <= (UV)IV_MIN) {
		    /* 2s complement assumption that (UV)-IV_MIN is correct.  */
		    /* -ve result, which could overflow an IV  */
		    SP--;
                    /* can't negate IV_MIN, but there are aren't two
                     * integers such that !ahigh && !bhigh, where the
                     * product equals 0x800....000 */
                    assert(product != (UV)IV_MIN);
		    SETi( -(IV)product );
		    RETURN;
		} /* else drop to NVs below. */
	    } else {
		/* One operand is large, 1 small */
		UV product_middle;
		if (bhigh) {
		    /* swap the operands */
		    ahigh = bhigh;
		    bhigh = blow; /* bhigh now the temp var for the swap */
		    blow = alow;
		    alow = bhigh;
		}
		/* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
		   multiplies can't overflow. shift can, add can, -ve can.  */
		product_middle = ahigh * blow;
		if (!(product_middle & topmask)) {
		    /* OK, (ahigh * blow) won't lose bits when we shift it.  */
		    UV product_low;
		    product_middle <<= (4 * sizeof (UV));
		    product_low = alow * blow;

		    /* as for pp_add, UV + something mustn't get smaller.
		       IIRC ANSI mandates this wrapping *behaviour* for
		       unsigned whatever the actual representation*/
		    product_low += product_middle;
		    if (product_low >= product_middle) {
			/* didn't overflow */
			if (auvok == buvok) {
			    /* -ve * -ve or +ve * +ve gives a +ve result.  */
			    SP--;
			    SETu( product_low );
			    RETURN;
			} else if (product_low <= (UV)IV_MIN) {
			    /* 2s complement assumption again  */
			    /* -ve result, which could overflow an IV  */
			    SP--;
			    SETi(product_low == (UV)IV_MIN
                                    ? IV_MIN : -(IV)product_low);
			    RETURN;
			} /* else drop to NVs below. */
		    }
		} /* product_middle too large */
	    } /* ahigh && bhigh */
	} /* SvIOK(svl) */
    } /* SvIOK(svr) */
#endif
    {
      NV right = SvNV_nomg(svr);
      NV left  = SvNV_nomg(svl);
      NV result = left * right;

      (void)POPs;
#if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
      if (Perl_isinf(result)) {
          Zero((U8*)&result + 8, 8, U8);
      }
#endif
      SETn(result);
      RETURN;
    }
}

PP(pp_divide)
{
    dSP; dATARGET; SV *svl, *svr;
    tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
    svr = TOPs;
    svl = TOPm1s;
    /* Only try to do UV divide first
       if ((SLOPPYDIVIDE is true) or
           (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
            to preserve))
       The assumption is that it is better to use floating point divide
       whenever possible, only doing integer divide first if we can't be sure.
       If NV_PRESERVES_UV is true then we know at compile time that no UV
       can be too large to preserve, so don't need to compile the code to
       test the size of UVs.  */

#if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
#  define PERL_TRY_UV_DIVIDE
    /* ensure that 20./5. == 4. */
#endif

#ifdef PERL_TRY_UV_DIVIDE
    if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
            bool left_non_neg = SvUOK(svl);
            bool right_non_neg = SvUOK(svr);
            UV left;
            UV right;

            if (right_non_neg) {
                right = SvUVX(svr);
            }
	    else {
		const IV biv = SvIVX(svr);
                if (biv >= 0) {
                    right = biv;
                    right_non_neg = TRUE; /* effectively it's a UV now */
                }
		else {
                    right = -(UV)biv;
                }
            }
            /* historically undef()/0 gives a "Use of uninitialized value"
               warning before dieing, hence this test goes here.
               If it were immediately before the second SvIV_please, then
               DIE() would be invoked before left was even inspected, so
               no inspection would give no warning.  */
            if (right == 0)
                DIE(aTHX_ "Illegal division by zero");

            if (left_non_neg) {
                left = SvUVX(svl);
            }
	    else {
		const IV aiv = SvIVX(svl);
                if (aiv >= 0) {
                    left = aiv;
                    left_non_neg = TRUE; /* effectively it's a UV now */
                }
		else {
                    left = -(UV)aiv;
                }
            }

            if (left >= right
#ifdef SLOPPYDIVIDE
                /* For sloppy divide we always attempt integer division.  */
#else
                /* Otherwise we only attempt it if either or both operands
                   would not be preserved by an NV.  If both fit in NVs
                   we fall through to the NV divide code below.  However,
                   as left >= right to ensure integer result here, we know that
                   we can skip the test on the right operand - right big
                   enough not to be preserved can't get here unless left is
                   also too big.  */

                && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
#endif
                ) {
                /* Integer division can't overflow, but it can be imprecise.  */

                /* Modern compilers optimize division followed by
                 * modulo into a single div instruction */
		const UV result = left / right;
                if (left % right == 0) {
                    SP--; /* result is valid */
                    if (left_non_neg == right_non_neg) {
                        /* signs identical, result is positive.  */
                        SETu( result );
                        RETURN;
                    }
                    /* 2s complement assumption */
                    if (result <= (UV)IV_MIN)
                        SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
                    else {
                        /* It's exact but too negative for IV. */
                        SETn( -(NV)result );
                    }
                    RETURN;
                } /* tried integer divide but it was not an integer result */
            } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
    } /* one operand wasn't SvIOK */
#endif /* PERL_TRY_UV_DIVIDE */
    {
	NV right = SvNV_nomg(svr);
	NV left  = SvNV_nomg(svl);
	(void)POPs;(void)POPs;
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
	if (! Perl_isnan(right) && right == 0.0)
#else
	if (right == 0.0)
#endif
	    DIE(aTHX_ "Illegal division by zero");
	PUSHn( left / right );
	RETURN;
    }
}

PP(pp_modulo)
{
    dSP; dATARGET;
    tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
    {
	UV left  = 0;
	UV right = 0;
	bool left_neg = FALSE;
	bool right_neg = FALSE;
	bool use_double = FALSE;
	bool dright_valid = FALSE;
	NV dright = 0.0;
	NV dleft  = 0.0;
	SV * const svr = TOPs;
	SV * const svl = TOPm1s;
        if (SvIV_please_nomg(svr)) {
            right_neg = !SvUOK(svr);
            if (!right_neg) {
                right = SvUVX(svr);
            } else {
		const IV biv = SvIVX(svr);
                if (biv >= 0) {
                    right = biv;
                    right_neg = FALSE; /* effectively it's a UV now */
                } else {
		    right = (UV) (0 - (UV) biv);
                }
            }
        }
        else {
	    dright = SvNV_nomg(svr);
	    right_neg = dright < 0;
	    if (right_neg)
		dright = -dright;
            if (dright < UV_MAX_P1) {
                right = U_V(dright);
                dright_valid = TRUE; /* In case we need to use double below.  */
            } else {
                use_double = TRUE;
            }
	}

        /* At this point use_double is only true if right is out of range for
           a UV.  In range NV has been rounded down to nearest UV and
           use_double false.  */
	if (!use_double && SvIV_please_nomg(svl)) {
                left_neg = !SvUOK(svl);
                if (!left_neg) {
                    left = SvUVX(svl);
                } else {
		    const IV aiv = SvIVX(svl);
                    if (aiv >= 0) {
                        left = aiv;
                        left_neg = FALSE; /* effectively it's a UV now */
                    } else {
                        left = (UV) (0 - (UV) aiv);
                    }
                }
        }
	else {
	    dleft = SvNV_nomg(svl);
	    left_neg = dleft < 0;
	    if (left_neg)
		dleft = -dleft;

            /* This should be exactly the 5.6 behaviour - if left and right are
               both in range for UV then use U_V() rather than floor.  */
	    if (!use_double) {
                if (dleft < UV_MAX_P1) {
                    /* right was in range, so is dleft, so use UVs not double.
                     */
                    left = U_V(dleft);
                }
                /* left is out of range for UV, right was in range, so promote
                   right (back) to double.  */
                else {
                    /* The +0.5 is used in 5.6 even though it is not strictly
                       consistent with the implicit +0 floor in the U_V()
                       inside the #if 1. */
                    dleft = Perl_floor(dleft + 0.5);
                    use_double = TRUE;
                    if (dright_valid)
                        dright = Perl_floor(dright + 0.5);
                    else
                        dright = right;
                }
            }
        }
	sp -= 2;
	if (use_double) {
	    NV dans;

	    if (!dright)
		DIE(aTHX_ "Illegal modulus zero");

	    dans = Perl_fmod(dleft, dright);
	    if ((left_neg != right_neg) && dans)
		dans = dright - dans;
	    if (right_neg)
		dans = -dans;
	    sv_setnv(TARG, dans);
	}
	else {
	    UV ans;

	    if (!right)
		DIE(aTHX_ "Illegal modulus zero");

	    ans = left % right;
	    if ((left_neg != right_neg) && ans)
		ans = right - ans;
	    if (right_neg) {
		/* XXX may warn: unary minus operator applied to unsigned type */
		/* could change -foo to be (~foo)+1 instead	*/
		if (ans <= ~((UV)IV_MAX)+1)
		    sv_setiv(TARG, ~ans+1);
		else
		    sv_setnv(TARG, -(NV)ans);
	    }
	    else
		sv_setuv(TARG, ans);
	}
	PUSHTARG;
	RETURN;
    }
}

PP(pp_repeat)
{
    dSP; dATARGET;
    IV count;
    SV *sv;
    bool infnan = FALSE;
    const U8 gimme = GIMME_V;

    if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
	/* TODO: think of some way of doing list-repeat overloading ??? */
	sv = POPs;
	SvGETMAGIC(sv);
    }
    else {
	if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
	    /* The parser saw this as a list repeat, and there
	       are probably several items on the stack. But we're
	       in scalar/void context, and there's no pp_list to save us
	       now. So drop the rest of the items -- robin@kitsite.com
	     */
	    dMARK;
	    if (MARK + 1 < SP) {
		MARK[1] = TOPm1s;
		MARK[2] = TOPs;
	    }
	    else {
		dTOPss;
		ASSUME(MARK + 1 == SP);
                MEXTEND(SP, 1);
                PUSHs(sv);
		MARK[1] = &PL_sv_undef;
	    }
	    SP = MARK + 2;
	}
	tryAMAGICbin_MG(repeat_amg, AMGf_assign);
	sv = POPs;
    }

    if (SvIOKp(sv)) {
	 if (SvUOK(sv)) {
	      const UV uv = SvUV_nomg(sv);
	      if (uv > IV_MAX)
		   count = IV_MAX; /* The best we can do? */
	      else
		   count = uv;
	 } else {
	      count = SvIV_nomg(sv);
	 }
    }
    else if (SvNOKp(sv)) {
        const NV nv = SvNV_nomg(sv);
        infnan = Perl_isinfnan(nv);
        if (UNLIKELY(infnan)) {
            count = 0;
        } else {
            if (nv < 0.0)
                count = -1;   /* An arbitrary negative integer */
            else
                count = (IV)nv;
        }
    }
    else
	count = SvIV_nomg(sv);

    if (infnan) {
        Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
                       "Non-finite repeat count does nothing");
    } else if (count < 0) {
        count = 0;
        Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
                       "Negative repeat count does nothing");
    }

    if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
	dMARK;
	const SSize_t items = SP - MARK;
	const U8 mod = PL_op->op_flags & OPf_MOD;

	if (count > 1) {
	    SSize_t max;

            if (  items > SSize_t_MAX / count   /* max would overflow */
                                                /* repeatcpy would overflow */
               || items > I32_MAX / (I32)sizeof(SV *)
            )
               Perl_croak(aTHX_ "%s","Out of memory during list extend");
            max = items * count;
            MEXTEND(MARK, max);

	    while (SP > MARK) {
                if (*SP) {
                   if (mod && SvPADTMP(*SP)) {
                       *SP = sv_mortalcopy(*SP);
                   }
		   SvTEMP_off((*SP));
		}
		SP--;
	    }
	    MARK++;
	    repeatcpy((char*)(MARK + items), (char*)MARK,
		items * sizeof(const SV *), count - 1);
	    SP += max;
	}
	else if (count <= 0)
	    SP = MARK;
    }
    else {	/* Note: mark already snarfed by pp_list */
	SV * const tmpstr = POPs;
	STRLEN len;
	bool isutf;

	if (TARG != tmpstr)
	    sv_setsv_nomg(TARG, tmpstr);
	SvPV_force_nomg(TARG, len);
	isutf = DO_UTF8(TARG);
	if (count != 1) {
	    if (count < 1)
		SvCUR_set(TARG, 0);
	    else {
		STRLEN max;

		if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
		    || len > (U32)I32_MAX  /* repeatcpy would overflow */
                )
		     Perl_croak(aTHX_ "%s",
                                        "Out of memory during string extend");
		max = (UV)count * len + 1;
		SvGROW(TARG, max);

		repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
		SvCUR_set(TARG, SvCUR(TARG) * count);
	    }
	    *SvEND(TARG) = '\0';
	}
	if (isutf)
	    (void)SvPOK_only_UTF8(TARG);
	else
	    (void)SvPOK_only(TARG);

	PUSHTARG;
    }
    RETURN;
}

PP(pp_subtract)
{
    dSP; dATARGET; bool useleft; SV *svl, *svr;
    tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
    svr = TOPs;
    svl = TOPm1s;

#ifdef PERL_PRESERVE_IVUV

    /* special-case some simple common cases */
    if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
        IV il, ir;
        U32 flags = (svl->sv_flags & svr->sv_flags);
        if (flags & SVf_IOK) {
            /* both args are simple IVs */
            UV topl, topr;
            il = SvIVX(svl);
            ir = SvIVX(svr);
          do_iv:
            topl = ((UV)il) >> (UVSIZE * 8 - 2);
            topr = ((UV)ir) >> (UVSIZE * 8 - 2);

            /* if both are in a range that can't under/overflow, do a
             * simple integer subtract: if the top of both numbers
             * are 00  or 11, then it's safe */
            if (!( ((topl+1) | (topr+1)) & 2)) {
                SP--;
                TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
                SETs(TARG);
                RETURN;
            }
            goto generic;
        }
        else if (flags & SVf_NOK) {
            /* both args are NVs */
            NV nl = SvNVX(svl);
            NV nr = SvNVX(svr);

            if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
                /* nothing was lost by converting to IVs */
                goto do_iv;
            }
            SP--;
            TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
            SETs(TARG);
            RETURN;
        }
    }

  generic:

    useleft = USE_LEFT(svl);
    /* See comments in pp_add (in pp_hot.c) about Overflow, and how
       "bad things" happen if you rely on signed integers wrapping.  */
    if (SvIV_please_nomg(svr)) {
	/* Unless the left argument is integer in range we are going to have to
	   use NV maths. Hence only attempt to coerce the right argument if
	   we know the left is integer.  */
	UV auv = 0;
	bool auvok = FALSE;
	bool a_valid = 0;

	if (!useleft) {
	    auv = 0;
	    a_valid = auvok = 1;
	    /* left operand is undef, treat as zero.  */
	} else {
	    /* Left operand is defined, so is it IV? */
	    if (SvIV_please_nomg(svl)) {
		if ((auvok = SvUOK(svl)))
		    auv = SvUVX(svl);
		else {
		    const IV aiv = SvIVX(svl);
		    if (aiv >= 0) {
			auv = aiv;
			auvok = 1;	/* Now acting as a sign flag.  */
		    } else {
                        auv = (UV) (0 - (UV) aiv);
		    }
		}
		a_valid = 1;
	    }
	}
	if (a_valid) {
	    bool result_good = 0;
	    UV result;
	    UV buv;
	    bool buvok = SvUOK(svr);

	    if (buvok)
		buv = SvUVX(svr);
	    else {
		const IV biv = SvIVX(svr);
		if (biv >= 0) {
		    buv = biv;
		    buvok = 1;
		} else
                    buv = (UV) (0 - (UV) biv);
	    }
	    /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
	       else "IV" now, independent of how it came in.
	       if a, b represents positive, A, B negative, a maps to -A etc
	       a - b =>  (a - b)
	       A - b => -(a + b)
	       a - B =>  (a + b)
	       A - B => -(a - b)
	       all UV maths. negate result if A negative.
	       subtract if signs same, add if signs differ. */

	    if (auvok ^ buvok) {
		/* Signs differ.  */
		result = auv + buv;
		if (result >= auv)
		    result_good = 1;
	    } else {
		/* Signs same */
		if (auv >= buv) {
		    result = auv - buv;
		    /* Must get smaller */
		    if (result <= auv)
			result_good = 1;
		} else {
		    result = buv - auv;
		    if (result <= buv) {
			/* result really should be -(auv-buv). as its negation
			   of true value, need to swap our result flag  */
			auvok = !auvok;
			result_good = 1;
		    }
		}
	    }
	    if (result_good) {
		SP--;
		if (auvok)
		    SETu( result );
		else {
		    /* Negate result */
		    if (result <= (UV)IV_MIN)
                        SETi(result == (UV)IV_MIN
                                ? IV_MIN : -(IV)result);
		    else {
			/* result valid, but out of range for IV.  */
			SETn( -(NV)result );
		    }
		}
		RETURN;
	    } /* Overflow, drop through to NVs.  */
	}
    }
#else
    useleft = USE_LEFT(svl);
#endif
    {
	NV value = SvNV_nomg(svr);
	(void)POPs;

	if (!useleft) {
	    /* left operand is undef, treat as zero - value */
	    SETn(-value);
	    RETURN;
	}
	SETn( SvNV_nomg(svl) - value );
	RETURN;
    }
}

#define IV_BITS (IVSIZE * 8)

static UV S_uv_shift(UV uv, int shift, bool left)
{
   if (shift < 0) {
       shift = -shift;
       left = !left;
   }
   if (UNLIKELY(shift >= IV_BITS)) {
       return 0;
   }
   return left ? uv << shift : uv >> shift;
}

static IV S_iv_shift(IV iv, int shift, bool left)
{
    if (shift < 0) {
        shift = -shift;
        left = !left;
    }

    if (UNLIKELY(shift >= IV_BITS)) {
        return iv < 0 && !left ? -1 : 0;
    }

    /* For left shifts, perl 5 has chosen to treat the value as unsigned for
     * the * purposes of shifting, then cast back to signed.  This is very
     * different from Raku:
     *
     * $ raku -e 'say -2 +< 5'
     * -64
     *
     * $ ./perl -le 'print -2 << 5'
     * 18446744073709551552
     * */
    if (left) {
        if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */
            return 0;
        }
        return (IV) (((UV) iv) << shift);
    }

    /* Here is right shift */
    return iv >> shift;
}

#define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
#define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
#define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
#define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)

PP(pp_left_shift)
{
    dSP; dATARGET; SV *svl, *svr;
    tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
    svr = POPs;
    svl = TOPs;
    {
      const IV shift = SvIV_nomg(svr);
      if (PL_op->op_private & HINT_INTEGER) {
          SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
      }
      else {
	  SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
      }
      RETURN;
    }
}

PP(pp_right_shift)
{
    dSP; dATARGET; SV *svl, *svr;
    tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
    svr = POPs;
    svl = TOPs;
    {
      const IV shift = SvIV_nomg(svr);
      if (PL_op->op_private & HINT_INTEGER) {
	  SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
      }
      else {
          SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
      }
      RETURN;
    }
}

PP(pp_lt)
{
    dSP;
    SV *left, *right;
    U32 flags_and, flags_or;

    tryAMAGICbin_MG(lt_amg, AMGf_numeric);
    right = POPs;
    left  = TOPs;
    flags_and = SvFLAGS(left) & SvFLAGS(right);
    flags_or  = SvFLAGS(left) | SvFLAGS(right);

    SETs(boolSV(
        ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
        ?    (SvIVX(left) < SvIVX(right))
        : (flags_and & SVf_NOK)
        ?    (SvNVX(left) < SvNVX(right))
        : (do_ncmp(left, right) == -1)
    ));
    RETURN;
}

PP(pp_gt)
{
    dSP;
    SV *left, *right;
    U32 flags_and, flags_or;

    tryAMAGICbin_MG(gt_amg, AMGf_numeric);
    right = POPs;
    left  = TOPs;
    flags_and = SvFLAGS(left) & SvFLAGS(right);
    flags_or  = SvFLAGS(left) | SvFLAGS(right);

    SETs(boolSV(
        ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
        ?    (SvIVX(left) > SvIVX(right))
        : (flags_and & SVf_NOK)
        ?    (SvNVX(left) > SvNVX(right))
        : (do_ncmp(left, right) == 1)
    ));
    RETURN;
}

PP(pp_le)
{
    dSP;
    SV *left, *right;
    U32 flags_and, flags_or;

    tryAMAGICbin_MG(le_amg, AMGf_numeric);
    right = POPs;
    left  = TOPs;
    flags_and = SvFLAGS(left) & SvFLAGS(right);
    flags_or  = SvFLAGS(left) | SvFLAGS(right);

    SETs(boolSV(
        ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
        ?    (SvIVX(left) <= SvIVX(right))
        : (flags_and & SVf_NOK)
        ?    (SvNVX(left) <= SvNVX(right))
        : (do_ncmp(left, right) <= 0)
    ));
    RETURN;
}

PP(pp_ge)
{
    dSP;
    SV *left, *right;
    U32 flags_and, flags_or;

    tryAMAGICbin_MG(ge_amg, AMGf_numeric);
    right = POPs;
    left  = TOPs;
    flags_and = SvFLAGS(left) & SvFLAGS(right);
    flags_or  = SvFLAGS(left) | SvFLAGS(right);

    SETs(boolSV(
        ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
        ?    (SvIVX(left) >= SvIVX(right))
        : (flags_and & SVf_NOK)
        ?    (SvNVX(left) >= SvNVX(right))
        : ( (do_ncmp(left, right) & 2) == 0)
    ));
    RETURN;
}

PP(pp_ne)
{
    dSP;
    SV *left, *right;
    U32 flags_and, flags_or;

    tryAMAGICbin_MG(ne_amg, AMGf_numeric);
    right = POPs;
    left  = TOPs;
    flags_and = SvFLAGS(left) & SvFLAGS(right);
    flags_or  = SvFLAGS(left) | SvFLAGS(right);

    SETs(boolSV(
        ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
        ?    (SvIVX(left) != SvIVX(right))
        : (flags_and & SVf_NOK)
        ?    (SvNVX(left) != SvNVX(right))
        : (do_ncmp(left, right) != 0)
    ));
    RETURN;
}

/* compare left and right SVs. Returns:
 * -1: <
 *  0: ==
 *  1: >
 *  2: left or right was a NaN
 */
I32
Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
{
    PERL_ARGS_ASSERT_DO_NCMP;
#ifdef PERL_PRESERVE_IVUV
    /* Fortunately it seems NaN isn't IOK */
    if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
	    if (!SvUOK(left)) {
		const IV leftiv = SvIVX(left);
		if (!SvUOK(right)) {
		    /* ## IV <=> IV ## */
		    const IV rightiv = SvIVX(right);
		    return (leftiv > rightiv) - (leftiv < rightiv);
		}
		/* ## IV <=> UV ## */
		if (leftiv < 0)
		    /* As (b) is a UV, it's >=0, so it must be < */
		    return -1;
		{
		    const UV rightuv = SvUVX(right);
		    return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
		}
	    }

	    if (SvUOK(right)) {
		/* ## UV <=> UV ## */
		const UV leftuv = SvUVX(left);
		const UV rightuv = SvUVX(right);
		return (leftuv > rightuv) - (leftuv < rightuv);
	    }
	    /* ## UV <=> IV ## */
	    {
		const IV rightiv = SvIVX(right);
		if (rightiv < 0)
		    /* As (a) is a UV, it's >=0, so it cannot be < */
		    return 1;
		{
		    const UV leftuv = SvUVX(left);
		    return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
		}
	    }
	    NOT_REACHED; /* NOTREACHED */
    }
#endif
    {
      NV const rnv = SvNV_nomg(right);
      NV const lnv = SvNV_nomg(left);

#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
      if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
	  return 2;
       }
      return (lnv > rnv) - (lnv < rnv);
#else
      if (lnv < rnv)
	return -1;
      if (lnv > rnv)
	return 1;
      if (lnv == rnv)
	return 0;
      return 2;
#endif
    }
}


PP(pp_ncmp)
{
    dSP;
    SV *left, *right;
    I32 value;
    tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
    right = POPs;
    left  = TOPs;
    value = do_ncmp(left, right);
    if (value == 2) {
	SETs(&PL_sv_undef);
    }
    else {
	dTARGET;
	SETi(value);
    }
    RETURN;
}


/* also used for: pp_sge() pp_sgt() pp_slt() */

PP(pp_sle)
{
    dSP;

    int amg_type = sle_amg;
    int multiplier = 1;
    int rhs = 1;

    switch (PL_op->op_type) {
    case OP_SLT:
	amg_type = slt_amg;
	/* cmp < 0 */
	rhs = 0;
	break;
    case OP_SGT:
	amg_type = sgt_amg;
	/* cmp > 0 */
	multiplier = -1;
	rhs = 0;
	break;
    case OP_SGE:
	amg_type = sge_amg;
	/* cmp >= 0 */
	multiplier = -1;
	break;
    }

    tryAMAGICbin_MG(amg_type, 0);
    {
      dPOPTOPssrl;
      const int cmp =
#ifdef USE_LOCALE_COLLATE
                      (IN_LC_RUNTIME(LC_COLLATE))
		      ? sv_cmp_locale_flags(left, right, 0)
                      :
#endif
		        sv_cmp_flags(left, right, 0);
      SETs(boolSV(cmp * multiplier < rhs));
      RETURN;
    }
}

PP(pp_seq)
{
    dSP;
    tryAMAGICbin_MG(seq_amg, 0);
    {
      dPOPTOPssrl;
      SETs(boolSV(sv_eq_flags(left, right, 0)));
      RETURN;
    }
}

PP(pp_sne)
{
    dSP;
    tryAMAGICbin_MG(sne_amg, 0);
    {
      dPOPTOPssrl;
      SETs(boolSV(!sv_eq_flags(left, right, 0)));
      RETURN;
    }
}

PP(pp_scmp)
{
    dSP; dTARGET;
    tryAMAGICbin_MG(scmp_amg, 0);
    {
      dPOPTOPssrl;
      const int cmp =
#ifdef USE_LOCALE_COLLATE
                      (IN_LC_RUNTIME(LC_COLLATE))
		      ? sv_cmp_locale_flags(left, right, 0)
		      :
#endif
                        sv_cmp_flags(left, right, 0);
      SETi( cmp );
      RETURN;
    }
}

PP(pp_bit_and)
{
    dSP; dATARGET;
    tryAMAGICbin_MG(band_amg, AMGf_assign);
    {
      dPOPTOPssrl;
      if (SvNIOKp(left) || SvNIOKp(right)) {
	const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
	const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
	if (PL_op->op_private & HINT_INTEGER) {
	  const IV i = SvIV_nomg(left) & SvIV_nomg(right);
	  SETi(i);
	}
	else {
	  const UV u = SvUV_nomg(left) & SvUV_nomg(right);
	  SETu(u);
	}
	if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
	if (right_ro_nonnum) SvNIOK_off(right);
      }
      else {
	do_vop(PL_op->op_type, TARG, left, right);
	SETTARG;
      }
      RETURN;
    }
}

PP(pp_nbit_and)
{
    dSP;
    tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
    {
	dATARGET; dPOPTOPssrl;
	if (PL_op->op_private & HINT_INTEGER) {
	  const IV i = SvIV_nomg(left) & SvIV_nomg(right);
	  SETi(i);
	}
	else {
	  const UV u = SvUV_nomg(left) & SvUV_nomg(right);
	  SETu(u);
	}
    }
    RETURN;
}

PP(pp_sbit_and)
{
    dSP;
    tryAMAGICbin_MG(sband_amg, AMGf_assign);
    {
	dATARGET; dPOPTOPssrl;
	do_vop(OP_BIT_AND, TARG, left, right);
	RETSETTARG;
    }
}

/* also used for: pp_bit_xor() */

PP(pp_bit_or)
{
    dSP; dATARGET;
    const int op_type = PL_op->op_type;

    tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
    {
      dPOPTOPssrl;
      if (SvNIOKp(left) || SvNIOKp(right)) {
	const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
	const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
	if (PL_op->op_private & HINT_INTEGER) {
	  const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
	  const IV r = SvIV_nomg(right);
	  const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
	  SETi(result);
	}
	else {
	  const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
	  const UV r = SvUV_nomg(right);
	  const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
	  SETu(result);
	}
	if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
	if (right_ro_nonnum) SvNIOK_off(right);
      }
      else {
	do_vop(op_type, TARG, left, right);
	SETTARG;
      }
      RETURN;
    }
}

/* also used for: pp_nbit_xor() */

PP(pp_nbit_or)
{
    dSP;
    const int op_type = PL_op->op_type;

    tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
		    AMGf_assign|AMGf_numarg);
    {
	dATARGET; dPOPTOPssrl;
	if (PL_op->op_private & HINT_INTEGER) {
	  const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
	  const IV r = SvIV_nomg(right);
	  const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
	  SETi(result);
	}
	else {
	  const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
	  const UV r = SvUV_nomg(right);
	  const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
	  SETu(result);
	}
    }
    RETURN;
}

/* also used for: pp_sbit_xor() */

PP(pp_sbit_or)
{
    dSP;
    const int op_type = PL_op->op_type;

    tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
		    AMGf_assign);
    {
	dATARGET; dPOPTOPssrl;
	do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
	       right);
	RETSETTARG;
    }
}

PERL_STATIC_INLINE bool
S_negate_string(pTHX)
{
    dTARGET; dSP;
    STRLEN len;
    const char *s;
    SV * const sv = TOPs;
    if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
	return FALSE;
    s = SvPV_nomg_const(sv, len);
    if (isIDFIRST(*s)) {
	sv_setpvs(TARG, "-");
	sv_catsv(TARG, sv);
    }
    else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
	sv_setsv_nomg(TARG, sv);
	*SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
    }
    else return FALSE;
    SETTARG;
    return TRUE;
}

PP(pp_negate)
{
    dSP; dTARGET;
    tryAMAGICun_MG(neg_amg, AMGf_numeric);
    if (S_negate_string(aTHX)) return NORMAL;
    {
	SV * const sv = TOPs;

	if (SvIOK(sv)) {
	    /* It's publicly an integer */
	oops_its_an_int:
	    if (SvIsUV(sv)) {
		if (SvIVX(sv) == IV_MIN) {
		    /* 2s complement assumption. */
                    SETi(SvIVX(sv));	/* special case: -((UV)IV_MAX+1) ==
                                           IV_MIN */
                    return NORMAL;
		}
		else if (SvUVX(sv) <= IV_MAX) {
		    SETi(-SvIVX(sv));
		    return NORMAL;
		}
	    }
	    else if (SvIVX(sv) != IV_MIN) {
		SETi(-SvIVX(sv));
		return NORMAL;
	    }
#ifdef PERL_PRESERVE_IVUV
	    else {
		SETu((UV)IV_MIN);
		return NORMAL;
	    }
#endif
	}
	if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
	    SETn(-SvNV_nomg(sv));
	else if (SvPOKp(sv) && SvIV_please_nomg(sv))
		  goto oops_its_an_int;
	else
	    SETn(-SvNV_nomg(sv));
    }
    return NORMAL;
}

PP(pp_not)
{
    dSP;
    SV *sv;

    tryAMAGICun_MG(not_amg, 0);
    sv = *PL_stack_sp;
    *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
    return NORMAL;
}

static void
S_scomplement(pTHX_ SV *targ, SV *sv)
{
	U8 *tmps;
	I32 anum;
	STRLEN len;

	sv_copypv_nomg(TARG, sv);
	tmps = (U8*)SvPV_nomg(TARG, len);

	if (SvUTF8(TARG)) {
            if (len && ! utf8_to_bytes(tmps, &len)) {
                Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
            }
            SvCUR_set(TARG, len);
            SvUTF8_off(TARG);
        }

	anum = len;

	{
	    long *tmpl;
	    for ( ; anum && PTR2nat(tmps) % sizeof(long); anum--, tmps++)
		*tmps = ~*tmps;
	    tmpl = (long*)tmps;
	    for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
		*tmpl = ~*tmpl;
	    tmps = (U8*)tmpl;
	}

	for ( ; anum > 0; anum--, tmps++)
	    *tmps = ~*tmps;
}

PP(pp_complement)
{
    dSP; dTARGET;
    tryAMAGICun_MG(compl_amg, AMGf_numeric);
    {
      dTOPss;
      if (SvNIOKp(sv)) {
	if (PL_op->op_private & HINT_INTEGER) {
	  const IV i = ~SvIV_nomg(sv);
	  SETi(i);
	}
	else {
	  const UV u = ~SvUV_nomg(sv);
	  SETu(u);
	}
      }
      else {
	S_scomplement(aTHX_ TARG, sv);
	SETTARG;
      }
      return NORMAL;
    }
}

PP(pp_ncomplement)
{
    dSP;
    tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
    {
	dTARGET; dTOPss;
	if (PL_op->op_private & HINT_INTEGER) {
	  const IV i = ~SvIV_nomg(sv);
	  SETi(i);
	}
	else {
	  const UV u = ~SvUV_nomg(sv);
	  SETu(u);
	}
    }
    return NORMAL;
}

PP(pp_scomplement)
{
    dSP;
    tryAMAGICun_MG(scompl_amg, AMGf_numeric);
    {
	dTARGET; dTOPss;
	S_scomplement(aTHX_ TARG, sv);
	SETTARG;
	return NORMAL;
    }
}

/* integer versions of some of the above */

PP(pp_i_multiply)
{
    dSP; dATARGET;
    tryAMAGICbin_MG(mult_amg, AMGf_assign);
    {
      dPOPTOPiirl_nomg;
      SETi( left * right );
      RETURN;
    }
}

PP(pp_i_divide)
{
    IV num;
    dSP; dATARGET;
    tryAMAGICbin_MG(div_amg, AMGf_assign);
    {
      dPOPTOPssrl;
      IV value = SvIV_nomg(right);
      if (value == 0)
	  DIE(aTHX_ "Illegal division by zero");
      num = SvIV_nomg(left);

      /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
      if (value == -1)
          value = - num;
      else
          value = num / value;
      SETi(value);
      RETURN;
    }
}

PP(pp_i_modulo)
{
     dSP; dATARGET;
     tryAMAGICbin_MG(modulo_amg, AMGf_assign);
     {
	  dPOPTOPiirl_nomg;
	  if (!right)
	       DIE(aTHX_ "Illegal modulus zero");
	  /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
	  if (right == -1)
	      SETi( 0 );
	  else
	      SETi( left % right );
	  RETURN;
     }
}

PP(pp_i_add)
{
    dSP; dATARGET;
    tryAMAGICbin_MG(add_amg, AMGf_assign);
    {
      dPOPTOPiirl_ul_nomg;
      SETi( left + right );
      RETURN;
    }
}

PP(pp_i_subtract)
{
    dSP; dATARGET;
    tryAMAGICbin_MG(subtr_amg, AMGf_assign);
    {
      dPOPTOPiirl_ul_nomg;
      SETi( left - right );
      RETURN;
    }
}

PP(pp_i_lt)
{
    dSP;
    tryAMAGICbin_MG(lt_amg, 0);
    {
      dPOPTOPiirl_nomg;
      SETs(boolSV(left < right));
      RETURN;
    }
}

PP(pp_i_gt)
{
    dSP;
    tryAMAGICbin_MG(gt_amg, 0);
    {
      dPOPTOPiirl_nomg;
      SETs(boolSV(left > right));
      RETURN;
    }
}

PP(pp_i_le)
{
    dSP;
    tryAMAGICbin_MG(le_amg, 0);
    {
      dPOPTOPiirl_nomg;
      SETs(boolSV(left <= right));
      RETURN;
    }
}

PP(pp_i_ge)
{
    dSP;
    tryAMAGICbin_MG(ge_amg, 0);
    {
      dPOPTOPiirl_nomg;
      SETs(boolSV(left >= right));
      RETURN;
    }
}

PP(pp_i_eq)
{
    dSP;
    tryAMAGICbin_MG(eq_amg, 0);
    {
      dPOPTOPiirl_nomg;
      SETs(boolSV(left == right));
      RETURN;
    }
}

PP(pp_i_ne)
{
    dSP;
    tryAMAGICbin_MG(ne_amg, 0);
    {
      dPOPTOPiirl_nomg;
      SETs(boolSV(left != right));
      RETURN;
    }
}

PP(pp_i_ncmp)
{
    dSP; dTARGET;
    tryAMAGICbin_MG(ncmp_amg, 0);
    {
      dPOPTOPiirl_nomg;
      I32 value;

      if (left > right)
	value = 1;
      else if (left < right)
	value = -1;
      else
	value = 0;
      SETi(value);
      RETURN;
    }
}

PP(pp_i_negate)
{
    dSP; dTARGET;
    tryAMAGICun_MG(neg_amg, 0);
    if (S_negate_string(aTHX)) return NORMAL;
    {
	SV * const sv = TOPs;
	IV const i = SvIV_nomg(sv);
	SETi(-i);
	return NORMAL;
    }
}

/* High falutin' math. */

PP(pp_atan2)
{
    dSP; dTARGET;
    tryAMAGICbin_MG(atan2_amg, 0);
    {
      dPOPTOPnnrl_nomg;
      SETn(Perl_atan2(left, right));
      RETURN;
    }
}


/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */

PP(pp_sin)
{
    dSP; dTARGET;
    int amg_type = fallback_amg;
    const char *neg_report = NULL;
    const int op_type = PL_op->op_type;

    switch (op_type) {
    case OP_SIN:  amg_type = sin_amg; break;
    case OP_COS:  amg_type = cos_amg; break;
    case OP_EXP:  amg_type = exp_amg; break;
    case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
    case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
    }

    assert(amg_type != fallback_amg);

    tryAMAGICun_MG(amg_type, 0);
    {
      SV * const arg = TOPs;
      const NV value = SvNV_nomg(arg);
#ifdef NV_NAN
      NV result = NV_NAN;
#else
      NV result = 0.0;
#endif
      if (neg_report) { /* log or sqrt */
	  if (
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
	      ! Perl_isnan(value) &&
#endif
	      (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
	      SET_NUMERIC_STANDARD();
	      /* diag_listed_as: Can't take log of %g */
	      DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
	  }
      }
      switch (op_type) {
      default:
      case OP_SIN:  result = Perl_sin(value);  break;
      case OP_COS:  result = Perl_cos(value);  break;
      case OP_EXP:  result = Perl_exp(value);  break;
      case OP_LOG:  result = Perl_log(value);  break;
      case OP_SQRT: result = Perl_sqrt(value); break;
      }
      SETn(result);
      return NORMAL;
    }
}

/* Support Configure command-line overrides for rand() functions.
   After 5.005, perhaps we should replace this by Configure support
   for drand48(), random(), or rand().  For 5.005, though, maintain
   compatibility by calling rand() but allow the user to override it.
   See INSTALL for details.  --Andy Dougherty  15 July 1998
*/
/* Now it's after 5.005, and Configure supports drand48() and random(),
   in addition to rand().  So the overrides should not be needed any more.
   --Jarkko Hietaniemi	27 September 1998
 */

PP(pp_rand)
{
    if (!PL_srand_called) {
	(void)seedDrand01((Rand_seed_t)seed());
	PL_srand_called = TRUE;
    }
    {
	dSP;
	NV value;

	if (MAXARG < 1)
	{
	    EXTEND(SP, 1);
	    value = 1.0;
	}
	else {
	    SV * const sv = POPs;
	    if(!sv)
		value = 1.0;
	    else
		value = SvNV(sv);
	}
    /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
	if (! Perl_isnan(value) && value == 0.0)
#else
	if (value == 0.0)
#endif
	    value = 1.0;
	{
	    dTARGET;
	    PUSHs(TARG);
	    PUTBACK;
	    value *= Drand01();
	    sv_setnv_mg(TARG, value);
	}
    }
    return NORMAL;
}

PP(pp_srand)
{
    dSP; dTARGET;
    UV anum;

    if (MAXARG >= 1 && (TOPs || POPs)) {
        SV *top;
        char *pv;
        STRLEN len;
        int flags;

        top = POPs;
        pv = SvPV(top, len);
        flags = grok_number(pv, len, &anum);

        if (!(flags & IS_NUMBER_IN_UV)) {
            Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
                             "Integer overflow in srand");
            anum = UV_MAX;
        }
    }
    else {
        anum = seed();
    }

    (void)seedDrand01((Rand_seed_t)anum);
    PL_srand_called = TRUE;
    if (anum)
	XPUSHu(anum);
    else {
	/* Historically srand always returned true. We can avoid breaking
	   that like this:  */
	sv_setpvs(TARG, "0 but true");
	XPUSHTARG;
    }
    RETURN;
}

PP(pp_int)
{
    dSP; dTARGET;
    tryAMAGICun_MG(int_amg, AMGf_numeric);
    {
      SV * const sv = TOPs;
      const IV iv = SvIV_nomg(sv);
      /* XXX it's arguable that compiler casting to IV might be subtly
	 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
	 else preferring IV has introduced a subtle behaviour change bug. OTOH
	 relying on floating point to be accurate is a bug.  */

      if (!SvOK(sv)) {
        SETu(0);
      }
      else if (SvIOK(sv)) {
	if (SvIsUV(sv))
	    SETu(SvUV_nomg(sv));
	else
	    SETi(iv);
      }
      else {
	  const NV value = SvNV_nomg(sv);
	  if (UNLIKELY(Perl_isinfnan(value)))
	      SETn(value);
	  else if (value >= 0.0) {
	      if (value < (NV)UV_MAX + 0.5) {
		  SETu(U_V(value));
	      } else {
		  SETn(Perl_floor(value));
	      }
	  }
	  else {
	      if (value > (NV)IV_MIN - 0.5) {
		  SETi(I_V(value));
	      } else {
		  SETn(Perl_ceil(value));
	      }
	  }
      }
    }
    return NORMAL;
}

PP(pp_abs)
{
    dSP; dTARGET;
    tryAMAGICun_MG(abs_amg, AMGf_numeric);
    {
      SV * const sv = TOPs;
      /* This will cache the NV value if string isn't actually integer  */
      const IV iv = SvIV_nomg(sv);

      if (!SvOK(sv)) {
        SETu(0);
      }
      else if (SvIOK(sv)) {
	/* IVX is precise  */
	if (SvIsUV(sv)) {
	  SETu(SvUV_nomg(sv));	/* force it to be numeric only */
	} else {
	  if (iv >= 0) {
	    SETi(iv);
	  } else {
	    if (iv != IV_MIN) {
	      SETi(-iv);
	    } else {
	      /* 2s complement assumption. Also, not really needed as
		 IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
	      SETu((UV)IV_MIN);
	    }
	  }
	}
      } else{
	const NV value = SvNV_nomg(sv);
	if (value < 0.0)
	  SETn(-value);
	else
	  SETn(value);
      }
    }
    return NORMAL;
}


/* also used for: pp_hex() */

PP(pp_oct)
{
    dSP; dTARGET;
    const char *tmps;
    I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
    STRLEN len;
    NV result_nv;
    UV result_uv;
    SV* const sv = TOPs;

    tmps = (SvPV_const(sv, len));
    if (DO_UTF8(sv)) {
	 /* If Unicode, try to downgrade
	  * If not possible, croak. */
	 SV* const tsv = sv_2mortal(newSVsv(sv));

	 SvUTF8_on(tsv);
	 sv_utf8_downgrade(tsv, FALSE);
	 tmps = SvPV_const(tsv, len);
    }
    if (PL_op->op_type == OP_HEX)
	goto hex;

    while (*tmps && len && isSPACE(*tmps))
        tmps++, len--;
    if (*tmps == '0')
        tmps++, len--;
    if (isALPHA_FOLD_EQ(*tmps, 'x')) {
        tmps++, len--;
        flags |= PERL_SCAN_DISALLOW_PREFIX;
    hex:
        result_uv = grok_hex (tmps, &len, &flags, &result_nv);
    }
    else if (isALPHA_FOLD_EQ(*tmps, 'b')) {
        tmps++, len--;
        flags |= PERL_SCAN_DISALLOW_PREFIX;
        result_uv = grok_bin (tmps, &len, &flags, &result_nv);
    }
    else
        result_uv = grok_oct (tmps, &len, &flags, &result_nv);

    if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
        SETn(result_nv);
    }
    else {
        SETu(result_uv);
    }
    return NORMAL;
}

/* String stuff. */


PP(pp_length)
{
    dSP; dTARGET;
    SV * const sv = TOPs;

    U32 in_bytes = IN_BYTES;
    /* Simplest case shortcut:
     * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
     * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
     * set)
     */
    U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);

    STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
    SETs(TARG);

    if (LIKELY(svflags == SVf_POK))
        goto simple_pv;

    if (svflags & SVs_GMG)
        mg_get(sv);

    if (SvOK(sv)) {
        STRLEN len;
	if (!IN_BYTES) { /* reread to avoid using an C auto/register */
            if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
                goto simple_pv;
            if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
                /* no need to convert from bytes to chars */
                len = SvCUR(sv);
                goto return_bool;
            }
	    len = sv_len_utf8_nomg(sv);
        }
	else {
            /* unrolled SvPV_nomg_const(sv,len) */
            if (SvPOK_nog(sv)) {
              simple_pv:
                len = SvCUR(sv);
                if (PL_op->op_private & OPpTRUEBOOL) {
                  return_bool:
                    SETs(len ? &PL_sv_yes : &PL_sv_zero);
                    return NORMAL;
                }
            }
            else {
                (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
            }
	}
        TARGi((IV)(len), 1);
    }
    else {
	if (!SvPADTMP(TARG)) {
            /* OPpTARGET_MY: targ is var in '$lex = length()' */
            sv_set_undef(TARG);
            SvSETMAGIC(TARG);
	}
        else
            /* TARG is on stack at this point and is overwriten by SETs.
             * This branch is the odd one out, so put TARG by default on
             * stack earlier to let local SP go out of liveness sooner */
            SETs(&PL_sv_undef);
    }
    return NORMAL; /* no putback, SP didn't move in this opcode */
}


/* Returns false if substring is completely outside original string.
   No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
   always be true for an explicit 0.
*/
bool
Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
				bool pos1_is_uv, IV len_iv,
				bool len_is_uv, STRLEN *posp,
				STRLEN *lenp)
{
    IV pos2_iv;
    int    pos2_is_uv;

    PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;

    if (!pos1_is_uv && pos1_iv < 0 && curlen) {
	pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
	pos1_iv += curlen;
    }
    if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
	return FALSE;

    if (len_iv || len_is_uv) {
	if (!len_is_uv && len_iv < 0) {
	    pos2_iv = curlen + len_iv;
	    if (curlen)
		pos2_is_uv = curlen-1 > ~(UV)len_iv;
	    else
		pos2_is_uv = 0;
	} else {  /* len_iv >= 0 */
	    if (!pos1_is_uv && pos1_iv < 0) {
		pos2_iv = pos1_iv + len_iv;
		pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
	    } else {
		if ((UV)len_iv > curlen-(UV)pos1_iv)
		    pos2_iv = curlen;
		else
		    pos2_iv = pos1_iv+len_iv;
		pos2_is_uv = 1;
	    }
	}
    }
    else {
	pos2_iv = curlen;
	pos2_is_uv = 1;
    }

    if (!pos2_is_uv && pos2_iv < 0) {
	if (!pos1_is_uv && pos1_iv < 0)
	    return FALSE;
	pos2_iv = 0;
    }
    else if (!pos1_is_uv && pos1_iv < 0)
	pos1_iv = 0;

    if ((UV)pos2_iv < (UV)pos1_iv)
	pos2_iv = pos1_iv;
    if ((UV)pos2_iv > curlen)
	pos2_iv = curlen;

    /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
    *posp = (STRLEN)( (UV)pos1_iv );
    *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );

    return TRUE;
}

PP(pp_substr)
{
    dSP; dTARGET;
    SV *sv;
    STRLEN curlen;
    STRLEN utf8_curlen;
    SV *   pos_sv;
    IV     pos1_iv;
    int    pos1_is_uv;
    SV *   len_sv;
    IV     len_iv = 0;
    int    len_is_uv = 0;
    I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
    const bool rvalue = (GIMME_V != G_VOID);
    const char *tmps;
    SV *repl_sv = NULL;
    const char *repl = NULL;
    STRLEN repl_len;
    int num_args = PL_op->op_private & 7;
    bool repl_need_utf8_upgrade = FALSE;

    if (num_args > 2) {
	if (num_args > 3) {
	  if(!(repl_sv = POPs)) num_args--;
	}
	if ((len_sv = POPs)) {
	    len_iv    = SvIV(len_sv);
	    len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
	}
	else num_args--;
    }
    pos_sv     = POPs;
    pos1_iv    = SvIV(pos_sv);
    pos1_is_uv = SvIOK_UV(pos_sv);
    sv = POPs;
    if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
	assert(!repl_sv);
	repl_sv = POPs;
    }
    if (lvalue && !repl_sv) {
	SV * ret;
	ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
	sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
	LvTYPE(ret) = 'x';
	LvTARG(ret) = SvREFCNT_inc_simple(sv);
	LvTARGOFF(ret) =
	    pos1_is_uv || pos1_iv >= 0
		? (STRLEN)(UV)pos1_iv
		: (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
	LvTARGLEN(ret) =
	    len_is_uv || len_iv > 0
		? (STRLEN)(UV)len_iv
		: (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);

	PUSHs(ret);    /* avoid SvSETMAGIC here */
	RETURN;
    }
    if (repl_sv) {
	repl = SvPV_const(repl_sv, repl_len);
	SvGETMAGIC(sv);
	if (SvROK(sv))
	    Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
			    "Attempt to use reference as lvalue in substr"
	    );
	tmps = SvPV_force_nomg(sv, curlen);
	if (DO_UTF8(repl_sv) && repl_len) {
	    if (!DO_UTF8(sv)) {
                /* Upgrade the dest, and recalculate tmps in case the buffer
                 * got reallocated; curlen may also have been changed */
		sv_utf8_upgrade_nomg(sv);
		tmps = SvPV_nomg(sv, curlen);
	    }
	}
	else if (DO_UTF8(sv))
	    repl_need_utf8_upgrade = TRUE;
    }
    else tmps = SvPV_const(sv, curlen);
    if (DO_UTF8(sv)) {
        utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
	if (utf8_curlen == curlen)
	    utf8_curlen = 0;
	else
	    curlen = utf8_curlen;
    }
    else
	utf8_curlen = 0;

    {
	STRLEN pos, len, byte_len, byte_pos;

	if (!translate_substr_offsets(
		curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
	)) goto bound_fail;

	byte_len = len;
	byte_pos = utf8_curlen
	    ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;

	tmps += byte_pos;

	if (rvalue) {
	    SvTAINTED_off(TARG);			/* decontaminate */
	    SvUTF8_off(TARG);			/* decontaminate */
	    sv_setpvn(TARG, tmps, byte_len);
#ifdef USE_LOCALE_COLLATE
	    sv_unmagic(TARG, PERL_MAGIC_collxfrm);
#endif
	    if (utf8_curlen)
		SvUTF8_on(TARG);
	}

	if (repl) {
	    SV* repl_sv_copy = NULL;

	    if (repl_need_utf8_upgrade) {
		repl_sv_copy = newSVsv(repl_sv);
		sv_utf8_upgrade(repl_sv_copy);
		repl = SvPV_const(repl_sv_copy, repl_len);
	    }
	    if (!SvOK(sv))
                SvPVCLEAR(sv);
	    sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
	    SvREFCNT_dec(repl_sv_copy);
	}
    }
    if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
	SP++;
    else if (rvalue) {
	SvSETMAGIC(TARG);
	PUSHs(TARG);
    }
    RETURN;

  bound_fail:
    if (repl)
	Perl_croak(aTHX_ "substr outside of string");
    Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
    RETPUSHUNDEF;
}

PP(pp_vec)
{
    dSP;
    const IV size   = POPi;
    SV* offsetsv   = POPs;
    SV * const src = POPs;
    const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
    SV * ret;
    UV   retuv;
    STRLEN offset = 0;
    char errflags = 0;

    /* extract a STRLEN-ranged integer value from offsetsv into offset,
     * or flag that its out of range */
    {
        IV iv = SvIV(offsetsv);

        /* avoid a large UV being wrapped to a negative value */
        if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
            errflags = LVf_OUT_OF_RANGE;
        else if (iv < 0)
            errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
#if PTRSIZE < IVSIZE
        else if (iv > Size_t_MAX)
            errflags = LVf_OUT_OF_RANGE;
#endif
        else
            offset = (STRLEN)iv;
    }

    retuv = errflags ? 0 : do_vecget(src, offset, size);

    if (lvalue) {			/* it's an lvalue! */
	ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
	sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
	LvTYPE(ret) = 'v';
	LvTARG(ret) = SvREFCNT_inc_simple(src);
	LvTARGOFF(ret) = offset;
	LvTARGLEN(ret) = size;
	LvFLAGS(ret)   = errflags;
    }
    else {
	dTARGET;
	SvTAINTED_off(TARG);		/* decontaminate */
	ret = TARG;
    }

    sv_setuv(ret, retuv);
    if (!lvalue)
	SvSETMAGIC(ret);
    PUSHs(ret);
    RETURN;
}


/* also used for: pp_rindex() */

PP(pp_index)
{
    dSP; dTARGET;
    SV *big;
    SV *little;
    SV *temp = NULL;
    STRLEN biglen;
    STRLEN llen = 0;
    SSize_t offset = 0;
    SSize_t retval;
    const char *big_p;
    const char *little_p;
    bool big_utf8;
    bool little_utf8;
    const bool is_index = PL_op->op_type == OP_INDEX;
    const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));

    if (threeargs)
	offset = POPi;
    little = POPs;
    big = POPs;
    big_p = SvPV_const(big, biglen);
    little_p = SvPV_const(little, llen);

    big_utf8 = DO_UTF8(big);
    little_utf8 = DO_UTF8(little);
    if (big_utf8 ^ little_utf8) {
	/* One needs to be upgraded.  */
	if (little_utf8) {
	    /* Well, maybe instead we might be able to downgrade the small
	       string?  */
	    char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
						     &little_utf8);
	    if (little_utf8) {
		/* If the large string is ISO-8859-1, and it's not possible to
		   convert the small string to ISO-8859-1, then there is no
		   way that it could be found anywhere by index.  */
		retval = -1;
		goto push_result;
	    }

	    /* At this point, pv is a malloc()ed string. So donate it to temp
	       to ensure it will get free()d  */
	    little = temp = newSV(0);
	    sv_usepvn(temp, pv, llen);
	    little_p = SvPVX(little);
	} else {
	    temp = newSVpvn(little_p, llen);

	    sv_utf8_upgrade(temp);
	    little = temp;
	    little_p = SvPV_const(little, llen);
	}
    }
    if (SvGAMAGIC(big)) {
	/* Life just becomes a lot easier if I use a temporary here.
	   Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
	   will trigger magic and overloading again, as will fbm_instr()
	*/
	big = newSVpvn_flags(big_p, biglen,
			     SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
	big_p = SvPVX(big);
    }
    if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
	/* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
	   warn on undef, and we've already triggered a warning with the
	   SvPV_const some lines above. We can't remove that, as we need to
	   call some SvPV to trigger overloading early and find out if the
	   string is UTF-8.
	   This is all getting too messy. The API isn't quite clean enough,
	   because data access has side effects.
	*/
	little = newSVpvn_flags(little_p, llen,
				SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
	little_p = SvPVX(little);
    }

    if (!threeargs)
	offset = is_index ? 0 : biglen;
    else {
	if (big_utf8 && offset > 0)
	    offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
	if (!is_index)
	    offset += llen;
    }
    if (offset < 0)
	offset = 0;
    else if (offset > (SSize_t)biglen)
	offset = biglen;
    if (!(little_p = is_index
	  ? fbm_instr((unsigned char*)big_p + offset,
		      (unsigned char*)big_p + biglen, little, 0)
	  : rninstr(big_p,  big_p  + offset,
		    little_p, little_p + llen)))
	retval = -1;
    else {
	retval = little_p - big_p;
	if (retval > 1 && big_utf8)
	    retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
    }
    SvREFCNT_dec(temp);

  push_result:
    /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
    if (PL_op->op_private & OPpTRUEBOOL) {
        SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
            ? &PL_sv_yes : &PL_sv_no;
        if (PL_op->op_private & OPpTARGET_MY) {
            /* $lex = (index() == -1) */
            sv_setsv_mg(TARG, result);
            PUSHs(TARG);
        }
        else {
            PUSHs(result);
        }
    }
    else
        PUSHi(retval);
    RETURN;
}

PP(pp_sprintf)
{
    dSP; dMARK; dORIGMARK; dTARGET;
    SvTAINTED_off(TARG);
    do_sprintf(TARG, SP-MARK, MARK+1);
    TAINT_IF(SvTAINTED(TARG));
    SP = ORIGMARK;
    PUSHTARG;
    RETURN;
}

PP(pp_ord)
{
    dSP; dTARGET;

    SV *argsv = TOPs;
    STRLEN len;
    const U8 *s = (U8*)SvPV_const(argsv, len);

    SETu(DO_UTF8(argsv)
           ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
           : (UV)(*s));

    return NORMAL;
}

PP(pp_chr)
{
    dSP; dT