#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
+ Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
#endif
if (!size) size = 1; /* malloc(0) is NASTY on our system */
#ifdef PERL_DEBUG_READONLY_COW
header->size = size;
#endif
ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
}
else {
? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
: 0;
#endif
-#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
- Malloc_t PerlMem_realloc();
-#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
if (!size) {
safesysfree(where);
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
+ Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
#endif
#ifdef PERL_DEBUG_READONLY_COW
if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
/* In particular, must do that fixup above before logging anything via
*printf(), as it can reallocate memory, which can cause SEGVs. */
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (ptr == NULL) {
#ifdef USE_MDH
#ifdef ALWAYS_NEED_THX
dTHX;
#endif
- DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
+ DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#ifdef USE_MDH
Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0 || (SSize_t)count < 0)
- Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+ Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
(UV)size, (UV)count);
#endif
#ifdef PERL_DEBUG_READONLY_COW
ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
#endif
PERL_ALLOC_CHECK(ptr);
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
if (ptr != NULL) {
#ifdef USE_MDH
{
return (char*)big;
{
const char first = *little;
- const char *s, *x;
bigend -= lend - little++;
OUTER:
while (big <= bigend) {
if (*big++ == first) {
+ const char *s, *x;
for (x=big,s=little; s < lend; x++,s++) {
if (*s != *x)
goto OUTER;
SvUPGRADE(sv, SVt_PVMG);
SvIOK_off(sv);
SvNOK_off(sv);
- SvVALID_on(sv);
- /* "deep magic", the comment used to add. The use of MAGIC itself isn't
- really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
- to call SvVALID_off() if the scalar was assigned to.
-
- The comment itself (and "deeper magic" below) date back to
- 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
- str->str_pok |= 2;
- where the magic (presumably) was that the scalar had a BM table hidden
- inside itself.
-
- As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
- the table instead of the previous (somewhat hacky) approach of co-opting
- the string buffer and storing it after the string. */
+ /* add PERL_MAGIC_bm magic holding the FBM lookup table */
assert(!mg_find(sv, PERL_MAGIC_bm));
mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
}
}
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",
+ ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %" UVuf "\n",
s[rarest], (UV)rarest));
}
const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
STRLEN littlelen = l;
const I32 multiline = flags & FBMrf_MULTILINE;
- bool tail = SvVALID(littlestr) ? cBOOL(SvTAIL(littlestr)) : FALSE;
+ bool valid = SvVALID(littlestr);
+ bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;
PERL_ARGS_ASSERT_FBM_INSTR;
+ assert(bigend >= big);
+
if ((STRLEN)(bigend - big) < littlelen) {
if ( tail
&& ((STRLEN)(bigend - big) == littlelen - 1)
return NULL;
}
- if (!SvVALID(littlestr)) {
+ if (!valid) {
/* not compiled; use Perl_ninstr() instead */
char * const b = ninstr((char*)big,(char*)bigend,
(char*)little, (char*)little + littlelen);
- if (!b && tail) { /* Automatically multiline! */
- /* Chop \n from littlestr: */
- s = bigend - littlelen + 1;
- if (*s == *little
- && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
- {
- return (char*)s;
- }
- return NULL;
- }
+ assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
return b;
}
}
}
-
-/*
-=for apidoc foldEQ
-
-Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
-same
-case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
-match themselves and their opposite case counterparts. Non-cased and non-ASCII
-range bytes match only themselves.
-
-=cut
-*/
-
-
-I32
-Perl_foldEQ(const char *s1, const char *s2, I32 len)
-{
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
-
- PERL_ARGS_ASSERT_FOLDEQ;
-
- assert(len >= 0);
-
- while (len--) {
- if (*a != *b && *a != PL_fold[*b])
- return 0;
- a++,b++;
- }
- return 1;
-}
-I32
-Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
-{
- /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
- * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
- * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
- * does it check that the strings each have at least 'len' characters */
-
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
-
- PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
-
- assert(len >= 0);
-
- while (len--) {
- if (*a != *b && *a != PL_fold_latin1[*b]) {
- return 0;
- }
- a++, b++;
- }
- return 1;
-}
-
-/*
-=for apidoc foldEQ_locale
-
-Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
-same case-insensitively in the current locale; false otherwise.
-
-=cut
-*/
-
-I32
-Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
-{
- dVAR;
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
-
- PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
-
- assert(len >= 0);
-
- while (len--) {
- if (*a != *b && *a != PL_fold_locale[*b])
- return 0;
- a++,b++;
- }
- return 1;
-}
-
/* copy a string to a safe spot */
/*
* from the sibling of PL_curcop.
*/
- const COP *cop =
- closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
- if (!cop)
- cop = PL_curcop;
+ if (PL_curcop) {
+ const COP *cop =
+ closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
+ if (!cop)
+ cop = PL_curcop;
+
+ if (CopLINE(cop))
+ Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
+ OutCopFILE(cop), (IV)CopLINE(cop));
+ }
- if (CopLINE(cop))
- Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
- OutCopFILE(cop), (IV)CopLINE(cop));
/* Seems that GvIO() can be untrustworthy during global destruction. */
if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
&& IoLINES(GvIOp(PL_last_in_gv)))
STRLEN l;
const bool line_mode = (RsSIMPLE(PL_rs) &&
*SvPV_const(PL_rs,l) == '\n' && l == 1);
- Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
+ Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
SVfARG(PL_last_in_gv == PL_argvgv
? &PL_sv_no
: sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
# else /* ! HAS_UNSETENV */
(void)setenv(nam, val, 1);
# endif /* HAS_UNSETENV */
-# else
-# if defined(HAS_UNSETENV)
+# elif defined(HAS_UNSETENV)
if (val == NULL) {
if (environ) /* old glibc can crash with null environ */
(void)unsetenv(nam);
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
}
-# else /* ! HAS_UNSETENV */
+# else /* ! HAS_UNSETENV */
char *new_env;
const int nlen = strlen(nam);
int vlen;
/* all that work just for this */
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
-# endif /* HAS_UNSETENV */
# endif /* __CYGWIN__ */
#ifndef PERL_USE_SAFE_PUTENV
}
}
#endif
-/* this is a drop-in replacement for bcopy(), except for the return
- * value, which we need to be able to emulate memcpy() */
-#if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY))
-void *
-Perl_my_bcopy(const void *vfrom, void *vto, size_t len)
-{
-#if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
- bcopy(vfrom, vto, len);
-#else
- const unsigned char *from = (const unsigned char *)vfrom;
- unsigned char *to = (unsigned char *)vto;
-
- PERL_ARGS_ASSERT_MY_BCOPY;
-
- if (from - to >= 0) {
- while (len--)
- *to++ = *from++;
- }
- else {
- to += len;
- from += len;
- while (len--)
- *(--to) = *(--from);
- }
-#endif
-
- return vto;
-}
-#endif
-
-/* this is a drop-in replacement for memset() */
-#ifndef HAS_MEMSET
-void *
-Perl_my_memset(void *vloc, int ch, size_t len)
-{
- unsigned char *loc = (unsigned char *)vloc;
-
- PERL_ARGS_ASSERT_MY_MEMSET;
-
- while (len--)
- *loc++ = ch;
- return vloc;
-}
-#endif
-
-/* this is a drop-in replacement for bzero() */
-#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
-void *
-Perl_my_bzero(void *vloc, size_t len)
-{
- unsigned char *loc = (unsigned char *)vloc;
-
- PERL_ARGS_ASSERT_MY_BZERO;
-
- while (len--)
- *loc++ = 0;
- return vloc;
-}
-#endif
-
-/* this is a drop-in replacement for memcmp() */
-#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
-int
-Perl_my_memcmp(const void *vs1, const void *vs2, size_t len)
-{
- const U8 *a = (const U8 *)vs1;
- const U8 *b = (const U8 *)vs2;
- int tmp;
-
- PERL_ARGS_ASSERT_MY_MEMCMP;
-
- while (len--) {
- if ((tmp = *a++ - *b++))
- return tmp;
- }
- return 0;
-}
-#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
-
-#ifndef HAS_VPRINTF
-/* This vsprintf replacement should generally never get used, since
- vsprintf was available in both System V and BSD 2.11. (There may
- be some cross-compilation or embedded set-ups where it is needed,
- however.)
-
- If you encounter a problem in this function, it's probably a symptom
- that Configure failed to detect your system's vprintf() function.
- See the section on "item vsprintf" in the INSTALL file.
-
- This version may compile on systems with BSD-ish <stdio.h>,
- but probably won't on others.
-*/
-
-#ifdef USE_CHAR_VSPRINTF
-char *
-#else
-int
-#endif
-vsprintf(char *dest, const char *pat, void *args)
-{
- FILE fakebuf;
-
-#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
- FILE_ptr(&fakebuf) = (STDCHAR *) dest;
- FILE_cnt(&fakebuf) = 32767;
-#else
- /* These probably won't compile -- If you really need
- this, you'll have to figure out some other method. */
- fakebuf._ptr = dest;
- fakebuf._cnt = 32767;
-#endif
-#ifndef _IOSTRG
-#define _IOSTRG 0
-#endif
- fakebuf._flag = _IOWRT|_IOSTRG;
- _doprnt(pat, args, &fakebuf); /* what a kludge */
-#if defined(STDIO_PTR_LVALUE)
- *(FILE_ptr(&fakebuf)++) = '\0';
-#else
- /* PerlIO has probably #defined away fputc, but we want it here. */
-# ifdef fputc
-# undef fputc /* XXX Should really restore it later */
-# endif
- (void)fputc('\0', &fakebuf);
-#endif
-#ifdef USE_CHAR_VSPRINTF
- return(dest);
-#else
- return 0; /* perl doesn't use return value */
-#endif
-}
-
-#endif /* HAS_VPRINTF */
-
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
if (did_pipes && pid > 0) {
int errkid;
unsigned n = 0;
- SSize_t n1;
while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
+ const SSize_t n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
if (did_pipes && pid > 0) {
int errkid;
unsigned n = 0;
- SSize_t n1;
while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
+ const SSize_t n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
PerlLIO_close(pp[0]);
return PerlIO_fdopen(p[This], mode);
}
-#else
-#if defined(DJGPP)
+#elif defined(DJGPP)
FILE *djgpp_popen();
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
*/
return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
}
-#else
-#if defined(__LIBCATAMOUNT__)
+#elif defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
return NULL;
}
-#endif
-#endif
#endif /* !DOSISH */
: 0
);
}
-#else
-#if defined(__LIBCATAMOUNT__)
+#elif defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
return -1;
}
-#endif
#endif /* !DOSISH */
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
if (len < sizeof tmpbuf)
tmpbuf[len] = '\0';
# else
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
- ':',
- &len);
+ s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
+ ':', &len);
# endif
if (s < bufend)
s++;
if (error)
Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
return (void*)t;
-# else
-# ifdef I_MACH_CTHREADS
+# elif defined(I_MACH_CTHREADS)
return (void*)cthread_data(cthread_self());
-# else
+# else
return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
-# endif
# endif
#else
return (void*)NULL;
long open_max = -1;
# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
-# else
-# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
+# elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
open_max = sysconf(_SC_OPEN_MAX);
-# else
-# ifdef FOPEN_MAX
+# elif defined(FOPEN_MAX)
open_max = FOPEN_MAX;
-# else
-# ifdef OPEN_MAX
+# elif defined(OPEN_MAX)
open_max = OPEN_MAX;
-# else
-# ifdef _NFILE
+# elif defined(_NFILE)
open_max = _NFILE;
-# endif
-# endif
-# endif
-# endif
-# endif
+# endif
if (open_max > 0) {
long i;
for (i = 0; i < open_max; i++)
if (name && HEK_LEN(name))
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %"HEKf" opened only for %sput",
+ "Filehandle %" HEKf " opened only for %sput",
HEKfARG(name), direction);
else
Perl_warner(aTHX_ packWARN(WARN_IO),
? "socket" : "filehandle");
const bool have_name = name && SvCUR(name);
Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s%s%"SVf, func, pars, vile, type,
+ "%s%s on %s %s%s%" SVf, func, pars, vile, type,
have_name ? " " : "",
SVfARG(have_name ? name : &PL_sv_no));
if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
Perl_warner(
aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
+ "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
func, pars, have_name ? " " : "",
SVfARG(have_name ? name : &PL_sv_no)
);
* This algorithm also fails to handle years before A.D. 1 gracefully, but
* that's still outside the scope for POSIX time manipulation, so I don't
* care.
+ *
+ * - lwall
*/
year = 1900 + ptm->tm_year;
{
#ifdef HAS_STRFTIME
- /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */
+ /* strftime(), but with a different API so that the return value is a pointer
+ * to the formatted result (which MUST be arranged to be FREED BY THE
+ * CALLER). This allows this function to increase the buffer size as needed,
+ * so that the caller doesn't have to worry about that.
+ *
+ * Note that yday and wday effectively are ignored by this function, as
+ * mini_mktime() overwrites them */
char *buf;
int buflen;
#define SV_CWD_RETURN_UNDEF \
-sv_setsv(sv, &PL_sv_undef); \
-return FALSE
+ sv_set_undef(sv); \
+ return FALSE
#define SV_CWD_ISDOT(dp) \
(dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
return TRUE;
}
else {
- sv_setsv(sv, &PL_sv_undef);
- return FALSE;
+ SV_CWD_RETURN_UNDEF;
}
}
abort_tidy_up_and_fail:
#ifdef ECONNABORTED
errno = ECONNABORTED; /* This would be the standard thing to do. */
-#else
-# ifdef ECONNREFUSED
+#elif defined(ECONNREFUSED)
errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
-# else
+#else
errno = ETIMEDOUT; /* Desperation time. */
-# endif
#endif
tidy_up_and_fail:
{
the_end_of_the_opts_parser:
if (opt & ~PERL_UNICODE_ALL_FLAGS)
- Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
+ Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
(UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
*popt = p;
void
Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
{
+#ifndef NO_PERL_HASH_ENV
const char *env_pv;
+#endif
unsigned long i;
PERL_ARGS_ASSERT_GET_HASH_SEED;
+#ifndef NO_PERL_HASH_ENV
env_pv= PerlEnv_getenv("PERL_HASH_SEED");
if ( env_pv )
-#ifndef USE_HASH_SEED_EXPLICIT
{
/* ignore leading spaces */
while (isSPACE(*env_pv))
env_pv++;
-#ifdef USE_PERL_PERTURB_KEYS
+# 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;
/* otherwise switch to deterministic mode */
PL_hash_rand_bits_enabled= 2;
}
-#endif
+# endif
/* ignore a leading 0x... if it is there */
if (env_pv[0] == '0' && env_pv[1] == 'x')
env_pv += 2;
/* should we warn about insufficient hex? */
}
else
-#endif
+#endif /* NO_PERL_HASH_ENV */
{
- (void)seedDrand01((Rand_seed_t)seed());
-
for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
- seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
+ seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1));
}
}
#ifdef USE_PERL_PERTURB_KEYS
PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
}
}
+# ifndef NO_PERL_HASH_ENV
env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
if (env_pv) {
if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
}
}
+# endif
#endif
}
switch (mlt) {
case MLT_ALLOC:
len = my_snprintf(buf, sizeof(buf),
- "alloc: %s:%d:%s: %"IVdf" %"UVuf
- " %s = %"IVdf": %"UVxf"\n",
+ "alloc: %s:%d:%s: %" IVdf " %" UVuf
+ " %s = %" IVdf ": %" UVxf "\n",
filename, linenumber, funcname, n, typesize,
type_name, n * typesize, PTR2UV(newalloc));
break;
case MLT_REALLOC:
len = my_snprintf(buf, sizeof(buf),
- "realloc: %s:%d:%s: %"IVdf" %"UVuf
- " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+ "realloc: %s:%d:%s: %" IVdf " %" UVuf
+ " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
filename, linenumber, funcname, n, typesize,
type_name, n * typesize, PTR2UV(oldalloc),
PTR2UV(newalloc));
break;
case MLT_FREE:
len = my_snprintf(buf, sizeof(buf),
- "free: %s:%d:%s: %"UVxf"\n",
+ "free: %s:%d:%s: %" UVxf "\n",
filename, linenumber, funcname,
PTR2UV(oldalloc));
break;
case MLT_NEW_SV:
case MLT_DEL_SV:
len = my_snprintf(buf, sizeof(buf),
- "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
+ "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
mlt == MLT_NEW_SV ? "new" : "del",
filename, linenumber, funcname,
PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
#endif /* PERL_MEM_LOG */
/*
-=for apidoc my_sprintf
-
-The C library C<sprintf>, wrapped if necessary, to ensure that it will return
-the length of the string written to the buffer. Only rare pre-ANSI systems
-need the wrapper function - usually this is a direct call to C<sprintf>.
-
-=cut
-*/
-#ifndef SPRINTF_RETURNS_STRLEN
-int
-Perl_my_sprintf(char *buffer, const char* pat, ...)
-{
- va_list args;
- PERL_ARGS_ASSERT_MY_SPRINTF;
- va_start(args, pat);
- vsprintf(buffer, pat, args);
- va_end(args);
- return strlen(buffer);
-}
-#endif
-
-/*
=for apidoc quadmath_format_single
C<quadmath_snprintf()> is very strict about its C<format> string and will
/*
=for apidoc my_snprintf
-The C library C<snprintf> functionality, if available and
-standards-compliant (uses C<vsnprintf>, actually). However, if the
-C<vsnprintf> is not available, will unfortunately use the unsafe
-C<vsprintf> which can overrun the buffer (there is an overrun check,
-but that may be too late). Consider using C<sv_vcatpvf> instead, or
-getting C<vsnprintf>.
+The C library C<snprintf> functionality (using C<vsnprintf>).
+Consider using C<sv_vcatpvf> instead.
=cut
*/
int retval = -1;
va_list ap;
PERL_ARGS_ASSERT_MY_SNPRINTF;
-#ifndef HAS_VSNPRINTF
- PERL_UNUSED_VAR(len);
-#endif
va_start(ap, format);
#ifdef USE_QUADMATH
{
if (qfmt) {
/* If the format looked promising, use it as quadmath. */
retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
- if (retval == -1)
+ if (retval == -1) {
+ if (qfmt != format) {
+ dTHX;
+ SAVEFREEPV(qfmt);
+ }
Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ }
quadmath_valid = TRUE;
if (qfmt != format)
Safefree(qfmt);
* Handling the "Q-less" cases right would require walking
* through the va_list and rewriting the format, calling
* quadmath for the NVs, building a new va_list, and then
- * letting vsnprintf/vsprintf to take care of the other
+ * letting vsnprintf to take care of the other
* arguments. This may be doable.
*
* We do not attempt that now. But for paranoia, we here try
* to detect some common (but not all) cases where the
* "Q-less" %[efgaEFGA] formats are present, and die if
* detected. This doesn't fix the problem, but it stops the
- * vsnprintf/vsprintf pulling doubles off the va_list when
+ * vsnprintf pulling doubles off the va_list when
* __float128 NVs should be pulled off instead.
*
* If quadmath_format_needed() returns false, we are reasonably
}
#endif
if (retval == -1)
-#ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
-#else
- retval = vsprintf(buffer, format, ap);
-#endif
va_end(ap);
- /* vsprintf() shows failure with < 0 */
- if (retval < 0
-#ifdef HAS_VSNPRINTF
/* vsnprintf() shows failure with >= len */
- ||
- (len > 0 && (Size_t)retval >= len)
-#endif
- )
+ if (len > 0 && (Size_t)retval >= len)
Perl_croak_nocontext("panic: my_snprintf buffer overflow");
return retval;
}
/*
=for apidoc my_vsnprintf
-The C library C<vsnprintf> if available and standards-compliant.
-However, if if the C<vsnprintf> is not available, will unfortunately
-use the unsafe C<vsprintf> which can overrun the buffer (there is an
-overrun check, but that may be too late). Consider using
-C<sv_vcatpvf> instead, or getting C<vsnprintf>.
+The C library C<vsnprintf>. Consider using C<sv_vcatpvf> instead.
=cut
*/
PERL_ARGS_ASSERT_MY_VSNPRINTF;
Perl_va_copy(ap, apc);
-# ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, apc);
-# else
- PERL_UNUSED_ARG(len);
- retval = vsprintf(buffer, format, apc);
-# endif
va_end(apc);
#else
-# ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
-# else
- PERL_UNUSED_ARG(len);
- retval = vsprintf(buffer, format, ap);
-# endif
#endif /* #ifdef NEED_VA_COPY */
- /* vsprintf() shows failure with < 0 */
- if (retval < 0
-#ifdef HAS_VSNPRINTF
/* vsnprintf() shows failure with >= len */
- ||
- (len > 0 && (Size_t)retval >= len)
-#endif
- )
+ if (len > 0 && (Size_t)retval >= len)
Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
return retval;
#endif
PERL_ARGS_ASSERT_MY_CXT_INIT;
if (*index == -1) {
/* this module hasn't been allocated an index yet */
-#if defined(USE_ITHREADS)
MUTEX_LOCK(&PL_my_ctx_mutex);
-#endif
*index = PL_my_cxt_index++;
-#if defined(USE_ITHREADS)
MUTEX_UNLOCK(&PL_my_ctx_mutex);
-#endif
}
/* make sure the array is big enough */
if (PL_my_cxt_size <= *index) {
if (PL_my_cxt_size) {
- while (PL_my_cxt_size <= *index)
- PL_my_cxt_size *= 2;
- Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+ IV new_size = PL_my_cxt_size;
+ while (new_size <= *index)
+ new_size *= 2;
+ Renew(PL_my_cxt_list, new_size, void *);
+ PL_my_cxt_size = new_size;
}
else {
PL_my_cxt_size = 16;
index = Perl_my_cxt_index(aTHX_ my_cxt_key);
if (index == -1) {
/* this module hasn't been allocated an index yet */
-#if defined(USE_ITHREADS)
MUTEX_LOCK(&PL_my_ctx_mutex);
-#endif
index = PL_my_cxt_index++;
-#if defined(USE_ITHREADS)
MUTEX_UNLOCK(&PL_my_ctx_mutex);
-#endif
}
/* make sure the array is big enough */
int old_size = PL_my_cxt_size;
int i;
if (PL_my_cxt_size) {
- while (PL_my_cxt_size <= index)
- PL_my_cxt_size *= 2;
- Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
- Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+ IV new_size = PL_my_cxt_size;
+ while (new_size <= index)
+ new_size *= 2;
+ Renew(PL_my_cxt_list, new_size, void *);
+ Renew(PL_my_cxt_keys, new_size, const char *);
+ PL_my_cxt_size = new_size;
}
else {
PL_my_cxt_size = 16;
if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
|| memNE(api_p, "v" PERL_API_VERSION_STRING,
sizeof("v" PERL_API_VERSION_STRING)-1))
- Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s",
+ Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s",
api_p, SVfARG(PL_stack_base[ax + 0]),
"v" PERL_API_VERSION_STRING);
}
else {
/* XXX GV_ADDWARN */
vn = "XS_VERSION";
- sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
+ sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
if (!sv || !SvOK(sv)) {
vn = "VERSION";
- sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
+ sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
}
}
if (sv) {
xssv = upg_version(xssv, 0);
if ( vcmp(pmsv,xssv) ) {
SV *string = vstringify(xssv);
- SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+ SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf
" does not match ", SVfARG(module), SVfARG(string));
SvREFCNT_dec(string);
string = vstringify(pmsv);
if (vn) {
- Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, SVfARG(module), vn,
+ Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,
SVfARG(string));
} else {
- Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, SVfARG(string));
+ Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));
}
SvREFCNT_dec(string);
}
#endif
+/*
+=for apidoc my_strnlen
+
+The C library C<strnlen> if available, or a Perl implementation of it.
+
+C<my_strnlen()> computes the length of the string, up to C<maxlen>
+characters. It will will never attempt to address more than C<maxlen>
+characters, making it suitable for use with strings that are not
+guaranteed to be NUL-terminated.
+
+=cut
+
+Description stolen from http://man.openbsd.org/strnlen.3,
+implementation stolen from PostgreSQL.
+*/
+#ifndef HAS_STRNLEN
+Size_t
+Perl_my_strnlen(const char *str, Size_t maxlen)
+{
+ const char *p = str;
+
+ PERL_ARGS_ASSERT_MY_STRNLEN;
+
+ while(maxlen-- && *p)
+ p++;
+
+ return p - str;
+}
+#endif
+
#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
/* VC7 or 7.1, building with pre-VC7 runtime libraries. */
long _ftol( double ); /* Defined by VC6 C libs. */
#endif
}
+#ifndef HAS_MKSTEMP
+
+#define TEMP_FILE_CH "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz0123456789"
+#define TEMP_FILE_CH_COUNT (sizeof(TEMP_FILE_CH)-1)
+
+int
+Perl_my_mkstemp(char *templte) {
+ dTHX;
+ STRLEN len = strlen(templte);
+ int fd;
+ int attempts = 0;
+
+ PERL_ARGS_ASSERT_MY_MKSTEMP;
+
+ if (len < 6 ||
+ templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
+ templte[len-4] != 'X' || templte[len-5] != 'X' || templte[len-6] != 'X') {
+ errno = EINVAL;
+ return -1;
+ }
+
+ do {
+ int i;
+ for (i = 1; i <= 6; ++i) {
+ templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)];
+ }
+ fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL, 0600);
+ } while (fd == -1 && errno == EEXIST && ++attempts <= 100);
+
+ return fd;
+}
+
+#endif
+
REGEXP *
Perl_get_re_arg(pTHX_ SV *sv) {
UV uv;
/* Skip trailing whitespace. */
- while (p > start && isspace(*p)) p--;
+ while (p > start && isSPACE(*p)) p--;
/* Now we should be at the close paren. */
if (p == start || *p != ')')
return NULL;
close_paren = p;
p--;
/* Now we should be in the line number. */
- if (p == start || !isdigit(*p))
+ if (p == start || !isDIGIT(*p))
return NULL;
/* Skip over the digits. */
- while (p > start && isdigit(*p))
+ while (p > start && isDIGIT(*p))
p--;
/* Now we should be at the colon. */
if (p == start || *p != ':')
* the object name (used as "-o '%s'" ), leave since at least
* partially the user controls it. */
for (p = ctx->fname; *p; p++) {
- if (*p == '\'' || iscntrl(*p)) {
+ if (*p == '\'' || isCNTRL(*p)) {
ctx->unavail = TRUE;
return;
}
if (frame->source_name_size &&
frame->source_name_offset &&
frame->source_line_number) {
- Perl_sv_catpvf(aTHX_ dsv, "\t%s:%"UVuf,
+ Perl_sv_catpvf(aTHX_ dsv, "\t%s:%" UVuf,
(char*)bt + frame->source_name_offset,
(UV)frame->source_line_number);
} else {
sv_catpvs(dsv, "\n");
}
- Perl_free_c_backtrace(aTHX_ bt);
+ Perl_free_c_backtrace(bt);
return dsv;
}
https://perl5.git.perl.org / perl5.git / blobdiff