/* pp.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#include "EXTERN.h"
#define PERL_IN_PP_C
#include "perl.h"
+#include "keywords.h"
/* variations on pp_null */
I32 oa;
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+ if (code == -KEY_chop || code == -KEY_chomp)
+ goto set;
while (i < MAXO) { /* The slow way. */
if (strEQ(s + 6, PL_op_name[i])
|| strEQ(s + 6, PL_op_desc[i]))
PP(pp_predec)
{
dSP;
- if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) > SVt_PVLV)
DIE(aTHX_ PL_no_modify);
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
- SvIVX(TOPs) != IV_MIN)
+ if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ && SvIVX(TOPs) != IV_MIN)
{
--SvIVX(TOPs);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
PP(pp_postinc)
{
dSP; dTARGET;
- if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) > SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
- SvIVX(TOPs) != IV_MAX)
+ if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ && SvIVX(TOPs) != IV_MAX)
{
++SvIVX(TOPs);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
PP(pp_postdec)
{
dSP; dTARGET;
- if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) > SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
- SvIVX(TOPs) != IV_MIN)
+ if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ && SvIVX(TOPs) != IV_MIN)
{
--SvIVX(TOPs);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
{
dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
/* Only try to do UV divide first
- if ((SLOPPYDIVIDE is true) or
+ 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
{
UV left = 0;
UV right = 0;
- bool left_neg;
- bool right_neg;
+ bool left_neg = FALSE;
+ bool right_neg = FALSE;
bool use_double = FALSE;
bool dright_valid = FALSE;
NV dright = 0.0;
MEXTEND(MARK, max);
if (count > 1) {
while (SP > MARK) {
+#if 0
+ /* This code was intended to fix 20010809.028:
+
+ $x = 'abcd';
+ for (($x =~ /./g) x 2) {
+ print chop; # "abcdabcd" expected as output.
+ }
+
+ * but that change (#11635) broke this code:
+
+ $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
+
+ * I can't think of a better fix that doesn't introduce
+ * an efficiency hit by copying the SVs. The stack isn't
+ * refcounted, and mortalisation obviously doesn't
+ * Do The Right Thing when the stack has more than
+ * one pointer to the same mortal value.
+ * .robin.
+ */
if (*SP) {
*SP = sv_2mortal(newSVsv(*SP));
SvREADONLY_on(*SP);
}
+#else
+ if (*SP)
+ SvTEMP_off((*SP));
+#endif
SP--;
}
MARK++;
}
}
#endif
+#ifndef NV_PRESERVES_UV
+#ifdef PERL_PRESERVE_IVUV
+ else
+#endif
+ if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ SP--;
+ SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
+ RETURN;
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn < value));
}
}
#endif
+#ifndef NV_PRESERVES_UV
+#ifdef PERL_PRESERVE_IVUV
+ else
+#endif
+ if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ SP--;
+ SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
+ RETURN;
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn > value));
}
}
#endif
+#ifndef NV_PRESERVES_UV
+#ifdef PERL_PRESERVE_IVUV
+ else
+#endif
+ if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ SP--;
+ SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
+ RETURN;
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn <= value));
}
}
#endif
+#ifndef NV_PRESERVES_UV
+#ifdef PERL_PRESERVE_IVUV
+ else
+#endif
+ if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ SP--;
+ SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
+ RETURN;
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn >= value));
dSP; tryAMAGICbinSET(ne,0);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && SvROK(TOPm1s)) {
- SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
+ SP--;
+ SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
RETURN;
}
#endif
bool auvok = SvUOK(TOPm1s);
bool buvok = SvUOK(TOPs);
- if (!auvok && !buvok) { /* ## IV <=> IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
-
- SP--;
- SETs(boolSV(aiv != biv));
- RETURN;
- }
- if (auvok && buvok) { /* ## UV != UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
+ if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
+ /* Casting IV to UV before comparison isn't going to matter
+ on 2s complement. On 1s complement or sign&magnitude
+ (if we have any of them) it could make negative zero
+ differ from normal zero. As I understand it. (Need to
+ check - is negative zero implementation defined behaviour
+ anyway?). NWC */
+ UV buv = SvUVX(POPs);
+ UV auv = SvUVX(TOPs);
- SP--;
SETs(boolSV(auv != buv));
RETURN;
}
dSP; dTARGET; tryAMAGICbin(ncmp,0);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && SvROK(TOPm1s)) {
- SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
+ UV right = PTR2UV(SvRV(POPs));
+ UV left = PTR2UV(SvRV(TOPs));
+ SETi((left > right) - (left < right));
RETURN;
}
#endif
while (tmps < send) {
UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
tmps += UTF8SKIP(tmps);
- result = uvchr_to_utf8(result, ~c);
+ result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
}
*result = '\0';
result -= targlen;
value = POPn;
if (value <= 0.0) {
SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take log of %g", value);
+ DIE(aTHX_ "Can't take log of %"NVgf, value);
}
value = Perl_log(value);
XPUSHn(value);
value = POPn;
if (value < 0.0) {
SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take sqrt of %g", value);
+ DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
}
value = Perl_sqrt(value);
XPUSHn(value);
}
}
+/*
+ * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
+ * These need to be revisited when a newer toolchain becomes available.
+ */
+#if defined(__sparc64__) && defined(__GNUC__)
+# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
+# undef SPARC64_MODF_WORKAROUND
+# define SPARC64_MODF_WORKAROUND 1
+# endif
+#endif
+
+#if defined(SPARC64_MODF_WORKAROUND)
+static NV
+sparc64_workaround_modf(NV theVal, NV *theIntRes)
+{
+ NV res, ret;
+ ret = Perl_modf(theVal, &res);
+ *theIntRes = res;
+ return ret;
+}
+#endif
+
PP(pp_int)
{
dSP; dTARGET; tryAMAGICun(int);
if (value < (NV)UV_MAX + 0.5) {
SETu(U_V(value));
} else {
-#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
-# ifdef HAS_MODFL_POW32_BUG
+#if defined(SPARC64_MODF_WORKAROUND)
+ (void)sparc64_workaround_modf(value, &value);
+#else
+# if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+# ifdef HAS_MODFL_POW32_BUG
/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
- {
+ {
NV offset = Perl_modf(value, &value);
(void)Perl_modf(offset, &offset);
value += offset;
}
-# else
+# else
(void)Perl_modf(value, &value);
-# endif
-#else
+# endif
+# else
double tmp = (double)value;
(void)Perl_modf(tmp, &tmp);
value = (NV)tmp;
+# endif
#endif
SETn(value);
}
STRLEN len;
NV result_nv;
UV result_uv;
+ SV* sv = POPs;
- tmps = (SvPVx(POPs, len));
+ tmps = (SvPVx(sv, len));
+ if (DO_UTF8(sv)) {
+ /* If Unicode, try to downgrade
+ * If not possible, croak. */
+ SV* tsv = sv_2mortal(newSVsv(sv));
+
+ SvUTF8_on(tsv);
+ sv_utf8_downgrade(tsv, FALSE);
+ tmps = SvPVX(tsv);
+ }
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
XPUSHn(result_nv);
STRLEN len;
NV result_nv;
UV result_uv;
+ SV* sv = POPs;
- tmps = (SvPVx(POPs, len));
+ tmps = (SvPVx(sv, len));
+ if (DO_UTF8(sv)) {
+ /* If Unicode, try to downgrade
+ * If not possible, croak. */
+ SV* tsv = sv_2mortal(newSVsv(sv));
+
+ SvUTF8_on(tsv);
+ sv_utf8_downgrade(tsv, FALSE);
+ tmps = SvPVX(tsv);
+ }
while (*tmps && len && isSPACE(*tmps))
tmps++, len--;
if (*tmps == '0')
SV *argsv = POPs;
STRLEN len;
U8 *s = (U8*)SvPVx(argsv, len);
+ SV *tmpsv;
+
+ if (PL_encoding && !DO_UTF8(argsv)) {
+ tmpsv = sv_2mortal(newSVsv(argsv));
+ s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
+ argsv = tmpsv;
+ }
XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
+
RETURN;
}
if (value > 255 && !IN_BYTES) {
SvGROW(TARG, UNISKIP(value)+1);
- tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
+ tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
SvCUR_set(TARG, tmps - SvPVX(TARG));
*tmps = '\0';
(void)SvPOK_only(TARG);
*tmps++ = value;
*tmps = '\0';
(void)SvPOK_only(TARG);
+ if (PL_encoding)
+ Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
XPUSHs(TARG);
RETURN;
}
PP(pp_crypt)
{
- dSP; dTARGET; dPOPTOPssrl;
- STRLEN n_a;
+ dSP; dTARGET;
#ifdef HAS_CRYPT
+ dPOPTOPssrl;
+ STRLEN n_a;
STRLEN len;
char *tmps = SvPV(left, len);
- char *t = 0;
+
if (DO_UTF8(left)) {
- /* If Unicode take the crypt() of the low 8 bits
- * of the characters of the string. */
- char *s = tmps;
- char *send = tmps + len;
- STRLEN i = 0;
- Newz(688, t, len, char);
- while (s < send) {
- t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
- s += UTF8SKIP(s);
- }
- tmps = t;
- }
-#ifdef FCRYPT
+ /* If Unicode, try to downgrade.
+ * If not possible, croak.
+ * Yes, we made this up. */
+ SV* tsv = sv_2mortal(newSVsv(left));
+
+ SvUTF8_on(tsv);
+ sv_utf8_downgrade(tsv, FALSE);
+ tmps = SvPVX(tsv);
+ }
+# ifdef FCRYPT
sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
-#else
+# else
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
-#endif
- Safefree(t);
+# endif
#else
DIE(aTHX_
"The crypt() function is unimplemented due to excessive paranoia.");
STRLEN slen;
if (DO_UTF8(sv)) {
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
STRLEN ulen;
STRLEN tculen;
if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
U8 *tend;
UV uv;
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
s = (U8*)SvPV(sv,len);
if (!len) {
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
s = (U8*)SvPV(sv,len);
if (!len) {
if (MARK < SP)
sv_setsv(val, *++MARK);
else if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
+ Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in anonymous hash");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
dSP;
dTOPss;
SV *retsv = sv;
-#ifdef USE_5005THREADS
- sv_lock(sv);
-#endif /* USE_5005THREADS */
-#ifdef USE_ITHREADS
- shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
- if(ssv)
- Perl_sharedsv_lock(aTHX_ ssv);
-#endif /* USE_ITHREADS */
+ SvLOCK(sv);
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
|| SvTYPE(retsv) == SVt_PVCV) {
retsv = refto(retsv);