{
dVAR; dSP; dTOPss;
+ if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
if (SvROK(sv)) {
wasref:
- tryAMAGICunDEREF(to_gv);
+ sv = amagic_deref_call(sv, to_gv_amg);
+ SPAGAIN;
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
}
else {
if (!isGV_with_GP(sv)) {
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto wasref;
- }
if (!SvOK(sv) && sv != &PL_sv_undef) {
/* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
*/
if (SvREADONLY(sv))
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
if (PL_op->op_private & OPpDEREF) {
GV *gv;
if (cUNOP->op_targ) {
}
sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
}
+ /* FAKE globs in the symbol table cause weird bugs (#77810) */
+ if (sv) SvFAKE_off(sv);
}
}
if (PL_op->op_private & OPpLVAL_INTRO)
save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
- SETs(sv);
+ if (sv && SvFAKE(sv)) {
+ SV *newsv = sv_newmortal();
+ sv_setsv_flags(newsv, sv, 0);
+ SvFAKE_off(newsv);
+ SETs(newsv);
+ }
+ else SETs(sv);
RETURN;
}
dVAR; dSP; dTOPss;
GV *gv = NULL;
+ if (!(PL_op->op_private & OPpDEREFed))
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
- wasref:
- tryAMAGICunDEREF(to_sv);
+ sv = amagic_deref_call(sv, to_sv_amg);
+ SPAGAIN;
sv = SvRV(sv);
switch (SvTYPE(sv)) {
gv = MUTABLE_GV(sv);
if (!isGV_with_GP(gv)) {
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto wasref;
- }
gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
if (!gv)
RETURN;
PP(pp_pos)
{
- dVAR; dSP; dTARGET; dPOPss;
+ dVAR; dSP; dPOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
- }
-
- LvTYPE(TARG) = '.';
- if (LvTARG(TARG) != sv) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(sv);
- }
- PUSHs(TARG); /* no SvSETMAGIC */
+ 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);
+ PUSHs(ret); /* no SvSETMAGIC */
RETURN;
}
else {
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
+ dTARGET;
I32 i = mg->mg_len;
if (DO_UTF8(sv))
sv_pos_b2u(sv, &i);
goto set;
}
if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
- ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
+ ret = newSVpvs_flags("+", SVs_TEMP);
+ goto set;
+ }
+ if (code == -KEY_push || code == -KEY_unshift) {
+ ret = newSVpvs_flags("+@", SVs_TEMP);
+ goto set;
+ }
+ if (code == -KEY_pop || code == -KEY_shift) {
+ ret = newSVpvs_flags(";+", SVs_TEMP);
+ goto set;
+ }
+ if (code == -KEY_splice) {
+ ret = newSVpvs_flags("+;$$@", SVs_TEMP);
+ goto set;
+ }
+ if (code == -KEY_tied || code == -KEY_untie) {
+ ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
+ goto set;
+ }
+ if (code == -KEY_tie) {
+ ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
goto set;
}
if (code == -KEY_readpipe) {
EXTEND(SP,1);
}
TARG = sv_newmortal();
- PUSHi(do_trans(sv));
+ if(PL_op->op_type == OP_TRANSR) {
+ SV * const newsv = newSVsv(sv);
+ do_trans(newsv);
+ mPUSHs(newsv);
+ }
+ else PUSHi(do_trans(sv));
RETURN;
}
/* let user-undef'd sub keep its identity */
GV* const gv = CvGV((const CV *)sv);
cv_undef(MUTABLE_CV(sv));
- CvGV((const CV *)sv) = gv;
+ CvGV_set(MUTABLE_CV(sv), gv);
}
break;
case SVt_PVGV:
GP *gp;
HV *stash;
- /* undef *Foo:: */
- if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
- mro_isa_changed_in(stash);
/* undef *Pkg::meth_name ... */
- else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
- && HvNAME_get(stash))
- mro_method_changed_in(stash);
+ 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;
+ }
gp_free(MUTABLE_GV(sv));
Newxz(gp, 1, GP);
GvLINE(sv) = CopLINE(PL_curcop);
GvEGV(sv) = MUTABLE_GV(sv);
GvMULTI_on(sv);
+
+ if(stash)
+ mro_package_moved(NULL, stash, (const GV *)sv, NULL, 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(
+ stash ? stash : GvSTASH((const GV *)sv)
+ );
+
break;
}
/* FALL THROUGH */
{
dVAR; dSP;
if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- DIE(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MIN)
{
{
dVAR; dSP; dTARGET;
if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- DIE(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
+ if (SvROK(TOPs))
+ TARG = sv_newmortal();
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
- sv_inc(TOPs);
+ sv_inc_nomg(TOPs);
SvSETMAGIC(TOPs);
/* special case for undef: see thread at 2003-03/msg00536.html in archive */
if (!SvOK(TARG))
{
dVAR; dSP; dTARGET;
if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- DIE(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
+ if (SvROK(TOPs))
+ TARG = sv_newmortal();
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MIN)
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
- sv_dec(TOPs);
+ sv_dec_nomg(TOPs);
SvSETMAGIC(TOPs);
SETs(TARG);
return NORMAL;
#ifdef PERL_PRESERVE_IVUV
bool is_int = 0;
#endif
- tryAMAGICbin(pow,opASSIGN);
- svl = sv_2num(TOPm1s);
- svr = sv_2num(TOPs);
+ 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. */
{
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
if (SvIOK(svr)) {
- SvIV_please(svl);
+ SvIV_please_nomg(svl);
if (SvIOK(svl)) {
UV power;
bool baseuok;
}
SP--;
SETn( result );
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
RETURN;
} else {
register unsigned int highbit = 8 * sizeof(UV);
float_it:
#endif
{
- NV right = SvNV(svr);
- NV left = SvNV(svl);
+ NV right = SvNV_nomg(svr);
+ NV left = SvNV_nomg(svl);
(void)POPs;
#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
#ifdef PERL_PRESERVE_IVUV
if (is_int)
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
#endif
RETURN;
}
PP(pp_multiply)
{
dVAR; dSP; dATARGET; SV *svl, *svr;
- tryAMAGICbin(mult,opASSIGN);
- svl = sv_2num(TOPm1s);
- svr = sv_2num(TOPs);
+ tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
+ svr = TOPs;
+ svl = TOPm1s;
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
if (SvIOK(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? */
- SvIV_please(svl);
+ SvIV_please_nomg(svl);
if (SvIOK(svl)) {
bool auvok = SvUOK(svl);
bool buvok = SvUOK(svr);
} /* SvIOK(svr) */
#endif
{
- NV right = SvNV(svr);
- NV left = SvNV(svl);
+ NV right = SvNV_nomg(svr);
+ NV left = SvNV_nomg(svl);
(void)POPs;
SETn( left * right );
RETURN;
PP(pp_divide)
{
dVAR; dSP; dATARGET; SV *svl, *svr;
- tryAMAGICbin(div,opASSIGN);
- svl = sv_2num(TOPm1s);
- svr = sv_2num(TOPs);
+ 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
#endif
#ifdef PERL_TRY_UV_DIVIDE
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
if (SvIOK(svr)) {
- SvIV_please(svl);
+ SvIV_please_nomg(svl);
if (SvIOK(svl)) {
bool left_non_neg = SvUOK(svl);
bool right_non_neg = SvUOK(svr);
} /* right wasn't SvIOK */
#endif /* PERL_TRY_UV_DIVIDE */
{
- NV right = SvNV(svr);
- NV left = SvNV(svl);
+ 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)
PP(pp_modulo)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ dVAR; dSP; dATARGET;
+ tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
{
UV left = 0;
UV right = 0;
bool dright_valid = FALSE;
NV dright = 0.0;
NV dleft = 0.0;
- SV * svl;
- SV * const svr = sv_2num(TOPs);
- SvIV_please(svr);
+ SV * const svr = TOPs;
+ SV * const svl = TOPm1s;
+ SvIV_please_nomg(svr);
if (SvIOK(svr)) {
right_neg = !SvUOK(svr);
if (!right_neg) {
}
}
else {
- dright = SvNV(svr);
+ dright = SvNV_nomg(svr);
right_neg = dright < 0;
if (right_neg)
dright = -dright;
use_double = TRUE;
}
}
- sp--;
/* 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. */
- svl = sv_2num(TOPs);
- SvIV_please(svl);
+ SvIV_please_nomg(svl);
if (!use_double && SvIOK(svl)) {
if (SvIOK(svl)) {
left_neg = !SvUOK(svl);
}
}
else {
- dleft = SvNV(svl);
+ dleft = SvNV_nomg(svl);
left_neg = dleft < 0;
if (left_neg)
dleft = -dleft;
}
}
}
- sp--;
+ sp -= 2;
if (use_double) {
NV dans;
PP(pp_repeat)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
- {
+ dVAR; dSP; dATARGET;
register IV count;
- dPOPss;
- SvGETMAGIC(sv);
+ SV *sv;
+
+ 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 {
+ tryAMAGICbin_MG(repeat_amg, AMGf_assign);
+ sv = POPs;
+ }
+
if (SvIOKp(sv)) {
if (SvUOK(sv)) {
- const UV uv = SvUV(sv);
+ const UV uv = SvUV_nomg(sv);
if (uv > IV_MAX)
count = IV_MAX; /* The best we can do? */
else
count = uv;
} else {
- const IV iv = SvIV(sv);
+ const IV iv = SvIV_nomg(sv);
if (iv < 0)
count = 0;
else
}
}
else if (SvNOKp(sv)) {
- const NV nv = SvNV(sv);
+ const NV nv = SvNV_nomg(sv);
if (nv < 0.0)
count = 0;
else
count = (IV)nv;
}
else
- count = SvIV(sv);
+ count = SvIV_nomg(sv);
+
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
static const char oom_list_extend[] = "Out of memory during list extend";
static const char oom_string_extend[] =
"Out of memory during string extend";
- SvSetSV(TARG, tmpstr);
- SvPV_force(TARG, len);
+ if (TARG != tmpstr)
+ sv_setsv_nomg(TARG, tmpstr);
+ SvPV_force_nomg(TARG, len);
isutf = DO_UTF8(TARG);
if (count != 1) {
if (count < 1)
PUSHTARG;
}
RETURN;
- }
}
PP(pp_subtract)
{
dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
- tryAMAGICbin(subtr,opASSIGN);
- svl = sv_2num(TOPm1s);
- svr = sv_2num(TOPs);
+ tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
+ svr = TOPs;
+ svl = TOPm1s;
useleft = USE_LEFT(svl);
#ifdef PERL_PRESERVE_IVUV
/* See comments in pp_add (in pp_hot.c) about Overflow, and how
"bad things" happen if you rely on signed integers wrapping. */
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
if (SvIOK(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
/* left operand is undef, treat as zero. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please(svl);
+ SvIV_please_nomg(svl);
if (SvIOK(svl)) {
if ((auvok = SvUOK(svl)))
auv = SvUVX(svl);
}
#endif
{
- NV value = SvNV(svr);
+ NV value = SvNV_nomg(svr);
(void)POPs;
if (!useleft) {
SETn(-value);
RETURN;
}
- SETn( SvNV(svl) - value );
+ SETn( SvNV_nomg(svl) - value );
RETURN;
}
}
PP(pp_left_shift)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+ dVAR; dSP; dATARGET; SV *svl, *svr;
+ tryAMAGICbin_MG(lshift_amg, AMGf_assign);
+ svr = POPs;
+ svl = TOPs;
{
- const IV shift = POPi;
+ const IV shift = SvIV_nomg(svr);
if (PL_op->op_private & HINT_INTEGER) {
- const IV i = TOPi;
+ const IV i = SvIV_nomg(svl);
SETi(i << shift);
}
else {
- const UV u = TOPu;
+ const UV u = SvUV_nomg(svl);
SETu(u << shift);
}
RETURN;
PP(pp_right_shift)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ dVAR; dSP; dATARGET; SV *svl, *svr;
+ tryAMAGICbin_MG(rshift_amg, AMGf_assign);
+ svr = POPs;
+ svl = TOPs;
{
- const IV shift = POPi;
+ const IV shift = SvIV_nomg(svr);
if (PL_op->op_private & HINT_INTEGER) {
- const IV i = TOPi;
+ const IV i = SvIV_nomg(svl);
SETi(i >> shift);
}
else {
- const UV u = TOPu;
+ const UV u = SvUV_nomg(svl);
SETu(u >> shift);
}
RETURN;
PP(pp_lt)
{
- dVAR; dSP; tryAMAGICbinSET(lt,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(lt_amg, AMGf_set);
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(TOPs);
+ SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
+ SvIV_please_nomg(TOPm1s);
if (SvIOK(TOPm1s)) {
bool auvok = SvUOK(TOPm1s);
bool buvok = SvUOK(TOPs);
#endif
{
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
if (Perl_isnan(left) || Perl_isnan(right))
RETSETNO;
SETs(boolSV(left < right));
#else
- dPOPnv;
- SETs(boolSV(TOPn < value));
+ dPOPnv_nomg;
+ SETs(boolSV(SvNV_nomg(TOPs) < value));
#endif
RETURN;
}
PP(pp_gt)
{
- dVAR; dSP; tryAMAGICbinSET(gt,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(gt_amg, AMGf_set);
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(TOPs);
+ SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
+ SvIV_please_nomg(TOPm1s);
if (SvIOK(TOPm1s)) {
bool auvok = SvUOK(TOPm1s);
bool buvok = SvUOK(TOPs);
#endif
{
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
if (Perl_isnan(left) || Perl_isnan(right))
RETSETNO;
SETs(boolSV(left > right));
#else
- dPOPnv;
- SETs(boolSV(TOPn > value));
+ dPOPnv_nomg;
+ SETs(boolSV(SvNV_nomg(TOPs) > value));
#endif
RETURN;
}
PP(pp_le)
{
- dVAR; dSP; tryAMAGICbinSET(le,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(le_amg, AMGf_set);
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(TOPs);
+ SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
+ SvIV_please_nomg(TOPm1s);
if (SvIOK(TOPm1s)) {
bool auvok = SvUOK(TOPm1s);
bool buvok = SvUOK(TOPs);
#endif
{
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
if (Perl_isnan(left) || Perl_isnan(right))
RETSETNO;
SETs(boolSV(left <= right));
#else
- dPOPnv;
- SETs(boolSV(TOPn <= value));
+ dPOPnv_nomg;
+ SETs(boolSV(SvNV_nomg(TOPs) <= value));
#endif
RETURN;
}
PP(pp_ge)
{
- dVAR; dSP; tryAMAGICbinSET(ge,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(ge_amg,AMGf_set);
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(TOPs);
+ SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
+ SvIV_please_nomg(TOPm1s);
if (SvIOK(TOPm1s)) {
bool auvok = SvUOK(TOPm1s);
bool buvok = SvUOK(TOPs);
#endif
{
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
if (Perl_isnan(left) || Perl_isnan(right))
RETSETNO;
SETs(boolSV(left >= right));
#else
- dPOPnv;
- SETs(boolSV(TOPn >= value));
+ dPOPnv_nomg;
+ SETs(boolSV(SvNV_nomg(TOPs) >= value));
#endif
RETURN;
}
PP(pp_ne)
{
- dVAR; dSP; tryAMAGICbinSET(ne,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(ne_amg,AMGf_set);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
}
#endif
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(TOPs);
+ SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
+ SvIV_please_nomg(TOPm1s);
if (SvIOK(TOPm1s)) {
const bool auvok = SvUOK(TOPm1s);
const bool buvok = SvUOK(TOPs);
#endif
{
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
if (Perl_isnan(left) || Perl_isnan(right))
RETSETYES;
SETs(boolSV(left != right));
#else
- dPOPnv;
- SETs(boolSV(TOPn != value));
+ dPOPnv_nomg;
+ SETs(boolSV(SvNV_nomg(TOPs) != value));
#endif
RETURN;
}
PP(pp_ncmp)
{
- dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ dVAR; dSP; dTARGET;
+ tryAMAGICbin_MG(ncmp_amg, 0);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
const UV right = PTR2UV(SvRV(POPs));
#endif
#ifdef PERL_PRESERVE_IVUV
/* Fortunately it seems NaN isn't IOK */
- SvIV_please(TOPs);
+ SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
- SvIV_please(TOPm1s);
+ SvIV_please_nomg(TOPm1s);
if (SvIOK(TOPm1s)) {
const bool leftuvok = SvUOK(TOPm1s);
const bool rightuvok = SvUOK(TOPs);
}
#endif
{
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
I32 value;
#ifdef Perl_isnan
break;
}
- tryAMAGICbinSET_var(amg_type,0);
+ tryAMAGICbin_MG(amg_type, AMGf_set);
{
dPOPTOPssrl;
const int cmp = (IN_LOCALE_RUNTIME
- ? sv_cmp_locale(left, right)
- : sv_cmp(left, right));
+ ? sv_cmp_locale_flags(left, right, 0)
+ : sv_cmp_flags(left, right, 0));
SETs(boolSV(cmp * multiplier < rhs));
RETURN;
}
PP(pp_seq)
{
- dVAR; dSP; tryAMAGICbinSET(seq,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(seq_amg, AMGf_set);
{
dPOPTOPssrl;
- SETs(boolSV(sv_eq(left, right)));
+ SETs(boolSV(sv_eq_flags(left, right, 0)));
RETURN;
}
}
PP(pp_sne)
{
- dVAR; dSP; tryAMAGICbinSET(sne,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(sne_amg, AMGf_set);
{
dPOPTOPssrl;
- SETs(boolSV(!sv_eq(left, right)));
+ SETs(boolSV(!sv_eq_flags(left, right, 0)));
RETURN;
}
}
PP(pp_scmp)
{
- dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
+ dVAR; dSP; dTARGET;
+ tryAMAGICbin_MG(scmp_amg, 0);
{
dPOPTOPssrl;
const int cmp = (IN_LOCALE_RUNTIME
- ? sv_cmp_locale(left, right)
- : sv_cmp(left, right));
+ ? sv_cmp_locale_flags(left, right, 0)
+ : sv_cmp_flags(left, right, 0));
SETi( cmp );
RETURN;
}
PP(pp_bit_and)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+ dVAR; dSP; dATARGET;
+ tryAMAGICbin_MG(band_amg, AMGf_assign);
{
dPOPTOPssrl;
- SvGETMAGIC(left);
- SvGETMAGIC(right);
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);
const UV u = SvUV_nomg(left) & SvUV_nomg(right);
SETu(u);
}
+ if (left_ro_nonnum) SvNIOK_off(left);
+ if (right_ro_nonnum) SvNIOK_off(right);
}
else {
do_vop(PL_op->op_type, TARG, left, right);
dVAR; dSP; dATARGET;
const int op_type = PL_op->op_type;
- tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
+ tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
{
dPOPTOPssrl;
- SvGETMAGIC(left);
- SvGETMAGIC(right);
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 UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
SETu(result);
}
+ if (left_ro_nonnum) SvNIOK_off(left);
+ if (right_ro_nonnum) SvNIOK_off(right);
}
else {
do_vop(op_type, TARG, left, right);
PP(pp_negate)
{
- dVAR; dSP; dTARGET; tryAMAGICun(neg);
+ dVAR; dSP; dTARGET;
+ tryAMAGICun_MG(neg_amg, AMGf_numeric);
{
- SV * const sv = sv_2num(TOPs);
+ SV * const sv = TOPs;
const int flags = SvFLAGS(sv);
- SvGETMAGIC(sv);
+
+ if( !SvNIOK( sv ) && looks_like_number( sv ) ){
+ SvIV_please( sv );
+ }
+
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
/* It's publicly an integer, or privately an integer-not-float */
oops_its_an_int:
#endif
}
if (SvNIOKp(sv))
- SETn(-SvNV(sv));
+ SETn(-SvNV_nomg(sv));
else if (SvPOKp(sv)) {
STRLEN len;
- const char * const s = SvPV_const(sv, len);
+ const char * const s = SvPV_nomg_const(sv, len);
if (isIDFIRST(*s)) {
sv_setpvs(TARG, "-");
sv_catsv(TARG, sv);
}
else if (*s == '+' || *s == '-') {
- sv_setsv(TARG, sv);
- *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
+ sv_setsv_nomg(TARG, sv);
+ *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
}
else if (DO_UTF8(sv)) {
- SvIV_please(sv);
+ SvIV_please_nomg(sv);
if (SvIOK(sv))
goto oops_its_an_int;
if (SvNOK(sv))
- sv_setnv(TARG, -SvNV(sv));
+ sv_setnv(TARG, -SvNV_nomg(sv));
else {
sv_setpvs(TARG, "-");
sv_catsv(TARG, sv);
}
}
else {
- SvIV_please(sv);
+ SvIV_please_nomg(sv);
if (SvIOK(sv))
goto oops_its_an_int;
- sv_setnv(TARG, -SvNV(sv));
+ sv_setnv(TARG, -SvNV_nomg(sv));
}
SETTARG;
}
else
- SETn(-SvNV(sv));
+ SETn(-SvNV_nomg(sv));
}
RETURN;
}
PP(pp_not)
{
- dVAR; dSP; tryAMAGICunSET(not);
- *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
+ dVAR; dSP;
+ tryAMAGICun_MG(not_amg, AMGf_set);
+ *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
return NORMAL;
}
PP(pp_complement)
{
- dVAR; dSP; dTARGET; tryAMAGICun(compl);
+ dVAR; dSP; dTARGET;
+ tryAMAGICun_MG(compl_amg, 0);
{
dTOPss;
- SvGETMAGIC(sv);
if (SvNIOKp(sv)) {
if (PL_op->op_private & HINT_INTEGER) {
const IV i = ~SvIV_nomg(sv);
(void)SvPV_nomg_const(sv,len); /* force check for uninit var */
sv_setsv_nomg(TARG, sv);
- tmps = (U8*)SvPV_force(TARG, len);
+ tmps = (U8*)SvPV_force_nomg(TARG, len);
anum = len;
if (SvUTF8(TARG)) {
/* Calculate exact length, let's not estimate. */
PP(pp_i_multiply)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ dVAR; dSP; dATARGET;
+ tryAMAGICbin_MG(mult_amg, AMGf_assign);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
SETi( left * right );
RETURN;
}
PP(pp_i_divide)
{
IV num;
- dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ dVAR; dSP; dATARGET;
+ tryAMAGICbin_MG(div_amg, AMGf_assign);
{
- dPOPiv;
+ dPOPTOPssrl;
+ IV value = SvIV_nomg(right);
if (value == 0)
DIE(aTHX_ "Illegal division by zero");
- num = POPi;
+ num = SvIV_nomg(left);
/* avoid FPE_INTOVF on some platforms when num is IV_MIN */
if (value == -1)
value = - num;
else
value = num / value;
- PUSHi( value );
+ SETi(value);
RETURN;
}
}
#endif
{
/* This is the vanilla old i_modulo. */
- dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ dVAR; dSP; dATARGET;
+ tryAMAGICbin_MG(modulo_amg, AMGf_assign);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
if (!right)
DIE(aTHX_ "Illegal modulus zero");
/* avoid FPE_INTOVF on some platforms when left is IV_MIN */
/* This is the i_modulo with the workaround for the _moddi3 bug
* in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
* See below for pp_i_modulo. */
- dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ dVAR; dSP; dATARGET;
+ tryAMAGICbin_MG(modulo_amg, AMGf_assign);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
if (!right)
DIE(aTHX_ "Illegal modulus zero");
/* avoid FPE_INTOVF on some platforms when left is IV_MIN */
PP(pp_i_modulo)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ dVAR; dSP; dATARGET;
+ tryAMAGICbin_MG(modulo_amg, AMGf_assign);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
if (!right)
DIE(aTHX_ "Illegal modulus zero");
/* The assumption is to use hereafter the old vanilla version... */
PP(pp_i_add)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ dVAR; dSP; dATARGET;
+ tryAMAGICbin_MG(add_amg, AMGf_assign);
{
- dPOPTOPiirl_ul;
+ dPOPTOPiirl_ul_nomg;
SETi( left + right );
RETURN;
}
PP(pp_i_subtract)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ dVAR; dSP; dATARGET;
+ tryAMAGICbin_MG(subtr_amg, AMGf_assign);
{
- dPOPTOPiirl_ul;
+ dPOPTOPiirl_ul_nomg;
SETi( left - right );
RETURN;
}
PP(pp_i_lt)
{
- dVAR; dSP; tryAMAGICbinSET(lt,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(lt_amg, AMGf_set);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
SETs(boolSV(left < right));
RETURN;
}
PP(pp_i_gt)
{
- dVAR; dSP; tryAMAGICbinSET(gt,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(gt_amg, AMGf_set);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
SETs(boolSV(left > right));
RETURN;
}
PP(pp_i_le)
{
- dVAR; dSP; tryAMAGICbinSET(le,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(le_amg, AMGf_set);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
SETs(boolSV(left <= right));
RETURN;
}
PP(pp_i_ge)
{
- dVAR; dSP; tryAMAGICbinSET(ge,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(ge_amg, AMGf_set);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
SETs(boolSV(left >= right));
RETURN;
}
PP(pp_i_eq)
{
- dVAR; dSP; tryAMAGICbinSET(eq,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(eq_amg, AMGf_set);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
SETs(boolSV(left == right));
RETURN;
}
PP(pp_i_ne)
{
- dVAR; dSP; tryAMAGICbinSET(ne,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(ne_amg, AMGf_set);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
SETs(boolSV(left != right));
RETURN;
}
PP(pp_i_ncmp)
{
- dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ dVAR; dSP; dTARGET;
+ tryAMAGICbin_MG(ncmp_amg, 0);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_nomg;
I32 value;
if (left > right)
PP(pp_i_negate)
{
- dVAR; dSP; dTARGET; tryAMAGICun(neg);
- SETi(-TOPi);
- RETURN;
+ dVAR; dSP; dTARGET;
+ tryAMAGICun_MG(neg_amg, 0);
+ {
+ SV * const sv = TOPs;
+ IV const i = SvIV_nomg(sv);
+ SETi(-i);
+ RETURN;
+ }
}
/* High falutin' math. */
PP(pp_atan2)
{
- dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
+ dVAR; dSP; dTARGET;
+ tryAMAGICbin_MG(atan2_amg, 0);
{
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
SETn(Perl_atan2(left, right));
RETURN;
}
break;
}
- tryAMAGICun_var(amg_type);
+
+ tryAMAGICun_MG(amg_type, 0);
{
- const NV value = POPn;
+ SV * const arg = POPs;
+ const NV value = SvNV_nomg(arg);
if (neg_report) {
if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
SET_NUMERIC_STANDARD();
PP(pp_srand)
{
- dVAR; dSP;
+ dVAR; dSP; dTARGET;
const UV anum = (MAXARG < 1) ? seed() : POPu;
(void)seedDrand01((Rand_seed_t)anum);
PL_srand_called = TRUE;
- EXTEND(SP, 1);
- RETPUSHYES;
+ 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)
{
- dVAR; dSP; dTARGET; tryAMAGICun(int);
+ dVAR; dSP; dTARGET;
+ tryAMAGICun_MG(int_amg, AMGf_numeric);
{
- SV * const sv = sv_2num(TOPs);
- const IV iv = SvIV(sv);
+ 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
}
else if (SvIOK(sv)) {
if (SvIsUV(sv))
- SETu(SvUV(sv));
+ SETu(SvUV_nomg(sv));
else
SETi(iv);
}
else {
- const NV value = SvNV(sv);
+ const NV value = SvNV_nomg(sv);
if (value >= 0.0) {
if (value < (NV)UV_MAX + 0.5) {
SETu(U_V(value));
PP(pp_abs)
{
- dVAR; dSP; dTARGET; tryAMAGICun(abs);
+ dVAR; dSP; dTARGET;
+ tryAMAGICun_MG(abs_amg, AMGf_numeric);
{
- SV * const sv = sv_2num(TOPs);
+ SV * const sv = TOPs;
/* This will cache the NV value if string isn't actually integer */
- const IV iv = SvIV(sv);
+ const IV iv = SvIV_nomg(sv);
if (!SvOK(sv)) {
SETu(0);
else if (SvIOK(sv)) {
/* IVX is precise */
if (SvIsUV(sv)) {
- SETu(SvUV(sv)); /* force it to be numeric only */
+ SETu(SvUV_nomg(sv)); /* force it to be numeric only */
} else {
if (iv >= 0) {
SETi(iv);
}
}
} else{
- const NV value = SvNV(sv);
+ const NV value = SvNV_nomg(sv);
if (value < 0.0)
SETn(-value);
else
tmps++, len--;
if (*tmps == '0')
tmps++, len--;
- if (*tmps == 'x') {
+ if (*tmps == 'x' || *tmps == 'X') {
hex:
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
}
- else if (*tmps == 'b')
+ else if (*tmps == 'b' || *tmps == 'B')
result_uv = grok_bin (tmps, &len, &flags, &result_nv);
else
result_uv = grok_oct (tmps, &len, &flags, &result_nv);
= sv_2pv_flags(sv, &len,
SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
- if (!p)
- SETs(&PL_sv_undef);
+ if (!p) {
+ sv_setsv(TARG, &PL_sv_undef);
+ SETTARG;
+ }
else if (DO_UTF8(sv)) {
SETi(utf8_length((U8*)p, (U8*)p + len));
}
else
SETi(sv_len(sv));
} else {
- SETs(&PL_sv_undef);
+ sv_setsv_nomg(TARG, &PL_sv_undef);
+ SETTARG;
}
RETURN;
}
bool repl_need_utf8_upgrade = FALSE;
bool repl_is_utf8 = FALSE;
- SvTAINTED_off(TARG); /* decontaminate */
- SvUTF8_off(TARG); /* decontaminate */
if (num_args > 2) {
if (num_args > 3) {
repl_sv = POPs;
STRLEN byte_pos = utf8_curlen
? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
- tmps += byte_pos;
- /* we either return a PV or an LV. If the TARG hasn't been used
- * before, or is of that type, reuse it; otherwise use a mortal
- * instead. Note that LVs can have an extended lifetime, so also
- * dont reuse if refcount > 1 (bug #20933) */
- if (SvTYPE(TARG) > SVt_NULL) {
- if ( (SvTYPE(TARG) == SVt_PVLV)
- ? (!lvalue || SvREFCNT(TARG) > 1)
- : lvalue)
- {
- TARG = sv_newmortal();
+ if (lvalue && !repl) {
+ SV * ret;
+
+ if (!SvGMAGICAL(sv)) {
+ if (SvROK(sv)) {
+ SvPV_force_nolen(sv);
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+ "Attempt to use reference as lvalue in substr");
+ }
+ if (isGV_with_GP(sv))
+ SvPV_force_nolen(sv);
+ else if (SvOK(sv)) /* is it defined ? */
+ (void)SvPOK_only_UTF8(sv);
+ else
+ sv_setpvs(sv, ""); /* avoid lexical reincarnation */
}
+
+ 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) = pos;
+ LvTARGLEN(ret) = len;
+
+ SPAGAIN;
+ PUSHs(ret); /* avoid SvSETMAGIC here */
+ RETURN;
}
+ SvTAINTED_off(TARG); /* decontaminate */
+ SvUTF8_off(TARG); /* decontaminate */
+
+ tmps += byte_pos;
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;
SvUTF8_on(sv);
SvREFCNT_dec(repl_sv_copy);
}
- else if (lvalue) { /* it's an lvalue! */
- if (!SvGMAGICAL(sv)) {
- if (SvROK(sv)) {
- SvPV_force_nolen(sv);
- Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
- "Attempt to use reference as lvalue in substr");
- }
- if (isGV_with_GP(sv))
- SvPV_force_nolen(sv);
- else if (SvOK(sv)) /* is it defined ? */
- (void)SvPOK_only_UTF8(sv);
- else
- sv_setpvs(sv, ""); /* avoid lexical reincarnation */
- }
-
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
- }
-
- LvTYPE(TARG) = 'x';
- if (LvTARG(TARG) != sv) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(sv);
- }
- LvTARGOFF(TARG) = pos;
- LvTARGLEN(TARG) = len;
- }
}
SPAGAIN;
PUSHs(TARG); /* avoid SvSETMAGIC here */
PP(pp_vec)
{
- dVAR; dSP; dTARGET;
+ dVAR; dSP;
register const IV size = POPi;
register const IV offset = POPi;
register SV * const src = POPs;
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ SV * ret;
- SvTAINTED_off(TARG); /* decontaminate */
if (lvalue) { /* it's an lvalue! */
- if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
- TARG = sv_newmortal();
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
- }
- LvTYPE(TARG) = 'v';
- if (LvTARG(TARG) != src) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(src);
- }
- LvTARGOFF(TARG) = offset;
- LvTARGLEN(TARG) = size;
+ 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;
+ }
+ else {
+ dTARGET;
+ SvTAINTED_off(TARG); /* decontaminate */
+ ret = TARG;
}
- sv_setuv(TARG, do_vecget(src, offset, size));
- PUSHs(TARG);
+ sv_setuv(ret, do_vecget(src, offset, size));
+ PUSHs(ret);
RETURN;
}
#else
DIE(aTHX_
"The crypt() function is unimplemented due to excessive paranoia.");
- return NORMAL;
#endif
}
const U8 *const send = s + len;
U8 tmpbuf[UTF8_MAXBYTES+1];
-/* This is ifdefd out because it needs more work and thought. It isn't clear
- * that we should do it. These are hard-coded rules from the Unicode standard,
- * and may change. 5.2 gives new guidance on the iota subscript, for example,
- * which has not been checked against this; and secondly it may be that we are
- * passed a subset of the context, via a \U...\E, for example, and its not
- * clear what the best approach is to that */
-#ifdef CONTEXT_DEPENDENT_CASING
+ /* All occurrences of these are to be moved to follow any other marks.
+ * This is context-dependent. We may not be passed enough context to
+ * move the iota subscript beyond all of them, but we do the best we can
+ * with what we're given. The result is always better than if we
+ * hadn't done this. And, the problem would only arise if we are
+ * passed a character without all its combining marks, which would be
+ * the caller's mistake. The information this is based on comes from a
+ * comment in Unicode SpecialCasing.txt, (and the Standard's text
+ * itself) and so can't be checked properly to see if it ever gets
+ * revised. But the likelihood of it changing is remote */
bool in_iota_subscript = FALSE;
-#endif
while (s < send) {
-#ifdef CONTEXT_DEPENDENT_CASING
if (in_iota_subscript && ! is_utf8_mark(s)) {
/* A non-mark. Time to output the iota subscript */
#define GREEK_CAPITAL_LETTER_IOTA 0x0399
CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
in_iota_subscript = FALSE;
}
-#endif
/* See comments at the first instance in this file of this ifdef */
const STRLEN u = UTF8SKIP(s);
STRLEN ulen;
-#ifndef CONTEXT_DEPENDENT_CASING
- toUPPER_utf8(s, tmpbuf, &ulen);
-#else
const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
- if (uv == GREEK_CAPITAL_LETTER_IOTA && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI) {
+ if (uv == GREEK_CAPITAL_LETTER_IOTA
+ && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
+ {
in_iota_subscript = TRUE;
}
else {
-#endif
if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
/* If the eventually required minimum size outgrows
* the available space, we need to grow. */
/* If someone uppercases one million U+03B0s we
* SvGROW() one million times. Or we could try
* guessing how much to allocate without allocating too
- * much. Such is life. See corresponding comment in lc code
- * for another option */
+ * much. Such is life. See corresponding comment in
+ * lc code for another option */
SvGROW(dest, min);
d = (U8*)SvPVX(dest) + o;
}
Copy(tmpbuf, d, ulen, U8);
d += ulen;
-#ifdef CONTEXT_DEPENDENT_CASING
}
-#endif
s += u;
}
}
-#ifdef CONTEXT_DEPENDENT_CASING
- if (in_iota_subscript) CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
-#endif
+ if (in_iota_subscript) {
+ CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
+ }
SvUTF8_on(dest);
*d = '\0';
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
- } else { /* Not UTF-8 */
+ }
+ else { /* Not UTF-8 */
if (len) {
const U8 *const send = s + len;
const STRLEN u = UTF8SKIP(s);
STRLEN ulen;
-/* See comments at the first instance in this file of this ifdef */
#ifndef CONTEXT_DEPENDENT_CASING
toLOWER_utf8(s, tmpbuf, &ulen);
#else
- /* Here is context dependent casing, not compiled in currently;
- * needs more thought and work */
+/* This is ifdefd out because it needs more work and thought. It isn't clear
+ * that we should do it.
+ * A minor objection is that this is based on a hard-coded rule from the
+ * Unicode standard, and may change, but this is not very likely at all.
+ * mktables should check and warn if it does.
+ * More importantly, if the sigma occurs at the end of the string, we don't
+ * have enough context to know whether it is part of a larger string or going
+ * to be or not. It may be that we are passed a subset of the context, via
+ * a \U...\E, for example, and we could conceivably know the larger context if
+ * code were changed to pass that in. But, if the string passed in is an
+ * intermediate result, and the user concatenates two strings together
+ * after we have made a final sigma, that would be wrong. If the final sigma
+ * occurs in the middle of the string we are working on, then we know that it
+ * should be a final sigma, but otherwise we can't be sure. */
const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
RETURN;
}
+/* Smart dereferencing for keys, values and each */
+PP(pp_rkeys)
+{
+ dVAR;
+ dSP;
+ dPOPss;
+
+ if (!SvOK(sv))
+ RETURN;
+
+ if (SvROK(sv)) {
+ SvGETMAGIC(sv);
+ if (SvAMAGIC(sv)) {
+ /* N.B.: AMG macros return sv if no overloading is found */
+ SV *maybe_hv = AMG_CALLun(sv,to_hv);
+ SV *maybe_av = AMG_CALLun(sv,to_av);
+ if ( maybe_hv != sv && maybe_av != sv ) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
+ Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
+ PL_op_desc[PL_op->op_type]
+ )
+ );
+ sv = maybe_hv;
+ }
+ else if ( maybe_av != sv ) {
+ if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) {
+ /* @{} overload, but underlying reftype is HV */
+ Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
+ Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}",
+ PL_op_desc[PL_op->op_type]
+ )
+ );
+ }
+ sv = maybe_av;
+ }
+ else if ( maybe_hv != sv ) {
+ if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) {
+ /* %{} overload, but underlying reftype is AV */
+ Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
+ Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
+ PL_op_desc[PL_op->op_type]
+ )
+ );
+ }
+ sv = maybe_hv;
+ }
+ }
+ sv = SvRV(sv);
+ }
+
+ if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) {
+ DIE(aTHX_ Perl_form(aTHX_ "Type of argument to %s must be hashref or arrayref",
+ PL_op_desc[PL_op->op_type] ));
+ }
+
+ /* Delegate to correct function for op type */
+ PUSHs(sv);
+ if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
+ return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
+ }
+ else {
+ return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
+ }
+}
+
PP(pp_aeach)
{
dVAR;
EXTEND(SP, n + 1);
- if (PL_op->op_type == OP_AKEYS) {
+ if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
n += i;
for (; i <= n; i++) {
mPUSHi(i);
*MARK = &PL_sv_undef;
Safefree(tmparyval);
}
+
+ if (SvMAGICAL(ary))
+ mg_set(MUTABLE_SV(ary));
+
SP = MARK;
RETURN;
}
sv_setsv(sv, *MARK);
av_store(ary, AvFILLp(ary)+1, sv);
}
- if (PL_delaymagic & DM_ARRAY)
+ if (PL_delaymagic & DM_ARRAY_ISA)
mg_set(MUTABLE_SV(ary));
PL_delaymagic = 0;
{
dVAR;
dSP;
- AV * const av = MUTABLE_AV(POPs);
+ AV * const av = PL_op->op_flags & OPf_SPECIAL
+ ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
EXTEND(SP, 1);
assert (sv);
register I32 tmp;
dTARGET;
STRLEN len;
- PADOFFSET padoff_du;
SvUTF8_off(TARG); /* decontaminate */
if (SP - MARK > 1)
do_join(TARG, &PL_sv_no, MARK, SP);
else {
- sv_setsv(TARG, (SP > MARK)
- ? *SP
- : (padoff_du = find_rundefsvoffset(),
- (padoff_du == NOT_IN_PAD
- || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
- ? DEFSV : PAD_SVl(padoff_du)));
-
+ sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
report_uninit(TARG);
}
dVAR;
DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
PL_op->op_type);
- return NORMAL;
}
PP(pp_boolkeys)
https://perl5.git.perl.org / perl5.git / blobdiff