/* pp.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2003, 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 */
+#include "reentr.h"
/* XXX I can't imagine anyone who doesn't have this actually _needs_
it, since pid_t is an integral type.
extern Pid_t getpid (void);
#endif
+/* variations on pp_null */
+
PP(pp_stub)
{
dSP;
PP(pp_padav)
{
dSP; dTARGET;
+ I32 gimme;
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
EXTEND(SP, 1);
if (PL_op->op_flags & OPf_REF) {
PUSHs(TARG);
PUSHs(TARG);
RETURN;
}
- if (GIMME == G_ARRAY) {
+ gimme = GIMME_V;
+ if (gimme == G_ARRAY) {
I32 maxarg = AvFILL((AV*)TARG) + 1;
EXTEND(SP, maxarg);
if (SvMAGICAL(TARG)) {
U32 i;
- for (i=0; i < maxarg; i++) {
+ for (i=0; i < (U32)maxarg; i++) {
SV **svp = av_fetch((AV*)TARG, i, FALSE);
SP[i+1] = (svp) ? *svp : &PL_sv_undef;
}
}
SP += maxarg;
}
- else {
+ else if (gimme == G_SCALAR) {
SV* sv = sv_newmortal();
I32 maxarg = AvFILL((AV*)TARG) + 1;
sv_setiv(sv, maxarg);
XPUSHs(TARG);
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_flags & OPf_REF)
RETURN;
else if (LVRET) {
GV *gv;
if (cUNOP->op_targ) {
STRLEN len;
- SV *namesv = PL_curpad[cUNOP->op_targ];
+ SV *namesv = PAD_SV(cUNOP->op_targ);
name = SvPV(namesv, len);
gv = (GV*)NEWSV(0,0);
gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
PP(pp_rv2sv)
{
+ GV *gv = Nullgv;
dSP; dTOPss;
if (SvROK(sv)) {
}
}
else {
- GV *gv = (GV*)sv;
char *sym;
STRLEN len;
+ gv = (GV*)sv;
if (SvTYPE(gv) != SVt_PVGV) {
if (SvGMAGICAL(sv)) {
sv = GvSV(gv);
}
if (PL_op->op_flags & OPf_MOD) {
- if (PL_op->op_private & OPpLVAL_INTRO)
- sv = save_scalar((GV*)TOPs);
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ if (cUNOP->op_first->op_type == OP_NULL)
+ sv = save_scalar((GV*)TOPs);
+ else if (gv)
+ sv = save_scalar(gv);
+ else
+ Perl_croak(aTHX_ PL_no_localize_ref);
+ }
else if (PL_op->op_private & OPpDEREF)
vivify_ref(sv, PL_op->op_private & OPpDEREF);
}
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_anoncode)
{
dSP;
- CV* cv = (CV*)PL_curpad[PL_op->op_targ];
+ CV* cv = (CV*)PAD_SV(PL_op->op_targ);
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
EXTEND(SP,1);
Perl_croak(aTHX_ "Attempt to bless into a reference");
ptr = SvPV(ssv,len);
if (ckWARN(WARN_MISC) && len == 0)
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
if (!sv)
RETPUSHUNDEF;
- if (SvTHINKFIRST(sv))
- sv_force_normal(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
break;
case SVt_PVCV:
if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
- Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
/* FALL THROUGH */
case SVt_PVFM:
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);
PP(pp_pow)
{
- dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ dSP; dATARGET;
+#ifdef PERL_PRESERVE_IVUV
+ bool is_int = 0;
+#endif
+ tryAMAGICbin(pow,opASSIGN);
+#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. */
{
- dPOPTOPnnrl;
- SETn( Perl_pow( left, right) );
- RETURN;
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool baseuok = SvUOK(TOPm1s);
+ UV baseuv;
+
+ if (baseuok) {
+ baseuv = SvUVX(TOPm1s);
+ } else {
+ IV iv = SvIVX(TOPm1s);
+ if (iv >= 0) {
+ baseuv = iv;
+ baseuok = TRUE; /* effectively it's a UV now */
+ } else {
+ baseuv = -iv; /* abs, baseuok == false records sign */
+ }
+ }
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ UV power;
+
+ if (SvUOK(TOPs)) {
+ power = SvUVX(TOPs);
+ } else {
+ IV iv = SvIVX(TOPs);
+ if (iv >= 0) {
+ power = iv;
+ } else {
+ goto float_it; /* Can't do negative powers this way. */
+ }
+ }
+ /* 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;
+ int n = 0;
+
+ for (; power; base *= base, n++) {
+ /* Do I look like I trust gcc with long longs here?
+ Do I hell. */
+ UV bit = (UV)1 << (UV)n;
+ if (power & bit) {
+ result *= base;
+ /* Only bother to clear the bit if it is set. */
+ power -= bit;
+ /* Avoid squaring base again if we're done. */
+ if (power == 0) break;
+ }
+ }
+ SP--;
+ SETn( result );
+ SvIV_please(TOPs);
+ RETURN;
+ } else {
+ register unsigned int highbit = 8 * sizeof(UV);
+ register unsigned int lowbit = 0;
+ register unsigned int diff;
+ while ((diff = (highbit - lowbit) >> 1)) {
+ if (baseuv & ~((1 << (lowbit + diff)) - 1))
+ lowbit += diff;
+ else
+ 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 */
+ register UV result = 1;
+ register UV base = baseuv;
+ register int n = 0;
+ for (; power; base *= base, n++) {
+ register UV bit = (UV)1 << (UV)n;
+ if (power & bit) {
+ result *= base;
+ power -= bit;
+ if (power == 0) break;
+ }
+ }
+ SP--;
+ if (baseuok || !(power & 1))
+ /* 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
+ {
+ dPOPTOPnnrl;
+ SETn( Perl_pow( left, right) );
+#ifdef PERL_PRESERVE_IVUV
+ if (is_int)
+ SvIV_please(TOPs);
+#endif
+ RETURN;
}
}
{
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
}
/* 2s complement assumption */
if (result <= (UV)IV_MIN)
- SETi( -result );
+ SETi( -(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 (abs(result) < 1.0) or (both UVs in range for NV) */
+ } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
} /* left wasn't SvIOK */
} /* right wasn't SvIOK */
#endif /* PERL_TRY_UV_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;
buv = (UV)-biv;
}
/* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
- else "IV" now, independant of how it came in.
+ 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)
}
}
#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));
bool auvok = SvUOK(TOPm1s);
bool buvok = SvUOK(TOPs);
- if (!auvok && !buvok) { /* ## IV <=> IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(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(aiv != biv));
- RETURN;
- }
- if (auvok && buvok) { /* ## UV != UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
-
- SP--;
SETs(boolSV(auv != buv));
RETURN;
}
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;
}
}
+STATIC
+PP(pp_i_modulo_0)
+{
+ /* This is the vanilla old i_modulo. */
+ dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+ SETi( left % right );
+ RETURN;
+ }
+}
+
+STATIC
+PP(pp_i_modulo_1)
+{
+#ifdef __GLIBC__
+ /* This is the i_modulo with the workaround for the _moddi3 bug
+ * in (at least) glibc 2.2.5 (the "right = -right" is the workaround).
+ * See below for pp_i_modulo. */
+ dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+ SETi( left % PERL_ABS(right) );
+ RETURN;
+ }
+#endif
+}
+
PP(pp_i_modulo)
{
- dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
- {
- dPOPTOPiirl;
- if (!right)
- DIE(aTHX_ "Illegal modulus zero");
- SETi( left % right );
- RETURN;
- }
+ dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+ /* The assumption is to use hereafter the old vanilla version... */
+ PL_op->op_ppaddr =
+ PL_ppaddr[OP_I_MODULO] =
+ &Perl_pp_i_modulo_0;
+ /* .. but if we have glibc, we might have a buggy _moddi3
+ * (at least glicb 2.2.5 is known to have this bug), in other
+ * words our integer modulus with negative quad as the second
+ * argument might be broken. Test for this and re-patch the
+ * opcode dispatch table if that is the case, remembering to
+ * also apply the workaround so that this first round works
+ * right, too. See [perl #9402] for more information. */
+#if defined(__GLIBC__) && IVSIZE == 8
+ {
+ IV l = 3;
+ IV r = -10;
+ /* Cannot do this check with inlined IV constants since
+ * that seems to work correctly even with the buggy glibc. */
+ if (l % r == -3) {
+ /* Yikes, we have the bug.
+ * Patch in the workaround version. */
+ PL_op->op_ppaddr =
+ PL_ppaddr[OP_I_MODULO] =
+ &Perl_pp_i_modulo_1;
+ /* Make certain we work right this time, too. */
+ right = PERL_ABS(right);
+ }
+ }
+#endif
+ SETi( left % right );
+ RETURN;
+ }
}
PP(pp_i_add)
u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
#else
# ifdef HAS_GETTIMEOFDAY
- gettimeofday(&when,(struct timezone *) 0);
+ PerlProc_gettimeofday(&when,NULL);
u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
# else
(void)time(&when);
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')
if (lvalue || repl)
Perl_croak(aTHX_ "substr outside of string");
if (ckWARN(WARN_SUBSTR))
- Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
+ Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
RETPUSHUNDEF;
}
else {
STRLEN n_a;
SvPV_force(sv,n_a);
if (ckWARN(WARN_SUBSTR))
- Perl_warner(aTHX_ WARN_SUBSTR,
+ Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
"Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
}
+ 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, Nullsv, PERL_MAGIC_substr, Nullch, 0);
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, Nullsv, PERL_MAGIC_vec, Nullch, 0);
sv_pos_u2b(big, &offset, 0);
if (offset < 0)
offset = 0;
- else if (offset > biglen)
+ else if (offset > (I32)biglen)
offset = biglen;
if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
(unsigned char*)tmps + biglen, little, 0)))
}
if (offset < 0)
offset = 0;
- else if (offset > blen)
+ else if (offset > (I32)blen)
offset = blen;
if (!(tmps2 = rninstr(tmps, tmps + offset,
tmps2, tmps2 + llen)))
U8 *s = (U8*)SvPVx(argsv, len);
SV *tmpsv;
- if (PL_encoding && !DO_UTF8(argsv)) {
+ if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
tmpsv = sv_2mortal(newSVsv(argsv));
- s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
+ s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
argsv = tmpsv;
}
- XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
-
+ XPUSHu(DO_UTF8(argsv) ?
+ utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
+ (*s & 0xff));
+
RETURN;
}
(void)SvUPGRADE(TARG,SVt_PV);
if (value > 255 && !IN_BYTES) {
- SvGROW(TARG, UNISKIP(value)+1);
- tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
+ SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
+ tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
SvCUR_set(TARG, tmps - SvPVX(TARG));
*tmps = '\0';
(void)SvPOK_only(TARG);
SvGROW(TARG,2);
SvCUR_set(TARG, 1);
tmps = SvPVX(TARG);
- *tmps++ = value;
+ *tmps++ = (char)value;
*tmps = '\0';
(void)SvPOK_only(TARG);
- if (PL_encoding)
- Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
+ if (PL_encoding && !IN_BYTES) {
+ sv_recode_to_utf8(TARG, PL_encoding);
+ tmps = SvPVX(TARG);
+ if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
+ memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
+ SvGROW(TARG,3);
+ SvCUR_set(TARG, 2);
+ *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
+ *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
+ *tmps = '\0';
+ SvUTF8_on(TARG);
+ }
+ }
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
+ SETs(TARG);
+ RETURN;
#else
DIE(aTHX_
"The crypt() function is unimplemented due to excessive paranoia.");
#endif
- SETs(TARG);
- RETURN;
}
PP(pp_ucfirst)
register U8 *s;
STRLEN slen;
- if (DO_UTF8(sv)) {
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ SvGETMAGIC(sv);
+ if (DO_UTF8(sv) &&
+ (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
+ UTF8_IS_START(*s)) {
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
STRLEN ulen;
STRLEN tculen;
- s = (U8*)SvPV(sv, slen);
utf8_to_uvchr(s, &ulen);
-
toTITLE_utf8(s, tmpbuf, &tculen);
utf8_to_uvchr(tmpbuf, 0);
if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
+ /* slen is the byte length of the whole SV.
+ * ulen is the byte length of the original Unicode character
+ * stored as UTF-8 at s.
+ * tculen is the byte length of the freshly titlecased
+ * Unicode character stored as UTF-8 at tmpbuf.
+ * We first set the result to be the titlecased character,
+ * and then append the rest of the SV data. */
sv_setpvn(TARG, (char*)tmpbuf, tculen);
- sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
+ if (slen > ulen)
+ sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
SvUTF8_on(TARG);
SETs(TARG);
}
else {
- s = (U8*)SvPV_force(sv, slen);
+ s = (U8*)SvPV_force_nomg(sv, slen);
Copy(tmpbuf, s, tculen, U8);
}
}
if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
+ sv_setsv_nomg(TARG, sv);
sv = TARG;
SETs(sv);
}
- s = (U8*)SvPV_force(sv, slen);
+ s = (U8*)SvPV_force_nomg(sv, slen);
if (*s) {
if (IN_LOCALE_RUNTIME) {
TAINT;
*s = toUPPER(*s);
}
}
- if (SvSMAGICAL(sv))
- mg_set(sv);
+ SvSETMAGIC(sv);
RETURN;
}
register U8 *s;
STRLEN slen;
- if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
+ SvGETMAGIC(sv);
+ if (DO_UTF8(sv) &&
+ (s = (U8*)SvPV_nomg(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;
toLOWER_utf8(s, tmpbuf, &ulen);
uv = utf8_to_uvchr(tmpbuf, 0);
-
tend = uvchr_to_utf8(tmpbuf, uv);
- if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
+ if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
dTARGET;
sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
- sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
+ if (slen > ulen)
+ sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
SvUTF8_on(TARG);
SETs(TARG);
}
else {
- s = (U8*)SvPV_force(sv, slen);
+ s = (U8*)SvPV_force_nomg(sv, slen);
Copy(tmpbuf, s, ulen, U8);
}
}
if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
+ sv_setsv_nomg(TARG, sv);
sv = TARG;
SETs(sv);
}
- s = (U8*)SvPV_force(sv, slen);
+ s = (U8*)SvPV_force_nomg(sv, slen);
if (*s) {
if (IN_LOCALE_RUNTIME) {
TAINT;
*s = toLOWER(*s);
}
}
- if (SvSMAGICAL(sv))
- mg_set(sv);
+ SvSETMAGIC(sv);
RETURN;
}
register U8 *s;
STRLEN len;
+ SvGETMAGIC(sv);
if (DO_UTF8(sv)) {
dTARGET;
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
- s = (U8*)SvPV(sv,len);
+ s = (U8*)SvPV_nomg(sv,len);
if (!len) {
SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
SETs(TARG);
}
else {
+ STRLEN nchar = utf8_length(s, s + len);
+
(void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
+ SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
+ sv_setsv_nomg(TARG, sv);
sv = TARG;
SETs(sv);
}
- s = (U8*)SvPV_force(sv, len);
+ s = (U8*)SvPV_force_nomg(sv, len);
if (len) {
register U8 *send = s + len;
}
}
}
- if (SvSMAGICAL(sv))
- mg_set(sv);
+ SvSETMAGIC(sv);
RETURN;
}
register U8 *s;
STRLEN len;
+ SvGETMAGIC(sv);
if (DO_UTF8(sv)) {
dTARGET;
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
- s = (U8*)SvPV(sv,len);
+ s = (U8*)SvPV_nomg(sv,len);
if (!len) {
SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
SETs(TARG);
}
else {
+ STRLEN nchar = utf8_length(s, s + len);
+
(void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
+ SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
+ sv_setsv_nomg(TARG, sv);
sv = TARG;
SETs(sv);
}
- s = (U8*)SvPV_force(sv, len);
+ s = (U8*)SvPV_force_nomg(sv, len);
if (len) {
register U8 *send = s + len;
}
}
}
- if (SvSMAGICAL(sv))
- mg_set(sv);
+ SvSETMAGIC(sv);
RETURN;
}
HV *hash = (HV*)POPs;
HE *entry;
I32 gimme = GIMME_V;
- I32 realhv = (SvTYPE(hash) == SVt_PVHV);
PUTBACK;
/* might clobber stack_sp */
- entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
+ entry = hv_iternext(hash);
SPAGAIN;
EXTEND(SP, 2);
if (entry) {
- PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
+ SV* sv = hv_iterkeysv(entry);
+ PUSHs(sv); /* won't clobber stack_sp */
if (gimme == G_ARRAY) {
SV *val;
PUTBACK;
/* might clobber stack_sp */
- val = realhv ?
- hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
+ val = hv_iterval(hash, entry);
SPAGAIN;
PUSHs(val);
}
*MARK = sv ? sv : &PL_sv_undef;
}
}
- else if (hvtype == SVt_PVAV) {
- if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
- while (++MARK <= SP) {
- sv = av_delete((AV*)hv, SvIV(*MARK), discard);
- *MARK = sv ? sv : &PL_sv_undef;
- }
- }
- else { /* pseudo-hash element */
- while (++MARK <= SP) {
- sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
- *MARK = sv ? sv : &PL_sv_undef;
- }
- }
+ else if (hvtype == SVt_PVAV) { /* array element */
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ while (++MARK <= SP) {
+ sv = av_delete((AV*)hv, SvIV(*MARK), discard);
+ *MARK = sv ? sv : &PL_sv_undef;
+ }
+ }
}
else
DIE(aTHX_ "Not a HASH reference");
if (PL_op->op_flags & OPf_SPECIAL)
sv = av_delete((AV*)hv, SvIV(keysv), discard);
else
- sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
+ DIE(aTHX_ "panic: avhv_delete no longer supported");
}
else
DIE(aTHX_ "Not a HASH reference");
if (av_exists((AV*)hv, SvIV(tmpsv)))
RETPUSHYES;
}
- else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
- RETPUSHYES;
}
else {
DIE(aTHX_ "Not a HASH reference");
dSP; dMARK; dORIGMARK;
register HV *hv = (HV*)POPs;
register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
- I32 realhv = (SvTYPE(hv) == SVt_PVHV);
+ bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
+ bool other_magic = FALSE;
+
+ if (localizing) {
+ MAGIC *mg;
+ HV *stash;
+
+ other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
+ ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
+ /* Try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise */
+ && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
+ && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
+ && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
+ }
+
+ while (++MARK <= SP) {
+ SV *keysv = *MARK;
+ SV **svp;
+ HE *he;
+ bool preeminent = FALSE;
+
+ if (localizing) {
+ preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
+ hv_exists_ent(hv, keysv, 0);
+ }
- if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
- DIE(aTHX_ "Can't localize pseudo-hash element");
+ he = hv_fetch_ent(hv, keysv, lval, 0);
+ svp = he ? &HeVAL(he) : 0;
- if (realhv || SvTYPE(hv) == SVt_PVAV) {
- while (++MARK <= SP) {
- SV *keysv = *MARK;
- SV **svp;
- I32 preeminent = SvRMAGICAL(hv) ? 1 :
- realhv ? hv_exists_ent(hv, keysv, 0)
- : avhv_exists_ent((AV*)hv, keysv, 0);
- if (realhv) {
- HE *he = hv_fetch_ent(hv, keysv, lval, 0);
- svp = he ? &HeVAL(he) : 0;
- }
- else {
- svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
- }
- if (lval) {
- if (!svp || *svp == &PL_sv_undef) {
- STRLEN n_a;
- DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
- }
- if (PL_op->op_private & OPpLVAL_INTRO) {
- if (preeminent)
- save_helem(hv, keysv, svp);
- else {
- STRLEN keylen;
- char *key = SvPV(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen), keylen);
- }
+ if (lval) {
+ if (!svp || *svp == &PL_sv_undef) {
+ STRLEN n_a;
+ DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
+ }
+ if (localizing) {
+ if (preeminent)
+ save_helem(hv, keysv, svp);
+ else {
+ STRLEN keylen;
+ char *key = SvPV(keysv, keylen);
+ SAVEDELETE(hv, savepvn(key,keylen), keylen);
}
- }
- *MARK = svp ? *svp : &PL_sv_undef;
- }
+ }
+ }
+ *MARK = svp ? *svp : &PL_sv_undef;
}
if (GIMME != G_ARRAY) {
MARK = ORIGMARK;
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_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
offset = 0;
length = AvMAX(ary) + 1;
}
- if (offset > AvFILLp(ary) + 1)
+ if (offset > AvFILLp(ary) + 1) {
+ if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
offset = AvFILLp(ary) + 1;
+ }
after = AvFILLp(ary) + 1 - (offset + length);
if (after < 0) { /* not that much array */
length += after; /* offset+length now in array */
while (down > up) {
tmp = *up;
*up++ = *down;
- *down-- = tmp;
+ *down-- = (char)tmp;
}
}
}
while (down > up) {
tmp = *up;
*up++ = *down;
- *down-- = tmp;
+ *down-- = (char)tmp;
}
(void)SvPOK_only_UTF8(TARG);
}
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
(pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
- PL_reg_match_utf8 = do_utf8;
+ RX_MATCH_UTF8_set(rx, do_utf8);
if (pm->op_pmreplroot) {
#ifdef USE_ITHREADS
- ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
+ ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
#else
ary = GvAVn((GV*)pm->op_pmreplroot);
#endif
}
else if (gimme != G_ARRAY)
-#ifdef USE_5005THREADS
- ary = (AV*)PL_curpad[0];
-#else
ary = GvAVn(PL_defgv);
-#endif /* USE_5005THREADS */
else
ary = Nullav;
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
}
/* temporarily switch stacks */
SWITCHSTACK(PL_curstack, ary);
+ PL_curstackinfo->si_stack = ary;
make_mortal = 0;
}
}
(void)SvUTF8_on(dstr);
XPUSHs(dstr);
if (rx->nparens) {
- for (i = 1; i <= rx->nparens; i++) {
+ for (i = 1; i <= (I32)rx->nparens; i++) {
s = rx->startp[i] + orig;
m = rx->endp[i] + orig;
}
}
s = rx->endp[0] + orig;
+ PUTBACK;
}
}
iters++;
}
else if (!origlimit) {
- while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
- iters--, SP--;
+ while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
+ if (TOPs && !make_mortal)
+ sv_2mortal(TOPs);
+ iters--;
+ SP--;
+ }
}
if (realarray) {
if (!mg) {
SWITCHSTACK(ary, oldstack);
+ PL_curstackinfo->si_stack = oldstack;
if (SvSMAGICAL(ary)) {
PUTBACK;
mg_set((SV*)ary);
RETPUSHUNDEF;
}
-#ifdef USE_5005THREADS
-void
-Perl_unlock_condpair(pTHX_ void *svv)
-{
- MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
-
- if (!mg)
- Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
- MUTEX_LOCK(MgMUTEXP(mg));
- if (MgOWNER(mg) != thr)
- Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
- MgOWNER(mg) = 0;
- COND_SIGNAL(MgOWNERCONDP(mg));
- DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
- PTR2UV(thr), PTR2UV(svv)));
- MUTEX_UNLOCK(MgMUTEXP(mg));
-}
-#endif /* USE_5005THREADS */
-
PP(pp_lock)
{
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);
PP(pp_threadsv)
{
-#ifdef USE_5005THREADS
- dSP;
- EXTEND(SP, 1);
- if (PL_op->op_private & OPpLVAL_INTRO)
- PUSHs(*save_threadsv(PL_op->op_targ));
- else
- PUSHs(THREADSV(PL_op->op_targ));
- RETURN;
-#else
DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
-#endif /* USE_5005THREADS */
}