GV * const gv = (GV*) sv_newmortal();
gv_init(gv, 0, "", 0, 0);
GvIOp(gv) = (IO *)sv;
- (void)SvREFCNT_inc(sv);
+ SvREFCNT_inc_void_NN(sv);
sv = (SV*) gv;
}
else if (SvTYPE(sv) != SVt_PVGV)
}
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
- if (SvPVX_const(sv)) {
+ else if (SvPVX_const(sv)) {
SvPV_free(sv);
SvLEN_set(sv, 0);
SvCUR_set(sv, 0);
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
+ case SVt_PVFM:
+ case SVt_PVIO:
DIE(aTHX_ "Not a SCALAR reference");
}
}
if (LvTARG(TARG) != sv) {
if (LvTARG(TARG))
SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc(sv);
+ LvTARG(TARG) = SvREFCNT_inc_simple(sv);
}
PUSHs(TARG); /* no SvSETMAGIC */
RETURN;
I32 i = mg->mg_len;
if (DO_UTF8(sv))
sv_pos_b2u(sv, &i);
- PUSHi(i + PL_curcop->cop_arybase);
+ PUSHi(i + CopARYBASE_get(PL_curcop));
RETURN;
}
}
if (!(sv = LvTARG(sv)))
sv = &PL_sv_undef;
else
- (void)SvREFCNT_inc(sv);
+ SvREFCNT_inc_void_NN(sv);
}
else if (SvTYPE(sv) == SVt_PVAV) {
if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
av_reify((AV*)sv);
SvTEMP_off(sv);
- (void)SvREFCNT_inc(sv);
+ SvREFCNT_inc_void_NN(sv);
}
else if (SvPADTMP(sv) && !IS_PADGV(sv))
sv = newSVsv(sv);
else {
SvTEMP_off(sv);
- (void)SvREFCNT_inc(sv);
+ SvREFCNT_inc_void_NN(sv);
}
rv = sv_newmortal();
sv_upgrade(rv, SVt_RV);
if (SvSCREAM(sv))
RETPUSHYES;
}
- else {
- if (PL_lastscream) {
- SvSCREAM_off(PL_lastscream);
- SvREFCNT_dec(PL_lastscream);
- }
- PL_lastscream = SvREFCNT_inc(sv);
+ s = (unsigned char*)(SvPV(sv, len));
+ pos = len;
+ if (pos <= 0 || !SvPOK(sv)) {
+ /* No point in studying a zero length string, and not safe to study
+ anything that doesn't appear to be a simple scalar (and hence might
+ change between now and when the regexp engine runs without our set
+ magic ever running) such as a reference to an object with overloaded
+ stringification. */
+ RETPUSHNO;
+ }
+
+ if (PL_lastscream) {
+ SvSCREAM_off(PL_lastscream);
+ SvREFCNT_dec(PL_lastscream);
}
+ PL_lastscream = SvREFCNT_inc_simple(sv);
s = (unsigned char*)(SvPV(sv, len));
pos = len;
if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case SVt_PVFM:
{
/* let user-undef'd sub keep its identity */
#endif
{
dPOPTOPnnrl;
+
+#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(TOPs);
bhigh = blow >> (4 * sizeof (UV));
blow &= botmask;
if (ahigh && bhigh) {
+ /*EMPTY*/;
/* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
which is overflow. Drop to NVs below. */
} else if (!ahigh && !bhigh) {
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left < right));
+#else
dPOPnv;
SETs(boolSV(TOPn < value));
+#endif
RETURN;
}
}
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left > right));
+#else
dPOPnv;
SETs(boolSV(TOPn > value));
+#endif
RETURN;
}
}
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left <= right));
+#else
dPOPnv;
SETs(boolSV(TOPn <= value));
+#endif
RETURN;
}
}
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left >= right));
+#else
dPOPnv;
SETs(boolSV(TOPn >= value));
+#endif
RETURN;
}
}
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETYES;
+ SETs(boolSV(left != right));
+#else
dPOPnv;
SETs(boolSV(TOPn != value));
+#endif
RETURN;
}
}
}
}
-PP(pp_bit_xor)
-{
- dVAR; dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
- {
- dPOPTOPssrl;
- SvGETMAGIC(left);
- SvGETMAGIC(right);
- if (SvNIOKp(left) || SvNIOKp(right)) {
- if (PL_op->op_private & HINT_INTEGER) {
- const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
- SETi(i);
- }
- else {
- const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
- SETu(u);
- }
- }
- else {
- do_vop(PL_op->op_type, TARG, left, right);
- SETTARG;
- }
- RETURN;
- }
-}
-
PP(pp_bit_or)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ dVAR; dSP; dATARGET;
+ const int op_type = PL_op->op_type;
+
+ tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
{
dPOPTOPssrl;
SvGETMAGIC(left);
SvGETMAGIC(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
- SETi(i);
+ 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 u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
- SETu(u);
+ 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);
}
}
else {
- do_vop(PL_op->op_type, TARG, left, right);
+ do_vop(op_type, TARG, left, right);
SETTARG;
}
RETURN;
PP(pp_i_divide)
{
+ IV num;
dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPiv;
if (value == 0)
- DIE(aTHX_ "Illegal division by zero");
- value = POPi / value;
+ DIE(aTHX_ "Illegal division by zero");
+ num = POPi;
+
+ /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
+ if (value == -1)
+ value = - num;
+ else
+ value = num / value;
PUSHi( value );
RETURN;
}
dPOPTOPiirl;
if (!right)
DIE(aTHX_ "Illegal modulus zero");
- SETi( left % right );
+ /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+ if (right == -1)
+ SETi( 0 );
+ else
+ SETi( left % right );
RETURN;
}
}
dPOPTOPiirl;
if (!right)
DIE(aTHX_ "Illegal modulus zero");
- SETi( left % PERL_ABS(right) );
+ /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+ if (right == -1)
+ SETi( 0 );
+ else
+ SETi( left % PERL_ABS(right) );
RETURN;
}
}
}
}
#endif
- SETi( left % right );
+ /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+ if (right == -1)
+ SETi( 0 );
+ else
+ SETi( left % right );
RETURN;
}
}
PP(pp_sin)
{
- dVAR; dSP; dTARGET; tryAMAGICun_var(sin_amg);
- {
- const NV value = POPn;
- XPUSHn(Perl_sin(value));
- RETURN;
+ dVAR; dSP; dTARGET;
+ int amg_type = sin_amg;
+ const char *neg_report = NULL;
+ NV (*func)(NV) = Perl_sin;
+ const int op_type = PL_op->op_type;
+
+ switch (op_type) {
+ case OP_COS:
+ amg_type = cos_amg;
+ func = Perl_cos;
+ break;
+ case OP_EXP:
+ amg_type = exp_amg;
+ func = Perl_exp;
+ break;
+ case OP_LOG:
+ amg_type = log_amg;
+ func = Perl_log;
+ neg_report = "log";
+ break;
+ case OP_SQRT:
+ amg_type = sqrt_amg;
+ func = Perl_sqrt;
+ neg_report = "sqrt";
+ break;
}
-}
-PP(pp_cos)
-{
- dVAR; dSP; dTARGET; tryAMAGICun_var(cos_amg);
+ tryAMAGICun_var(amg_type);
{
const NV value = POPn;
- XPUSHn(Perl_cos(value));
+ if (neg_report) {
+ if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
+ SET_NUMERIC_STANDARD();
+ DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
+ }
+ }
+ XPUSHn(func(value));
RETURN;
}
}
RETPUSHYES;
}
-PP(pp_exp)
-{
- dVAR; dSP; dTARGET; tryAMAGICun_var(exp_amg);
- {
- NV value;
- value = POPn;
- value = Perl_exp(value);
- XPUSHn(value);
- RETURN;
- }
-}
-
-PP(pp_log)
-{
- dVAR; dSP; dTARGET; tryAMAGICun_var(log_amg);
- {
- const NV value = POPn;
- if (value <= 0.0) {
- SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take log of %"NVgf, value);
- }
- XPUSHn(Perl_log(value));
- RETURN;
- }
-}
-
-PP(pp_sqrt)
-{
- dVAR; dSP; dTARGET; tryAMAGICun_var(sqrt_amg);
- {
- const NV value = POPn;
- if (value < 0.0) {
- SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
- }
- XPUSHn(Perl_sqrt(value));
- RETURN;
- }
-}
-
PP(pp_int)
{
dVAR; dSP; dTARGET; tryAMAGICun(int);
I32 fail;
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
const char *tmps;
- const I32 arybase = PL_curcop->cop_arybase;
+ const I32 arybase = CopARYBASE_get(PL_curcop);
SV *repl_sv = NULL;
const char *repl = NULL;
STRLEN repl_len;
Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
"Attempt to use reference as lvalue in substr");
}
- if (SvOK(sv)) /* is it defined ? */
+ if (isGV_with_GP(sv))
+ SvPV_force_nolen(sv);
+ else if (SvOK(sv)) /* is it defined ? */
(void)SvPOK_only_UTF8(sv);
else
sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
if (LvTARG(TARG) != sv) {
if (LvTARG(TARG))
SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc(sv);
+ LvTARG(TARG) = SvREFCNT_inc_simple(sv);
}
LvTARGOFF(TARG) = upos;
LvTARGLEN(TARG) = urem;
if (LvTARG(TARG) != src) {
if (LvTARG(TARG))
SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc(src);
+ LvTARG(TARG) = SvREFCNT_inc_simple(src);
}
LvTARGOFF(TARG) = offset;
LvTARGLEN(TARG) = size;
I32 retval;
const char *tmps;
const char *tmps2;
- const I32 arybase = PL_curcop->cop_arybase;
+ const I32 arybase = CopARYBASE_get(PL_curcop);
bool big_utf8;
bool little_utf8;
const bool is_index = PL_op->op_type == OP_INDEX;
if (slen > ulen)
sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
SvUTF8_on(TARG);
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
else {
s = (U8*)SvPV_force_nomg(sv, slen);
if (!len) {
SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
else {
STRLEN min = len + 1;
*d = '\0';
SvUTF8_on(TARG);
SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
}
else {
if (!len) {
SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
else {
STRLEN min = len + 1;
#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
+ /*EMPTY*/
/*
* Now if the sigma is NOT followed by
* /$ignorable_sequence$cased_letter/;
*d = '\0';
SvUTF8_on(TARG);
SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
}
else {
register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
if (SvTYPE(av) == SVt_PVAV) {
- const I32 arybase = PL_curcop->cop_arybase;
+ const I32 arybase = CopARYBASE_get(PL_curcop);
if (lval && PL_op->op_private & OPpLVAL_INTRO) {
register SV **svp;
I32 max = -1;
DIE(aTHX_ PL_no_helem_sv, keysv);
}
if (localizing) {
- if (preeminent)
- save_helem(hv, keysv, svp);
- else {
- STRLEN keylen;
- const char *key = SvPV_const(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen), keylen);
- }
+ if (HvNAME_get(hv) && isGV(*svp))
+ save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
+ else {
+ if (preeminent)
+ save_helem(hv, keysv, svp);
+ else {
+ STRLEN keylen;
+ const char * const key = SvPV_const(keysv, keylen);
+ SAVEDELETE(hv, savepvn(key,keylen),
+ SvUTF8(keysv) ? -keylen : keylen);
+ }
+ }
}
}
*MARK = svp ? *svp : &PL_sv_undef;
SV ** const lastlelem = PL_stack_base + POPMARK;
SV ** const firstlelem = PL_stack_base + POPMARK + 1;
register SV ** const firstrelem = lastlelem + 1;
- const I32 arybase = PL_curcop->cop_arybase;
+ const I32 arybase = CopARYBASE_get(PL_curcop);
I32 is_something_there = PL_op->op_flags & OPf_MOD;
register const I32 max = lastrelem - lastlelem;
if (offset < 0)
offset += AvFILLp(ary) + 1;
else
- offset -= PL_curcop->cop_arybase;
+ offset -= CopARYBASE_get(PL_curcop);
if (offset < 0)
DIE(aTHX_ PL_no_aelem, i);
if (++MARK < SP) {
AV * const av = (AV*)POPs;
SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
EXTEND(SP, 1);
- if (!sv)
- RETPUSHUNDEF;
+ assert (sv);
if (AvREAL(av))
(void)sv_2mortal(sv);
PUSHs(sv);
sv_setsv(TARG, (SP > MARK)
? *SP
: (padoff_du = find_rundefsvoffset(),
- (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
+ (padoff_du == NOT_IN_PAD
+ || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
? DEFSV : PAD_SVl(padoff_du)));
up = SvPV_force(TARG, len);
if (len > 1) {
const I32 oldsave = PL_savestack_ix;
I32 make_mortal = 1;
bool multiline = 0;
- MAGIC *mg = (MAGIC *) NULL;
+ MAGIC *mg = NULL;
#ifdef DEBUGGING
Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
projects / p5sagit/p5-mst-13.2.git / blobdiff