/* pp.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
*/
+/* This file contains general pp ("push/pop") functions that execute the
+ * opcodes that make up a perl program. A typical pp function expects to
+ * find its arguments on the stack, and usually pushes its results onto
+ * the stack, hence the 'pp' terminology. Each OP structure contains
+ * a pointer to the relevant pp_foo() function.
+ */
+
#include "EXTERN.h"
#define PERL_IN_PP_C
#include "perl.h"
#include "reentr.h"
-/* variations on pp_null */
-
/* XXX I can't imagine anyone who doesn't have this actually _needs_
it, since pid_t is an integral type.
--AD 2/20/1998
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)) {
}
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) {
RETURNOP(do_kv());
}
else if (gimme == G_SCALAR) {
- SV* sv = sv_newmortal();
- if (HvFILL((HV*)TARG))
- Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
- (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
- else
- sv_setiv(sv, 0);
+ SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
SETs(sv);
}
RETURN;
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);
}
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
+ if (SvPVX(sv)) {
+ SvOOK_off(sv); /* backoff */
+ if (SvLEN(sv))
+ Safefree(SvPVX(sv));
+ SvLEN(sv)=SvCUR(sv)=0;
+ }
SvRV(sv) = (SV*)gv;
SvROK_on(sv);
SvSETMAGIC(sv);
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "a symbol");
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
RETSETUNDEF;
}
sym = SvPV(sv,len);
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)) {
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "a SCALAR");
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
RETSETUNDEF;
}
sym = SvPV(sv, len);
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);
}
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);
sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
break;
case 'P':
- if (strEQ(elem, "PACKAGE"))
- sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
+ if (strEQ(elem, "PACKAGE")) {
+ if (HvNAME(GvSTASH(gv)))
+ sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
+ else
+ sv = newSVpv("__ANON__",0);
+ }
break;
case 'S':
if (strEQ(elem, "SCALAR"))
if (PL_op->op_flags & OPf_STACKED)
sv = POPs;
+ else if (PL_op->op_private & OPpTARGET_MY)
+ sv = GETTARGET;
else {
sv = DEFSV;
EXTEND(SP,1);
if (!sv)
RETPUSHUNDEF;
- if (SvTHINKFIRST(sv))
- sv_force_normal(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
break;
default:
if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
- (void)SvOOK_off(sv);
+ SvOOK_off(sv);
Safefree(SvPVX(sv));
SvPV_set(sv, Nullch);
SvLEN_set(sv, 0);
}
- (void)SvOK_off(sv);
+ SvOK_off(sv);
SvSETMAGIC(sv);
}
PP(pp_predec)
{
dSP;
- if (SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MIN)
PP(pp_postinc)
{
dSP; dTARGET;
- if (SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
else
sv_inc(TOPs);
SvSETMAGIC(TOPs);
+ /* special case for undef: see thread at 2003-03/msg00536.html in archive */
if (!SvOK(TARG))
sv_setiv(TARG, 0);
SETs(TARG);
PP(pp_postdec)
{
dSP; dTARGET;
- if (SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
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
- /* ** is implemented with pow. pow is floating point. Perl programmers
- write 2 ** 31 and expect it to be 2147483648
- pow never made any guarantee to deliver a result to 53 (or whatever)
- bits of accuracy. Which is unfortunate, as perl programmers expect it
- to, and on some platforms (eg Irix with long doubles) it doesn't in
- a very visible case. (2 ** 31, which a regression test uses)
- So we'll implement power-of-2 ** +ve integer with multiplies, to avoid
- these problems. */
+ /* 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(TOPm1s);
if (SvIOK(TOPm1s)) {
goto float_it; /* Can't do negative powers this way. */
}
}
- /* now we have integer ** positive integer.
- foo & (foo - 1) is zero only for a power of 2. */
+ /* 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 postive integer.
+ /* 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
NV base = baseuok ? baseuv : -(NV)baseuv;
int n = 0;
- /* The logic is this.
- x ** n === x ** m1 * x ** m2 where n = m1 + m2
- so as 42 is 32 + 8 + 2
- x ** 42 can be written as
- x ** 32 * x ** 8 * x ** 2
- I can calculate x ** 2, x ** 4, x ** 8 etc trivially:
- x ** 2n is x ** n * x ** n
- So I loop round, squaring x each time
- (x, x ** 2, x ** 4, x ** 8) and multiply the result
- by the x-value whenever that bit is set in the power.
- To finish as soon as possible I zero bits in the power
- when I've done them, so that power becomes zero when
- I clear the last bit (no more to do), and the loop
- terminates. */
for (; power; base *= base, n++) {
/* Do I look like I trust gcc with long longs here?
Do I hell. */
if (power & bit) {
result *= base;
/* Only bother to clear the bit if it is set. */
- power &= ~bit;
+ 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;
+ bool odd_power = (bool)(power & 1);
+ 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 || !odd_power)
+ /* answer is positive */
+ SETu( result );
+ else if (result <= (UV)IV_MAX)
+ /* answer negative, fits in IV */
+ SETi( -(IV)result );
+ else if (result == (UV)IV_MIN)
+ /* 2's complement assumption: special case IV_MIN */
+ SETi( IV_MIN );
+ else
+ /* answer negative, doesn't fit */
+ SETn( -(NV)result );
+ RETURN;
+ }
+ }
+ }
+ }
}
- float_it:
+ float_it:
#endif
{
- dPOPTOPnnrl;
- SETn( Perl_pow( left, right) );
- RETURN;
+ dPOPTOPnnrl;
+ SETn( Perl_pow( left, right) );
+#ifdef PERL_PRESERVE_IVUV
+ if (is_int)
+ SvIV_please(TOPs);
+#endif
+ RETURN;
}
}
}
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 */
{
dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
{
- register IV count = POPi;
+ register IV count;
+ dPOPss;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvIOKp(sv)) {
+ if (SvUOK(sv)) {
+ UV uv = SvUV(sv);
+ if (uv > IV_MAX)
+ count = IV_MAX; /* The best we can do? */
+ else
+ count = uv;
+ } else {
+ IV iv = SvIV(sv);
+ if (iv < 0)
+ count = 0;
+ else
+ count = iv;
+ }
+ }
+ else if (SvNOKp(sv)) {
+ NV nv = SvNV(sv);
+ if (nv < 0.0)
+ count = 0;
+ else
+ count = (IV)nv;
+ }
+ else
+ count = SvIVx(sv);
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
I32 items = SP - MARK;
I32 max;
+ static const char oom_list_extend[] =
+ "Out of memory during list extend";
max = items * count;
+ MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
+ /* Did the max computation overflow? */
+ if (items > 0 && max > 0 && (max < items || max < count))
+ Perl_croak(aTHX_ oom_list_extend);
MEXTEND(MARK, max);
if (count > 1) {
while (SP > MARK) {
SV *tmpstr = POPs;
STRLEN len;
bool isutf;
+ static const char oom_string_extend[] =
+ "Out of memory during string extend";
SvSetSV(TARG, tmpstr);
SvPV_force(TARG, len);
if (count < 1)
SvCUR_set(TARG, 0);
else {
+ IV max = count * len;
+ if (len > ((MEM_SIZE)~0)/count)
+ Perl_croak(aTHX_ oom_string_extend);
+ MEM_WRAP_CHECK_1(max, char, oom_string_extend);
SvGROW(TARG, (count * len) + 1);
repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
SvCUR(TARG) *= count;
#ifdef PERL_PRESERVE_IVUV
else
#endif
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
- SP--;
- SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
- RETURN;
- }
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+ SP--;
+ SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
+ RETURN;
+ }
#endif
{
dPOPnv;
#ifdef PERL_PRESERVE_IVUV
else
#endif
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
RETURN;
#ifdef PERL_PRESERVE_IVUV
else
#endif
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
RETURN;
#ifdef PERL_PRESERVE_IVUV
else
#endif
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
RETURN;
{
dSP; tryAMAGICbinSET(ne,0);
#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
RETURN;
{
dSP; dTARGET; tryAMAGICbin(ncmp,0);
#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
UV right = PTR2UV(SvRV(POPs));
UV left = PTR2UV(SvRV(TOPs));
SETi((left > right) - (left < right));
dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
{
dPOPTOPssrl;
+ if (SvGMAGICAL(left)) mg_get(left);
+ if (SvGMAGICAL(right)) mg_get(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = SvIV(left) & SvIV(right);
+ IV i = SvIV_nomg(left) & SvIV_nomg(right);
SETi(i);
}
else {
- UV u = SvUV(left) & SvUV(right);
+ UV u = SvUV_nomg(left) & SvUV_nomg(right);
SETu(u);
}
}
dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
{
dPOPTOPssrl;
+ if (SvGMAGICAL(left)) mg_get(left);
+ if (SvGMAGICAL(right)) mg_get(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+ IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
SETi(i);
}
else {
- UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+ UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
SETu(u);
}
}
dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
{
dPOPTOPssrl;
+ if (SvGMAGICAL(left)) mg_get(left);
+ if (SvGMAGICAL(right)) mg_get(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+ IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
SETi(i);
}
else {
- UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+ UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
SETu(u);
}
}
dSP; dTARGET; tryAMAGICun(compl);
{
dTOPss;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
if (SvNIOKp(sv)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = ~SvIV(sv);
+ IV i = ~SvIV_nomg(sv);
SETi(i);
}
else {
- UV u = ~SvUV(sv);
+ UV u = ~SvUV_nomg(sv);
SETu(u);
}
}
register I32 anum;
STRLEN len;
- SvSetSV(TARG, sv);
+ (void)SvPV_nomg(sv,len); /* force check for uninit var */
+ sv_setsv_nomg(TARG, sv);
tmps = (U8*)SvPV_force(TARG, len);
anum = len;
if (SvUTF8(TARG)) {
*result = '\0';
result -= nchar;
sv_setpvn(TARG, (char*)result, nchar);
+ SvUTF8_off(TARG);
}
Safefree(result);
SETs(TARG);
}
}
+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;
+ }
+}
+
+#if defined(__GLIBC__) && IVSIZE == 8
+STATIC
+PP(pp_i_modulo_1)
+{
+ /* 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. */
+ 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)
RETPUSHYES;
}
-STATIC U32
-S_seed(pTHX)
-{
- /*
- * This is really just a quick hack which grabs various garbage
- * values. It really should be a real hash algorithm which
- * spreads the effect of every input bit onto every output bit,
- * if someone who knows about such things would bother to write it.
- * Might be a good idea to add that function to CORE as well.
- * No numbers below come from careful analysis or anything here,
- * except they are primes and SEED_C1 > 1E6 to get a full-width
- * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
- * probably be bigger too.
- */
-#if RANDBITS > 16
-# define SEED_C1 1000003
-#define SEED_C4 73819
-#else
-# define SEED_C1 25747
-#define SEED_C4 20639
-#endif
-#define SEED_C2 3
-#define SEED_C3 269
-#define SEED_C5 26107
-
-#ifndef PERL_NO_DEV_RANDOM
- int fd;
-#endif
- U32 u;
-#ifdef VMS
-# include <starlet.h>
- /* when[] = (low 32 bits, high 32 bits) of time since epoch
- * in 100-ns units, typically incremented ever 10 ms. */
- unsigned int when[2];
-#else
-# ifdef HAS_GETTIMEOFDAY
- struct timeval when;
-# else
- Time_t when;
-# endif
-#endif
-
-/* This test is an escape hatch, this symbol isn't set by Configure. */
-#ifndef PERL_NO_DEV_RANDOM
-#ifndef PERL_RANDOM_DEVICE
- /* /dev/random isn't used by default because reads from it will block
- * if there isn't enough entropy available. You can compile with
- * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
- * is enough real entropy to fill the seed. */
-# define PERL_RANDOM_DEVICE "/dev/urandom"
-#endif
- fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
- if (fd != -1) {
- if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
- u = 0;
- PerlLIO_close(fd);
- if (u)
- return u;
- }
-#endif
-
-#ifdef VMS
- _ckvmssts(sys$gettim(when));
- u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
-#else
-# ifdef HAS_GETTIMEOFDAY
- PerlProc_gettimeofday(&when,NULL);
- u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
-# else
- (void)time(&when);
- u = (U32)SEED_C1 * when;
-# endif
-#endif
- u += SEED_C3 * (U32)PerlProc_getpid();
- u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
-#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
- u += SEED_C5 * (U32)PTR2UV(&when);
-#endif
- return u;
-}
-
PP(pp_exp)
{
dSP; dTARGET; tryAMAGICun(exp);
}
}
-/*
- * 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);
else preferring IV has introduced a subtle behaviour change bug. OTOH
relying on floating point to be accurate is a bug. */
- if (SvIOK(TOPs)) {
+ if (!SvOK(TOPs))
+ SETu(0);
+ else if (SvIOK(TOPs)) {
if (SvIsUV(TOPs)) {
UV uv = TOPu;
SETu(uv);
if (value < (NV)UV_MAX + 0.5) {
SETu(U_V(value));
} else {
-#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
- (void)Perl_modf(value, &value);
-# endif
-# else
- double tmp = (double)value;
- (void)Perl_modf(tmp, &tmp);
- value = (NV)tmp;
-# endif
-#endif
- SETn(value);
+ SETn(Perl_floor(value));
}
}
else {
if (value > (NV)IV_MIN - 0.5) {
SETi(I_V(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
- (void)Perl_modf(-value, &value);
-# endif
- value = -value;
-#else
- double tmp = (double)value;
- (void)Perl_modf(-tmp, &tmp);
- value = -(NV)tmp;
-#endif
- SETn(value);
+ SETn(Perl_ceil(value));
}
}
}
/* This will cache the NV value if string isn't actually integer */
IV iv = TOPi;
- if (SvIOK(TOPs)) {
+ if (!SvOK(TOPs))
+ SETu(0);
+ else if (SvIOK(TOPs)) {
/* IVX is precise */
if (SvIsUV(TOPs)) {
SETu(TOPu); /* force it to be numeric only */
if (utf8_curlen)
sv_pos_u2b(sv, &pos, &rem);
tmps += 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();
+ }
+ }
+
sv_setpvn(TARG, tmps, rem);
#ifdef USE_LOCALE_COLLATE
sv_unmagic(TARG, PERL_MAGIC_collxfrm);
sv_upgrade(TARG, SVt_PVLV);
sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
}
+ else
+ SvOK_off(TARG);
LvTYPE(TARG) = 'x';
if (LvTARG(TARG) != sv) {
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);
*tmps++ = (char)value;
*tmps = '\0';
(void)SvPOK_only(TARG);
- if (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);
+ tmps = SvPVX(TARG);
+ 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;
}
sv_utf8_downgrade(tsv, FALSE);
tmps = SvPVX(tsv);
}
+# ifdef USE_ITHREADS
+# ifdef HAS_CRYPT_R
+ if (!PL_reentrant_buffer->_crypt_struct_buffer) {
+ /* This should be threadsafe because in ithreads there is only
+ * one thread per interpreter. If this would not be true,
+ * we would need a mutex to protect this malloc. */
+ PL_reentrant_buffer->_crypt_struct_buffer =
+ (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
+#if defined(__GLIBC__) || defined(__EMX__)
+ if (PL_reentrant_buffer->_crypt_struct_buffer) {
+ PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
+ /* work around glibc-2.2.5 bug */
+ PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
+ }
+#endif
+ }
+# endif /* HAS_CRYPT_R */
+# endif /* USE_ITHREADS */
# ifdef FCRYPT
sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
# else
register U8 *s;
STRLEN slen;
- if (DO_UTF8(sv)) {
+ 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_UCLC+1];
U8 *tend;
toLOWER_utf8(s, tmpbuf, &ulen);
uv = utf8_to_uvchr(tmpbuf, 0);
-
tend = uvchr_to_utf8(tmpbuf, uv);
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;
U8 *send;
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);
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;
U8 *send;
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);
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;
}
}
if (GIMME != G_ARRAY) {
MARK = ORIGMARK;
- *++MARK = *SP;
+ *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
SP = MARK;
}
RETURN;
SP = ORIGMARK;
else if (gimme == G_SCALAR) {
MARK = ORIGMARK;
- *++MARK = *SP;
+ if (SP > MARK)
+ *++MARK = *SP;
+ else
+ *++MARK = &PL_sv_undef;
SP = MARK;
}
}
}
if (GIMME != G_ARRAY) {
MARK = ORIGMARK;
- *++MARK = *SP;
+ *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
SP = MARK;
}
RETURN;
if (newlen && !AvREAL(ary) && AvREIFY(ary))
av_reify(ary);
+ /* make new elements SVs now: avoid problems if they're from the array */
+ for (dst = MARK, i = newlen; i; i--) {
+ SV *h = *dst;
+ *dst = NEWSV(46, 0);
+ sv_setsv(*dst++, h);
+ }
+
if (diff < 0) { /* shrinking the area */
if (newlen) {
New(451, tmparyval, newlen, SV*); /* so remember insertion */
dst[--i] = &PL_sv_undef;
if (newlen) {
- for (src = tmparyval, dst = AvARRAY(ary) + offset;
- newlen; newlen--) {
- *dst = NEWSV(46, 0);
- sv_setsv(*dst++, *src++);
- }
+ Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
Safefree(tmparyval);
}
}
}
}
- for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
- *dst = NEWSV(46, 0);
- sv_setsv(*dst++, *src++);
+ if (newlen) {
+ Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
}
+
MARK = ORIGMARK + 1;
if (GIMME == G_ARRAY) { /* copy return vals to stack */
if (length) {
register I32 tmp;
dTARGET;
STRLEN len;
+ I32 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 : DEFSV);
+ sv_setsv(TARG, (SP > MARK)
+ ? *SP
+ : (padoff_du = find_rundefsvoffset(),
+ (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
+ ? DEFSV : PAD_SVl(padoff_du)));
up = SvPV_force(TARG, len);
if (len > 1) {
if (DO_UTF8(TARG)) { /* first reverse each character */
I32 origlimit = limit;
I32 realarray = 0;
I32 base;
- AV *oldstack = PL_curstack;
I32 gimme = GIMME_V;
I32 oldsave = PL_savestack_ix;
I32 make_mortal = 1;
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))) {
AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
}
/* temporarily switch stacks */
- SWITCHSTACK(PL_curstack, ary);
+ SAVESWITCHSTACK(PL_curstack, ary);
make_mortal = 0;
}
}
s++;
}
}
- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+ if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
}
}
else {
maxiters += slen * rx->nparens;
- while (s < strend && --limit
-/* && (!rx->check_substr
- || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
- 0, NULL))))
-*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
- 1 /* minend */, sv, NULL, 0))
+ while (s < strend && --limit)
{
+ PUTBACK;
+ i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
+ SPAGAIN;
+ if (i == 0)
+ break;
TAINT_IF(RX_MATCH_TAINTED(rx));
if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
m = s;
}
}
- LEAVE_SCOPE(oldsave);
iters = (SP - PL_stack_base) - base;
if (iters > maxiters)
DIE(aTHX_ "Split loop");
if (TOPs && !make_mortal)
sv_2mortal(TOPs);
iters--;
- SP--;
+ *SP-- = &PL_sv_undef;
}
}
+ PUTBACK;
+ LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
+ SPAGAIN;
if (realarray) {
if (!mg) {
- SWITCHSTACK(ary, oldstack);
if (SvSMAGICAL(ary)) {
PUTBACK;
mg_set((SV*)ary);
if (gimme == G_ARRAY)
RETURN;
}
- if (iters || !pm->op_pmreplroot) {
- GETTARGET;
- PUSHi(iters);
- RETURN;
- }
- 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));
+ GETTARGET;
+ PUSHi(iters);
+ RETURN;
}
-#endif /* USE_5005THREADS */
PP(pp_lock)
{
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 */
}
https://perl5.git.perl.org / perl5.git / blobdiff