#endif
#endif
+#include <math.h>
+#include <stdlib.h>
+
#ifdef __Lynx__
/* Missing protos on LynxOS */
int putenv(char *);
dTHX;
#endif
Malloc_t ptr;
-#ifdef HAS_64K_LIMIT
- if (size > 0xffff) {
- PerlIO_printf(Perl_error_log,
- "Allocation too large: %lx\n", size) FLUSH;
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
#ifdef PERL_TRACK_MEMPOOL
size += sTHX;
#endif
Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
-#ifdef HAS_64K_LIMIT
- if (size > 0xffff) {
- PerlIO_printf(Perl_error_log,
- "Reallocation too large: %lx\n", size) FLUSH;
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
if (!size) {
safesysfree(where);
return NULL;
dTHX;
#endif
Malloc_t ptr;
-#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
+#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING)
MEM_SIZE total_size = 0;
#endif
/* Even though calloc() for zero bytes is strange, be robust. */
if (size && (count <= MEM_SIZE_MAX / size)) {
-#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
+#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING)
total_size = size * count;
#endif
}
else
- Perl_croak_memory_wrap();
+ croak_memory_wrap();
#ifdef PERL_TRACK_MEMPOOL
if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
total_size += sTHX;
else
- Perl_croak_memory_wrap();
+ croak_memory_wrap();
#endif
-#ifdef HAS_64K_LIMIT
- if (total_size > 0xffff) {
- PerlIO_printf(Perl_error_log,
- "Allocation too large: %lx\n", total_size) FLUSH;
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
if ((SSize_t)size < 0 || (SSize_t)count < 0)
Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
const U8 *s;
STRLEN i;
STRLEN len;
- STRLEN rarest = 0;
U32 frequency = 256;
MAGIC *mg;
+ PERL_DEB( STRLEN rarest = 0 );
PERL_ARGS_ASSERT_FBM_COMPILE;
- if (isGV_with_GP(sv))
+ if (isGV_with_GP(sv) || SvROK(sv))
return;
if (SvVALID(sv))
if (mg && mg->mg_len >= 0)
mg->mg_len++;
}
- s = (U8*)SvPV_force_mutable(sv, len);
+ if (!SvPOK(sv) || SvNIOKp(sv))
+ s = (U8*)SvPV_force_mutable(sv, len);
+ else s = (U8 *)SvPV_mutable(sv, len);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
SvUPGRADE(sv, SVt_PVMG);
s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
if (PL_freq[s[i]] < frequency) {
- rarest = i;
+ PERL_DEB( rarest = i );
frequency = PL_freq[s[i]];
}
}
- BmRARE(sv) = s[rarest];
- BmPREVIOUS(sv) = rarest;
BmUSEFUL(sv) = 100; /* Initial value */
if (flags & FBMcf_TAIL)
SvTAIL_on(sv);
DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
- BmRARE(sv), BmPREVIOUS(sv)));
+ s[rarest], (UV)rarest));
}
/* If SvTAIL(littlestr), it has a fake '\n' at end. */
return retval;
}
-STATIC const COP*
-S_closest_cop(pTHX_ const COP *cop, const OP *o)
+const COP*
+Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
+ bool opnext)
{
dVAR;
- /* Look for PL_op starting from o. cop is the last COP we've seen. */
+ /* Look for curop starting from o. cop is the last COP we've seen. */
+ /* opnext means that curop is actually the ->op_next of the op we are
+ seeking. */
PERL_ARGS_ASSERT_CLOSEST_COP;
- if (!o || o == PL_op)
+ if (!o || !curop || (
+ opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
+ ))
return cop;
if (o->op_flags & OPf_KIDS) {
/* Keep searching, and return when we've found something. */
- new_cop = closest_cop(cop, kid);
+ new_cop = closest_cop(cop, kid, curop, opnext);
if (new_cop)
return new_cop;
}
* from the sibling of PL_curcop.
*/
- const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
+ const COP *cop =
+ closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE);
if (!cop)
cop = PL_curcop;
if (PL_stderrgv && SvREFCNT(PL_stderrgv)
&& (io = GvIO(PL_stderrgv))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
- Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
+ Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
else {
#ifdef USE_SFIO
my_exit(1);
}
-/* saves machine code for a common noreturn idiom typically used in Newx*() */
-void
-Perl_croak_memory_wrap(void)
-{
- Perl_croak_nocontext("%s",PL_memory_wrap);
-}
-
-
/* does not return, used only in POPSTACK */
void
Perl_croak_popstack(void)
#endif /* HAS_VPRINTF */
-#ifdef MYSWAP
-#if BYTEORDER != 0x4321
-short
-Perl_my_swap(pTHX_ short s)
-{
-#if (BYTEORDER & 1) == 0
- short result;
-
- result = ((s & 255) << 8) + ((s >> 8) & 255);
- return result;
-#else
- return s;
-#endif
-}
-
-long
-Perl_my_htonl(pTHX_ long l)
-{
- union {
- long result;
- char c[sizeof(long)];
- } u;
-
-#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
-#if BYTEORDER == 0x12345678
- u.result = 0;
-#endif
- u.c[0] = (l >> 24) & 255;
- u.c[1] = (l >> 16) & 255;
- u.c[2] = (l >> 8) & 255;
- u.c[3] = l & 255;
- return u.result;
-#else
-#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
- Perl_croak(aTHX_ "Unknown BYTEORDER\n");
-#else
- I32 o;
- I32 s;
-
- for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
- u.c[o & 0xf] = (l >> s) & 255;
- }
- return u.result;
-#endif
-#endif
-}
-
-long
-Perl_my_ntohl(pTHX_ long l)
-{
- union {
- long l;
- char c[sizeof(long)];
- } u;
-
-#if BYTEORDER == 0x1234
- u.c[0] = (l >> 24) & 255;
- u.c[1] = (l >> 16) & 255;
- u.c[2] = (l >> 8) & 255;
- u.c[3] = l & 255;
- return u.l;
-#else
-#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
- Perl_croak(aTHX_ "Unknown BYTEORDER\n");
-#else
- I32 o;
- I32 s;
-
- u.l = l;
- l = 0;
- for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
- l |= (u.c[o & 0xf] & 255) << s;
- }
- return l;
-#endif
-#endif
-}
-
-#endif /* BYTEORDER != 0x4321 */
-#endif /* MYSWAP */
-
-/*
- * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
- * If these functions are defined,
- * the BYTEORDER is neither 0x1234 nor 0x4321.
- * However, this is not assumed.
- * -DWS
- */
-
-#define HTOLE(name,type) \
- type \
- name (type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- U32 i; \
- U32 s = 0; \
- for (i = 0; i < sizeof(u.c); i++, s += 8) { \
- u.c[i] = (n >> s) & 0xFF; \
- } \
- return u.value; \
- }
-
-#define LETOH(name,type) \
- type \
- name (type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- U32 i; \
- U32 s = 0; \
- u.value = n; \
- n = 0; \
- for (i = 0; i < sizeof(u.c); i++, s += 8) { \
- n |= ((type)(u.c[i] & 0xFF)) << s; \
- } \
- return n; \
- }
-
-/*
- * Big-endian byte order functions.
- */
-
-#define HTOBE(name,type) \
- type \
- name (type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- U32 i; \
- U32 s = 8*(sizeof(u.c)-1); \
- for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
- u.c[i] = (n >> s) & 0xFF; \
- } \
- return u.value; \
- }
-
-#define BETOH(name,type) \
- type \
- name (type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- U32 i; \
- U32 s = 8*(sizeof(u.c)-1); \
- u.value = n; \
- n = 0; \
- for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
- n |= ((type)(u.c[i] & 0xFF)) << s; \
- } \
- return n; \
- }
-
-/*
- * If we just can't do it...
- */
-
-#define NOT_AVAIL(name,type) \
- type \
- name (type n) \
- { \
- Perl_croak_nocontext(#name "() not available"); \
- return n; /* not reached */ \
- }
-
-
-#if defined(HAS_HTOVS) && !defined(htovs)
-HTOLE(htovs,short)
-#endif
-#if defined(HAS_HTOVL) && !defined(htovl)
-HTOLE(htovl,long)
-#endif
-#if defined(HAS_VTOHS) && !defined(vtohs)
-LETOH(vtohs,short)
-#endif
-#if defined(HAS_VTOHL) && !defined(vtohl)
-LETOH(vtohl,long)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE16
-# if U16SIZE == 2
-HTOLE(Perl_my_htole16,U16)
-# else
-NOT_AVAIL(Perl_my_htole16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH16
-# if U16SIZE == 2
-LETOH(Perl_my_letoh16,U16)
-# else
-NOT_AVAIL(Perl_my_letoh16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE16
-# if U16SIZE == 2
-HTOBE(Perl_my_htobe16,U16)
-# else
-NOT_AVAIL(Perl_my_htobe16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH16
-# if U16SIZE == 2
-BETOH(Perl_my_betoh16,U16)
-# else
-NOT_AVAIL(Perl_my_betoh16,U16)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE32
-# if U32SIZE == 4
-HTOLE(Perl_my_htole32,U32)
-# else
-NOT_AVAIL(Perl_my_htole32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH32
-# if U32SIZE == 4
-LETOH(Perl_my_letoh32,U32)
-# else
-NOT_AVAIL(Perl_my_letoh32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE32
-# if U32SIZE == 4
-HTOBE(Perl_my_htobe32,U32)
-# else
-NOT_AVAIL(Perl_my_htobe32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH32
-# if U32SIZE == 4
-BETOH(Perl_my_betoh32,U32)
-# else
-NOT_AVAIL(Perl_my_betoh32,U32)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE64
-# if U64SIZE == 8
-HTOLE(Perl_my_htole64,U64)
-# else
-NOT_AVAIL(Perl_my_htole64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH64
-# if U64SIZE == 8
-LETOH(Perl_my_letoh64,U64)
-# else
-NOT_AVAIL(Perl_my_letoh64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE64
-# if U64SIZE == 8
-HTOBE(Perl_my_htobe64,U64)
-# else
-NOT_AVAIL(Perl_my_htobe64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH64
-# if U64SIZE == 8
-BETOH(Perl_my_betoh64,U64)
-# else
-NOT_AVAIL(Perl_my_betoh64,U64)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLES
-HTOLE(Perl_my_htoles,short)
-#endif
-#ifdef PERL_NEED_MY_LETOHS
-LETOH(Perl_my_letohs,short)
-#endif
-#ifdef PERL_NEED_MY_HTOBES
-HTOBE(Perl_my_htobes,short)
-#endif
-#ifdef PERL_NEED_MY_BETOHS
-BETOH(Perl_my_betohs,short)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLEI
-HTOLE(Perl_my_htolei,int)
-#endif
-#ifdef PERL_NEED_MY_LETOHI
-LETOH(Perl_my_letohi,int)
-#endif
-#ifdef PERL_NEED_MY_HTOBEI
-HTOBE(Perl_my_htobei,int)
-#endif
-#ifdef PERL_NEED_MY_BETOHI
-BETOH(Perl_my_betohi,int)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLEL
-HTOLE(Perl_my_htolel,long)
-#endif
-#ifdef PERL_NEED_MY_LETOHL
-LETOH(Perl_my_letohl,long)
-#endif
-#ifdef PERL_NEED_MY_HTOBEL
-HTOBE(Perl_my_htobel,long)
-#endif
-#ifdef PERL_NEED_MY_BETOHL
-BETOH(Perl_my_betohl,long)
-#endif
-
-void
-Perl_my_swabn(void *ptr, int n)
-{
- char *s = (char *)ptr;
- char *e = s + (n-1);
- char tc;
-
- PERL_ARGS_ASSERT_MY_SWABN;
-
- for (n /= 2; n > 0; s++, e--, n--) {
- tc = *s;
- *s = *e;
- *e = tc;
- }
-}
-
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
#endif /* HAS_FORK */
}
-#ifdef DUMP_FDS
-void
-Perl_dump_fds(pTHX_ const char *const s)
-{
- int fd;
- Stat_t tmpstatbuf;
-
- PERL_ARGS_ASSERT_DUMP_FDS;
-
- PerlIO_printf(Perl_debug_log,"%s", s);
- for (fd = 0; fd < 32; fd++) {
- if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
- PerlIO_printf(Perl_debug_log," %d",fd);
- }
- PerlIO_printf(Perl_debug_log,"\n");
- return;
-}
-#endif /* DUMP_FDS */
-
#ifndef HAS_DUP2
int
dup2(int oldfd, int newfd)
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
dVAR;
- Sigsave_t hstat, istat, qstat;
int status;
SV **svp;
Pid_t pid;
svp = av_fetch(PL_fdpid,fd,TRUE);
pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
SvREFCNT_dec(*svp);
- *svp = &PL_sv_undef;
+ *svp = NULL;
#ifdef OS2
if (pid == -1) { /* Opened by popen. */
return my_syspclose(ptr);
#endif
close_failed = (PerlIO_close(ptr) == EOF);
SAVE_ERRNO;
-#ifndef PERL_MICRO
- rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
- rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
- rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
-#endif
if (should_wait) do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
-#ifndef PERL_MICRO
- rsignal_restore(SIGHUP, &hstat);
- rsignal_restore(SIGINT, &istat);
- rsignal_restore(SIGQUIT, &qstat);
-#endif
if (close_failed) {
RESTORE_ERRNO;
return -1;
dVAR;
I32 result = 0;
PERL_ARGS_ASSERT_WAIT4PID;
- if (!pid)
- return -1;
#ifdef PERL_USES_PL_PIDSTATUS
+ if (!pid) {
+ /* PERL_USES_PL_PIDSTATUS is only defined when neither
+ waitpid() nor wait4() is available, or on OS/2, which
+ doesn't appear to support waiting for a progress group
+ member, so we can only treat a 0 pid as an unknown child.
+ */
+ errno = ECHILD;
+ return -1;
+ }
{
if (pid > 0) {
/* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
goto finish;
#endif
#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
- result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
+ result = wait4(pid,statusp,flags,NULL);
goto finish;
#endif
#ifdef PERL_USES_PL_PIDSTATUS
assert(len >= 0);
if (count < 0)
- Perl_croak_memory_wrap();
+ croak_memory_wrap();
if (len == 1)
memset(to, *from, count);
*
*/
-#ifdef HAS_GNULIBC
+#ifdef __GLIBC__
# ifndef STRUCT_TM_HASZONE
# define STRUCT_TM_HASZONE
# endif
{
#ifndef PERL_MICRO
dVAR;
-#ifndef INCOMPLETE_TAINTS
SvTAINTED_on(sv);
-#endif
PERL_ARGS_ASSERT_GETCWD_SV;
}
}
if ( qv ) { /* quoted versions always get at least three terms*/
- I32 len = av_len(av);
+ SSize_t len = av_len(av);
/* This for loop appears to trigger a compiler bug on OS X, as it
loops infinitely. Yes, len is negative. No, it makes no sense.
Compiler in question is:
if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
/* can just copy directly */
{
- I32 key;
+ SSize_t key;
AV * const av = newAV();
AV *sav;
/* This will get reblessed later if a derived class*/
SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
char *buf;
#ifdef USE_LOCALE_NUMERIC
- char *loc = savepv(setlocale(LC_NUMERIC, NULL));
- setlocale(LC_NUMERIC, "C");
+ char *loc = NULL;
+ if (! PL_numeric_standard) {
+ loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
+ }
#endif
if (sv) {
Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
buf = tbuf;
}
#ifdef USE_LOCALE_NUMERIC
- setlocale(LC_NUMERIC, loc);
- Safefree(loc);
+ if (loc) {
+ setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
+ }
#endif
while (buf[len-1] == '0' && len > 0) len--;
if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
SV *
Perl_vnumify(pTHX_ SV *vs)
{
- I32 i, len, digit;
+ SSize_t i, len;
+ I32 digit;
int width;
bool alpha = FALSE;
SV *sv;
int
Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
{
- I32 i,l,m,r,retval;
+ SSize_t i,l,m,r;
+ I32 retval;
bool lalpha = FALSE;
bool ralpha = FALSE;
I32 left = 0;
}
void
-Perl_get_hash_seed(pTHX_ unsigned char *seed_buffer)
+Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
{
dVAR;
- const char *s;
- const unsigned char * const end= seed_buffer + PERL_HASH_SEED_BYTES;
+ const char *env_pv;
+ unsigned long i;
PERL_ARGS_ASSERT_GET_HASH_SEED;
- s= PerlEnv_getenv("PERL_HASH_SEED");
+ env_pv= PerlEnv_getenv("PERL_HASH_SEED");
- if ( s )
+ if ( env_pv )
#ifndef USE_HASH_SEED_EXPLICIT
{
- while (isSPACE(*s))
- s++;
- if (s[0] == '0' && s[1] == 'x')
- s += 2;
-
- while (isXDIGIT(*s) && seed_buffer < end) {
- *seed_buffer = READ_XDIGIT(s) << 4;
- if (isXDIGIT(*s)) {
- *seed_buffer |= READ_XDIGIT(s);
+ /* ignore leading spaces */
+ while (isSPACE(*env_pv))
+ env_pv++;
+#ifdef USE_PERL_PERTURB_KEYS
+ /* if they set it to "0" we disable key traversal randomization completely */
+ if (strEQ(env_pv,"0")) {
+ PL_hash_rand_bits_enabled= 0;
+ } else {
+ /* otherwise switch to deterministic mode */
+ PL_hash_rand_bits_enabled= 2;
+ }
+#endif
+ /* ignore a leading 0x... if it is there */
+ if (env_pv[0] == '0' && env_pv[1] == 'x')
+ env_pv += 2;
+
+ for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
+ seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
+ if ( isXDIGIT(*env_pv)) {
+ seed_buffer[i] |= READ_XDIGIT(env_pv);
}
- seed_buffer++;
}
- while (isSPACE(*s))
- s++;
- if (*s && !isXDIGIT(*s)) {
+ while (isSPACE(*env_pv))
+ env_pv++;
+
+ if (*env_pv && !isXDIGIT(*env_pv)) {
Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
}
/* should we check for unparsed crap? */
+ /* should we warn about unused hex? */
+ /* should we warn about insufficient hex? */
}
else
#endif
{
- unsigned char *ptr= seed_buffer;
(void)seedDrand01((Rand_seed_t)seed());
- while (ptr < end) {
- *ptr++ = (unsigned char)(Drand01() * (U8_MAX+1));
+ for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
+ seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
}
}
+#ifdef USE_PERL_PERTURB_KEYS
{ /* initialize PL_hash_rand_bits from the hash seed.
* This value is highly volatile, it is updated every
* hash insert, and is used as part of hash bucket chain
* randomization and hash iterator randomization. */
- unsigned long i;
- PL_hash_rand_bits= 0;
+ PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
for( i = 0; i < sizeof(UV) ; i++ ) {
- PL_hash_rand_bits = (PL_hash_rand_bits << 8) | seed_buffer[i % PERL_HASH_SEED_BYTES];
+ PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
+ PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
+ }
+ }
+ env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
+ if (env_pv) {
+ if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
+ PL_hash_rand_bits_enabled= 0;
+ } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
+ PL_hash_rand_bits_enabled= 1;
+ } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
+ PL_hash_rand_bits_enabled= 2;
+ } else {
+ Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
}
}
+#endif
}
#ifdef PERL_GLOBAL_STRUCT
# ifdef PERL_SET_VARS
PERL_SET_VARS(plvarsp);
# endif
+# ifdef PERL_GLOBAL_STRUCT_PRIVATE
+ plvarsp->Gsv_placeholder.sv_flags = 0;
+ memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
+# endif
# undef PERL_GLOBAL_STRUCT_INIT
# endif
return plvarsp;
(void)clearenv();
# elif defined(HAS_UNSETENV)
int bsiz = 80; /* Most envvar names will be shorter than this. */
- int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
- char *buf = (char*)safesysmalloc(bufsiz);
+ char *buf = (char*)safesysmalloc(bsiz);
while (*environ != NULL) {
char *e = strchr(*environ, '=');
int l = e ? e - *environ : (int)strlen(*environ);
if (bsiz < l + 1) {
(void)safesysfree(buf);
bsiz = l + 1; /* + 1 for the \0. */
- bufsiz = bsiz * sizeof(char); /* keep bsiz and bufsiz in sync */
- buf = (char*)safesysmalloc(bufsiz);
+ buf = (char*)safesysmalloc(bsiz);
}
memcpy(buf, *environ, l);
buf[l] = '\0';
Perl_croak_sv(aTHX_ xpt);
}
+/*
+=for apidoc my_strlcat
+
+The C library C<strlcat> if available, or a Perl implementation of it.
+This operates on C NUL-terminated strings.
+
+C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
+most S<C<size - strlen(dst) - 1>> characters. It will then NUL-terminate,
+unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
+practice this should not happen as it means that either C<size> is incorrect or
+that C<dst> is not a proper NUL-terminated string).
+
+Note that C<size> is the full size of the destination buffer and
+the result is guaranteed to be NUL-terminated if there is room. Note that room
+for the NUL should be included in C<size>.
+
+=cut
+
+Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
+*/
#ifndef HAS_STRLCAT
Size_t
Perl_my_strlcat(char *dst, const char *src, Size_t size)
}
#endif
+
+/*
+=for apidoc my_strlcpy
+
+The C library C<strlcpy> if available, or a Perl implementation of it.
+This operates on C NUL-terminated strings.
+
+C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
+to C<dst>, NUL-terminating the result if C<size> is not 0.
+
+=cut
+
+Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
+*/
#ifndef HAS_STRLCPY
Size_t
Perl_my_strlcpy(char *dst, const char *src, Size_t size)
{
dVAR;
SV * const dbsv = GvSVn(PL_DBsub);
- const bool save_taint = TAINT_get; /* Accepted unused var warning under NO_TAINT_SUPPORT */
+ const bool save_taint = TAINT_get;
/* When we are called from pp_goto (svp is null),
* we do not care about using dbsv to call CV;
SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
}
TAINT_IF(save_taint);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(save_taint);
+#endif
}
int
}
/*
+ * This code is derived from drand48() implementation from FreeBSD,
+ * found in lib/libc/gen/_rand48.c.
+ *
+ * The U64 implementation is original, based on the POSIX
+ * specification for drand48().
+ */
+
+/*
+* Copyright (c) 1993 Martin Birgmeier
+* All rights reserved.
+*
+* You may redistribute unmodified or modified versions of this source
+* code provided that the above copyright notice and this and the
+* following conditions are retained.
+*
+* This software is provided ``as is'', and comes with no warranties
+* of any kind. I shall in no event be liable for anything that happens
+* to anyone/anything when using this software.
+*/
+
+#define FREEBSD_DRAND48_SEED_0 (0x330e)
+
+#ifdef PERL_DRAND48_QUAD
+
+#define DRAND48_MULT U64_CONST(0x5deece66d)
+#define DRAND48_ADD 0xb
+#define DRAND48_MASK U64_CONST(0xffffffffffff)
+
+#else
+
+#define FREEBSD_DRAND48_SEED_1 (0xabcd)
+#define FREEBSD_DRAND48_SEED_2 (0x1234)
+#define FREEBSD_DRAND48_MULT_0 (0xe66d)
+#define FREEBSD_DRAND48_MULT_1 (0xdeec)
+#define FREEBSD_DRAND48_MULT_2 (0x0005)
+#define FREEBSD_DRAND48_ADD (0x000b)
+
+const unsigned short _rand48_mult[3] = {
+ FREEBSD_DRAND48_MULT_0,
+ FREEBSD_DRAND48_MULT_1,
+ FREEBSD_DRAND48_MULT_2
+};
+const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
+
+#endif
+
+void
+Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
+{
+ PERL_ARGS_ASSERT_DRAND48_INIT_R;
+
+#ifdef PERL_DRAND48_QUAD
+ *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
+#else
+ random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
+ random_state->seed[1] = (U16) seed;
+ random_state->seed[2] = (U16) (seed >> 16);
+#endif
+}
+
+double
+Perl_drand48_r(perl_drand48_t *random_state)
+{
+ PERL_ARGS_ASSERT_DRAND48_R;
+
+#ifdef PERL_DRAND48_QUAD
+ *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
+ & DRAND48_MASK;
+
+ return ldexp(*random_state, -48);
+#else
+ {
+ U32 accu;
+ U16 temp[2];
+
+ accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
+ + (U32) _rand48_add;
+ temp[0] = (U16) accu; /* lower 16 bits */
+ accu >>= sizeof(U16) * 8;
+ accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
+ + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
+ temp[1] = (U16) accu; /* middle 16 bits */
+ accu >>= sizeof(U16) * 8;
+ accu += _rand48_mult[0] * random_state->seed[2]
+ + _rand48_mult[1] * random_state->seed[1]
+ + _rand48_mult[2] * random_state->seed[0];
+ random_state->seed[0] = temp[0];
+ random_state->seed[1] = temp[1];
+ random_state->seed[2] = (U16) accu;
+
+ return ldexp((double) random_state->seed[0], -48) +
+ ldexp((double) random_state->seed[1], -32) +
+ ldexp((double) random_state->seed[2], -16);
+ }
+#endif
+}
+
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
https://perl5.git.perl.org / perl5.git / blobdiff