/* pp.c
*
- * Copyright (c) 1991-2003, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 2005, 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"
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;
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
- char *sym;
- STRLEN len;
-
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
/* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
*/
+ if (SvREADONLY(sv))
+ Perl_croak(aTHX_ PL_no_modify);
if (PL_op->op_private & OPpDEREF) {
- char *name;
+ const char *name;
GV *gv;
if (cUNOP->op_targ) {
STRLEN len;
}
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
- SvRV(sv) = (SV*)gv;
+ if (SvPVX(sv)) {
+ SvOOK_off(sv); /* backoff */
+ if (SvLEN(sv))
+ Safefree(SvPVX(sv));
+ SvLEN_set(sv, 0);
+ SvCUR_set(sv, 0);
+ }
+ SvRV_set(sv, (SV*)gv);
SvROK_on(sv);
SvSETMAGIC(sv);
goto wasref;
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);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
- if (!sv
- && (!is_gv_magical(sym,len,0)
- || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
- {
+ SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
+ if (!temp
+ && (!is_gv_magical_sv(sv,0)
+ || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
RETSETUNDEF;
}
+ sv = temp;
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a symbol");
- sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
+ DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
+ sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
}
}
}
}
}
else {
- char *sym;
- STRLEN len;
gv = (GV*)sv;
if (SvTYPE(gv) != SVt_PVGV) {
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);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
+ gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
if (!gv
- && (!is_gv_magical(sym,len,0)
- || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
+ && (!is_gv_magical_sv(sv, 0)
+ || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
{
RETSETUNDEF;
}
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
- gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+ DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
+ gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
}
}
sv = GvSV(gv);
}
rv = sv_newmortal();
sv_upgrade(rv, SVt_RV);
- SvRV(rv) = sv;
+ SvRV_set(rv, sv);
SvROK_on(rv);
return rv;
}
{
dSP; dTARGET;
SV *sv;
- char *pv;
+ const char *pv;
sv = POPs;
else {
SV *ssv = POPs;
STRLEN len;
- char *ptr;
+ const char *ptr;
if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
Perl_croak(aTHX_ "Attempt to bless into a reference");
GV *gv;
SV *sv;
SV *tmpRef;
- char *elem;
+ const char *elem;
dSP;
STRLEN n_a;
gv = (GV*)POPs;
tmpRef = Nullsv;
sv = Nullsv;
- switch (elem ? *elem : '\0')
- {
- case 'A':
- if (strEQ(elem, "ARRAY"))
- tmpRef = (SV*)GvAV(gv);
- break;
- case 'C':
- if (strEQ(elem, "CODE"))
- tmpRef = (SV*)GvCVu(gv);
- break;
- case 'F':
- if (strEQ(elem, "FILEHANDLE")) {
- /* finally deprecated in 5.8.0 */
- deprecate("*glob{FILEHANDLE}");
- tmpRef = (SV*)GvIOp(gv);
+ if (elem) {
+ /* elem will always be NUL terminated. */
+ const char *elem2 = elem + 1;
+ switch (*elem) {
+ case 'A':
+ if (strEQ(elem2, "RRAY"))
+ tmpRef = (SV*)GvAV(gv);
+ break;
+ case 'C':
+ if (strEQ(elem2, "ODE"))
+ tmpRef = (SV*)GvCVu(gv);
+ break;
+ case 'F':
+ if (strEQ(elem2, "ILEHANDLE")) {
+ /* finally deprecated in 5.8.0 */
+ deprecate("*glob{FILEHANDLE}");
+ tmpRef = (SV*)GvIOp(gv);
+ }
+ else
+ if (strEQ(elem2, "ORMAT"))
+ tmpRef = (SV*)GvFORM(gv);
+ break;
+ case 'G':
+ if (strEQ(elem2, "LOB"))
+ tmpRef = (SV*)gv;
+ break;
+ case 'H':
+ if (strEQ(elem2, "ASH"))
+ tmpRef = (SV*)GvHV(gv);
+ break;
+ case 'I':
+ if (*elem2 == 'O' && !elem[2])
+ tmpRef = (SV*)GvIOp(gv);
+ break;
+ case 'N':
+ if (strEQ(elem2, "AME"))
+ sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
+ break;
+ case 'P':
+ if (strEQ(elem2, "ACKAGE")) {
+ const char *name = HvNAME(GvSTASH(gv));
+ sv = newSVpv(name ? name : "__ANON__", 0);
+ }
+ break;
+ case 'S':
+ if (strEQ(elem2, "CALAR"))
+ tmpRef = GvSV(gv);
+ break;
}
- else
- if (strEQ(elem, "FORMAT"))
- tmpRef = (SV*)GvFORM(gv);
- break;
- case 'G':
- if (strEQ(elem, "GLOB"))
- tmpRef = (SV*)gv;
- break;
- case 'H':
- if (strEQ(elem, "HASH"))
- tmpRef = (SV*)GvHV(gv);
- break;
- case 'I':
- if (strEQ(elem, "IO"))
- tmpRef = (SV*)GvIOp(gv);
- break;
- case 'N':
- if (strEQ(elem, "NAME"))
- sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
- break;
- case 'P':
- if (strEQ(elem, "PACKAGE"))
- sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
- break;
- case 'S':
- if (strEQ(elem, "SCALAR"))
- tmpRef = GvSV(gv);
- break;
}
if (tmpRef)
sv = newRV(tmpRef);
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);
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)
{
- --SvIVX(TOPs);
+ SvIV_set(TOPs, SvIVX(TOPs) - 1);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
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)
&& SvIVX(TOPs) != IV_MAX)
{
- ++SvIVX(TOPs);
+ SvIV_set(TOPs, SvIVX(TOPs) + 1);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
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)
&& SvIVX(TOPs) != IV_MIN)
{
- --SvIVX(TOPs);
+ SvIV_set(TOPs, SvIVX(TOPs) - 1);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
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;
}
}
SP--;
- if (baseuok || !(power & 1))
+ if (baseuok || !odd_power)
/* answer is positive */
SETu( result );
else if (result <= (UV)IV_MAX)
{
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;
+ SvCUR_set(TARG, SvCUR(TARG) * count);
}
*SvEND(TARG) = '\0';
}
#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);
}
}
-#ifdef __GLIBC__
+#if defined(__GLIBC__) && IVSIZE == 8
STATIC
PP(pp_i_modulo_1)
{
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 */
I32 pos;
I32 rem;
I32 fail;
- I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
- char *tmps;
- I32 arybase = PL_curcop->cop_arybase;
+ const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ const char *tmps;
+ const I32 arybase = PL_curcop->cop_arybase;
SV *repl_sv = NULL;
- char *repl = 0;
+ const char *repl = 0;
STRLEN repl_len;
int num_args = PL_op->op_private & 7;
bool repl_need_utf8_upgrade = FALSE;
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_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);
}
+ else
+ SvOK_off(TARG);
LvTYPE(TARG) = 'x';
if (LvTARG(TARG) != sv) {
dSP; dTARGET;
SV *big;
SV *little;
+ SV *temp = Nullsv;
I32 offset;
I32 retval;
char *tmps;
char *tmps2;
STRLEN biglen;
I32 arybase = PL_curcop->cop_arybase;
+ int big_utf8;
+ int little_utf8;
if (MAXARG < 3)
offset = 0;
offset = POPi - arybase;
little = POPs;
big = POPs;
- tmps = SvPV(big, biglen);
- if (offset > 0 && DO_UTF8(big))
+ big_utf8 = DO_UTF8(big);
+ little_utf8 = DO_UTF8(little);
+ if (big_utf8 ^ little_utf8) {
+ /* One needs to be upgraded. */
+ SV *bytes = little_utf8 ? big : little;
+ STRLEN len;
+ char *p = SvPV(bytes, len);
+
+ temp = newSVpvn(p, len);
+
+ if (PL_encoding) {
+ sv_recode_to_utf8(temp, PL_encoding);
+ } else {
+ sv_utf8_upgrade(temp);
+ }
+ if (little_utf8) {
+ big = temp;
+ big_utf8 = TRUE;
+ } else {
+ little = temp;
+ }
+ }
+ if (big_utf8 && offset > 0)
sv_pos_u2b(big, &offset, 0);
+ tmps = SvPV(big, biglen);
if (offset < 0)
offset = 0;
else if (offset > (I32)biglen)
retval = -1;
else
retval = tmps2 - tmps;
- if (retval > 0 && DO_UTF8(big))
+ if (retval > 0 && big_utf8)
sv_pos_b2u(big, &retval);
+ if (temp)
+ SvREFCNT_dec(temp);
PUSHi(retval + arybase);
RETURN;
}
dSP; dTARGET;
SV *big;
SV *little;
+ SV *temp = Nullsv;
STRLEN blen;
STRLEN llen;
I32 offset;
char *tmps;
char *tmps2;
I32 arybase = PL_curcop->cop_arybase;
+ int big_utf8;
+ int little_utf8;
if (MAXARG >= 3)
offset = POPi;
little = POPs;
big = POPs;
+ big_utf8 = DO_UTF8(big);
+ little_utf8 = DO_UTF8(little);
+ if (big_utf8 ^ little_utf8) {
+ /* One needs to be upgraded. */
+ SV *bytes = little_utf8 ? big : little;
+ STRLEN len;
+ char *p = SvPV(bytes, len);
+
+ temp = newSVpvn(p, len);
+
+ if (PL_encoding) {
+ sv_recode_to_utf8(temp, PL_encoding);
+ } else {
+ sv_utf8_upgrade(temp);
+ }
+ if (little_utf8) {
+ big = temp;
+ big_utf8 = TRUE;
+ } else {
+ little = temp;
+ }
+ }
tmps2 = SvPV(little, llen);
tmps = SvPV(big, blen);
+
if (MAXARG < 3)
offset = blen;
else {
- if (offset > 0 && DO_UTF8(big))
+ if (offset > 0 && big_utf8)
sv_pos_u2b(big, &offset, 0);
offset = offset - arybase + llen;
}
retval = -1;
else
retval = tmps2 - tmps;
- if (retval > 0 && DO_UTF8(big))
+ if (retval > 0 && big_utf8)
sv_pos_b2u(big, &retval);
+ if (temp)
+ SvREFCNT_dec(temp);
PUSHi(retval + arybase);
RETURN;
}
}
XPUSHu(DO_UTF8(argsv) ?
- utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
+ utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
(*s & 0xff));
RETURN;
tmps = SvPVX(TARG);
if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
- SvGROW(TARG,3);
+ SvGROW(TARG, 3);
+ tmps = SvPVX(TARG);
SvCUR_set(TARG, 2);
*tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
*tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
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
if (DO_UTF8(sv) &&
(s = (U8*)SvPV_nomg(sv, slen)) && slen &&
UTF8_IS_START(*s)) {
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
STRLEN ulen;
STRLEN tculen;
(s = (U8*)SvPV_nomg(sv, slen)) && slen &&
UTF8_IS_START(*s)) {
STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
U8 *tend;
UV uv;
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf[UTF8_MAXBYTES+1];
s = (U8*)SvPV_nomg(sv,len);
if (!len) {
SETs(TARG);
}
else {
- STRLEN nchar = utf8_length(s, s + len);
+ STRLEN min = len + 1;
(void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
+ SvGROW(TARG, min);
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
while (s < send) {
+ STRLEN u = UTF8SKIP(s);
+
toUPPER_utf8(s, tmpbuf, &ulen);
+ if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows
+ * the available space, we need to grow. */
+ UV o = d - (U8*)SvPVX(TARG);
+
+ /* 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. */
+ SvGROW(TARG, min);
+ d = (U8*)SvPVX(TARG) + o;
+ }
Copy(tmpbuf, d, ulen, U8);
d += ulen;
- s += UTF8SKIP(s);
+ s += u;
}
*d = '\0';
SvUTF8_on(TARG);
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
s = (U8*)SvPV_nomg(sv,len);
if (!len) {
SETs(TARG);
}
else {
- STRLEN nchar = utf8_length(s, s + len);
+ STRLEN min = len + 1;
(void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
+ SvGROW(TARG, min);
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
while (s < send) {
+ STRLEN u = UTF8SKIP(s);
UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
-#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
+
+#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
/*
* Now if the sigma is NOT followed by
* then it should be mapped to 0x03C2,
* (GREEK SMALL LETTER FINAL SIGMA),
* instead of staying 0x03A3.
- * See lib/unicore/SpecCase.txt.
+ * "should be": in other words,
+ * this is not implemented yet.
+ * See lib/unicore/SpecialCasing.txt.
*/
}
+ if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows
+ * the available space, we need to grow. */
+ UV o = d - (U8*)SvPVX(TARG);
+
+ /* If someone lowercases one million U+0130s we
+ * SvGROW() one million times. Or we could try
+ * guessing how much to allocate without allocating.
+ * too much. Such is life. */
+ SvGROW(TARG, min);
+ d = (U8*)SvPVX(TARG) + o;
+ }
Copy(tmpbuf, d, ulen, U8);
d += ulen;
- s += UTF8SKIP(s);
+ s += u;
}
*d = '\0';
SvUTF8_on(TARG);
}
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++ = newSVsv(h);
+ }
+
if (diff < 0) { /* shrinking the area */
if (newlen) {
New(451, tmparyval, newlen, SV*); /* so remember insertion */
*dst-- = *src--;
}
dst = AvARRAY(ary);
- SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
+ SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
AvMAX(ary) += diff;
}
else {
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);
}
}
dst = src - diff;
Move(src, dst, offset, SV*);
}
- SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
+ SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
AvMAX(ary) += diff;
AvFILLp(ary) += diff;
}
}
}
- 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) {
else {
av_unshift(ary, SP - MARK);
while (MARK < SP) {
- sv = NEWSV(27, 0);
- sv_setsv(sv, *++MARK);
+ sv = newSVsv(*++MARK);
(void)av_store(ary, i++, sv);
}
}
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;
+ bool multiline = 0;
MAGIC *mg = (MAGIC *) NULL;
#ifdef DEBUGGING
AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
}
/* temporarily switch stacks */
- SWITCHSTACK(PL_curstack, ary);
- PL_curstackinfo->si_stack = ary;
+ SAVESWITCHSTACK(PL_curstack, ary);
make_mortal = 0;
}
}
s++;
}
}
- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
+ if (pm->op_pmflags & PMf_MULTILINE) {
+ multiline = 1;
}
if (!limit)
if (m >= strend)
break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
++s;
}
}
- else if (strEQ("^", rx->precomp)) {
+ else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
while (--limit) {
/*SUPPRESS 530*/
for (m = s; m < strend && *m != '\n'; m++) ;
m++;
if (m >= strend)
break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
for (m = s; m < strend && *m != c; m++) ;
if (m >= strend)
break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
#ifndef lint
while (s < strend && --limit &&
(m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
- csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
+ csv, multiline ? FBMrf_MULTILINE : 0)) )
#endif
{
- dstr = NEWSV(31, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
}
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;
strend = s + (strend - m);
}
m = rx->startp[0] + orig;
- dstr = NEWSV(32, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
parens that didn't match -- they should be set to
undef, not the empty string */
if (m >= orig && s >= orig) {
- dstr = NEWSV(33, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
}
else
dstr = &PL_sv_undef; /* undef, not "" */
}
}
s = rx->endp[0] + orig;
- PUTBACK;
}
}
- LEAVE_SCOPE(oldsave);
iters = (SP - PL_stack_base) - base;
if (iters > maxiters)
DIE(aTHX_ "Split loop");
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
STRLEN l = strend - s;
- dstr = NEWSV(34, l);
- sv_setpvn(dstr, s, l);
+ dstr = newSVpvn(s, l);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
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);
- PL_curstackinfo->si_stack = oldstack;
if (SvSMAGICAL(ary)) {
PUTBACK;
mg_set((SV*)ary);
if (gimme == G_ARRAY)
RETURN;
}
- if (iters || !pm->op_pmreplroot) {
- GETTARGET;
- PUSHi(iters);
- RETURN;
- }
- RETPUSHUNDEF;
+
+ GETTARGET;
+ PUSHi(iters);
+ RETURN;
}
PP(pp_lock)
{
DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: shiftwidth=4:
+*/
https://perl5.git.perl.org / perl5.git / blobdiff