/* pp.c
*
- * Copyright (c) 1991-2003, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 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.
}
else if (gimme == G_SCALAR) {
SV* sv = sv_newmortal();
+ if (SvRMAGICAL(TARG) && mg_find(TARG, PERL_MAGIC_tied))
+ Perl_croak(aTHX_ "Can't provide tied hash usage; "
+ "use keys(%%hash) to test if empty");
if (HvFILL((HV*)TARG))
Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
(long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 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"))
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)
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);
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);
+ /* This is maint, and we don't have Perl_ceil in perl.h */
+ SETn(-Perl_floor(-value));
}
}
}
sv_upgrade(TARG, SVt_PVLV);
sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
}
+ else
+ (void)SvOK_off(TARG);
LvTYPE(TARG) = 'x';
if (LvTARG(TARG) != sv) {
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;
}
}
s = rx->endp[0] + orig;
- PUTBACK;
}
}
https://perl5.git.perl.org / perl5.git / blobdiff