/* util.c
*
- * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
*/
/*
- * "Very useful, no doubt, that was to Saruman; yet it seems that he was
- * not content." --Gandalf
+ * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
+ * not content.' --Gandalf to Pippin
+ *
+ * [p.598 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
*/
/* This file contains assorted utility routines.
NORETURN_FUNCTION_END;
}
+#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+# define ALWAYS_NEED_THX
+#endif
+
/* paranoid version of system's malloc() */
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- if (ptr != Nullch) {
+ if (ptr != NULL) {
+#ifdef PERL_TRACK_MEMPOOL
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+#endif
+
+#ifdef PERL_POISON
+ PoisonNew(((char *)ptr), size, char);
+#endif
+
#ifdef PERL_TRACK_MEMPOOL
- ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+ header->interpreter = aTHX;
+ /* Link us into the list. */
+ header->prev = &PL_memory_debug_header;
+ header->next = PL_memory_debug_header.next;
+ PL_memory_debug_header.next = header;
+ header->next->prev = header;
# ifdef PERL_POISON
- ((struct perl_memory_debug_header *)ptr)->size = size;
- ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+ header->size = size;
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
return ptr;
}
- else if (PL_nomemok)
- return Nullch;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Malloc_t
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
Malloc_t PerlMem_realloc();
#ifdef PERL_TRACK_MEMPOOL
where = (Malloc_t)((char*)where-sTHX);
size += sTHX;
- if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool");
- }
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
+
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: realloc from wrong pool");
+ }
+ assert(header->next->prev == header);
+ assert(header->prev->next == header);
# ifdef PERL_POISON
- if (((struct perl_memory_debug_header *)where)->size > size) {
- const MEM_SIZE freed_up =
- ((struct perl_memory_debug_header *)where)->size - size;
- char *start_of_freed = ((char *)where) + size;
- Poison(start_of_freed, freed_up, char);
- }
- ((struct perl_memory_debug_header *)where)->size = size;
+ if (header->size > size) {
+ const MEM_SIZE freed_up = header->size - size;
+ char *start_of_freed = ((char *)where) + size;
+ PoisonFree(start_of_freed, freed_up, char);
+ }
+ header->size = size;
# endif
+ }
#endif
#ifdef DEBUGGING
if ((long)size < 0)
ptr = (Malloc_t)PerlMem_realloc(where,size);
PERL_ALLOC_CHECK(ptr);
- 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 != Nullch) {
+ /* MUST do this fixup first, before doing ANYTHING else, as anything else
+ might allocate memory/free/move memory, and until we do the fixup, it
+ may well be chasing (and writing to) free memory. */
#ifdef PERL_TRACK_MEMPOOL
+ if (ptr != NULL) {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+
+# ifdef PERL_POISON
+ if (header->size < size) {
+ const MEM_SIZE fresh = size - header->size;
+ char *start_of_fresh = ((char *)ptr) + size;
+ PoisonNew(start_of_fresh, fresh, char);
+ }
+# endif
+
+ header->next->prev = header;
+ header->prev->next = header;
+
ptr = (Malloc_t)((char*)ptr+sTHX);
+ }
#endif
+
+ /* 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));
+
+
+ if (ptr != NULL) {
return ptr;
}
- else if (PL_nomemok)
- return Nullch;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Free_t
Perl_safesysfree(Malloc_t where)
{
-#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
+#ifdef ALWAYS_NEED_THX
dTHX;
#else
dVAR;
if (where) {
#ifdef PERL_TRACK_MEMPOOL
where = (Malloc_t)((char*)where-sTHX);
- if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
- Perl_croak_nocontext("panic: free from wrong pool");
- }
-# ifdef PERL_POISON
{
- if (((struct perl_memory_debug_header *)where)->in_use
- == PERL_POISON_FREE) {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
+
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: free from wrong pool");
+ }
+ if (!header->prev) {
Perl_croak_nocontext("panic: duplicate free");
}
- if (((struct perl_memory_debug_header *)where)->in_use
- != PERL_POISON_INUSE) {
- Perl_croak_nocontext("panic: bad free ");
+ if (!(header->next) || header->next->prev != header
+ || header->prev->next != header) {
+ Perl_croak_nocontext("panic: bad free");
}
- ((struct perl_memory_debug_header *)where)->in_use
- = PERL_POISON_FREE;
- }
- Poison(where, ((struct perl_memory_debug_header *)where)->size, char);
+ /* Unlink us from the chain. */
+ header->next->prev = header->prev;
+ header->prev->next = header->next;
+# ifdef PERL_POISON
+ PoisonNew(where, header->size, char);
# endif
+ /* Trigger the duplicate free warning. */
+ header->next = NULL;
+ }
#endif
PerlMem_free(where);
}
Malloc_t
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
+ MEM_SIZE total_size = 0;
+ /* Even though calloc() for zero bytes is strange, be robust. */
+ if (size && (count <= MEM_SIZE_MAX / size))
+ total_size = size * count;
+ else
+ Perl_croak_nocontext("%s", PL_memory_wrap);
+#ifdef PERL_TRACK_MEMPOOL
+ if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
+ total_size += sTHX;
+ else
+ Perl_croak_nocontext("%s", PL_memory_wrap);
+#endif
#ifdef HAS_64K_LIMIT
- if (size * count > 0xffff) {
+ if (total_size > 0xffff) {
PerlIO_printf(Perl_error_log,
- "Allocation too large: %lx\n", size * count) FLUSH;
+ "Allocation too large: %lx\n", total_size) FLUSH;
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
if ((long)size < 0 || (long)count < 0)
Perl_croak_nocontext("panic: calloc");
#endif
- size *= count;
#ifdef PERL_TRACK_MEMPOOL
- size += sTHX;
+ /* Have to use malloc() because we've added some space for our tracking
+ header. */
+ /* malloc(0) is non-portable. */
+ ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
+#else
+ /* Use calloc() because it might save a memset() if the memory is fresh
+ and clean from the OS. */
+ if (count && size)
+ ptr = (Malloc_t)PerlMem_calloc(count, size);
+ else /* calloc(0) is non-portable. */
+ ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
#endif
- ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
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)size));
- if (ptr != Nullch) {
- memset((void*)ptr, 0, 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 PERL_TRACK_MEMPOOL
- ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+
+ memset((void*)ptr, 0, total_size);
+ header->interpreter = aTHX;
+ /* Link us into the list. */
+ header->prev = &PL_memory_debug_header;
+ header->next = PL_memory_debug_header.next;
+ PL_memory_debug_header.next = header;
+ header->next->prev = header;
# ifdef PERL_POISON
- ((struct perl_memory_debug_header *)ptr)->size = size;
- ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+ header->size = total_size;
# endif
- ptr = (Malloc_t)((char*)ptr+sTHX);
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+ }
#endif
return ptr;
}
- else if (PL_nomemok)
- return Nullch;
- return write_no_mem();
+ else {
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ return write_no_mem();
+ }
}
/* These must be defined when not using Perl's malloc for binary
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
{
register I32 tolen;
+
+ PERL_ARGS_ASSERT_DELIMCPY;
+
for (tolen = 0; from < fromend; from++, tolen++) {
if (*from == '\\') {
- if (from[1] == delim)
- from++;
- else {
+ if (from[1] != delim) {
if (to < toend)
*to++ = *from;
tolen++;
- from++;
}
+ from++;
}
else if (*from == delim)
break;
/* This routine was donated by Corey Satten. */
char *
-Perl_instr(pTHX_ register const char *big, register const char *little)
+Perl_instr(register const char *big, register const char *little)
{
register I32 first;
+ PERL_ARGS_ASSERT_INSTR;
+
if (!little)
return (char*)big;
first = *little++;
continue;
for (x=big,s=little; *s; /**/ ) {
if (!*x)
- return Nullch;
+ return NULL;
if (*s != *x)
break;
else {
if (!*s)
return (char*)(big-1);
}
- return Nullch;
+ return NULL;
}
/* same as instr but allow embedded nulls */
char *
-Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
+Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
+ PERL_ARGS_ASSERT_NINSTR;
if (little >= lend)
return (char*)big;
{
- char first = *little++;
+ const char first = *little;
const char *s, *x;
- bigend -= lend - little;
+ bigend -= lend - little++;
OUTER:
while (big <= bigend) {
- if (*big++ != first)
- goto OUTER;
- for (x=big,s=little; s < lend; x++,s++) {
- if (*s != *x)
- goto OUTER;
+ if (*big++ == first) {
+ for (x=big,s=little; s < lend; x++,s++) {
+ if (*s != *x)
+ goto OUTER;
+ }
+ return (char*)(big-1);
}
- return (char*)(big-1);
}
}
- return Nullch;
+ return NULL;
}
/* reverse of the above--find last substring */
char *
-Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
{
register const char *bigbeg;
register const I32 first = *little;
register const char * const littleend = lend;
+ PERL_ARGS_ASSERT_RNINSTR;
+
if (little >= littleend)
return (char*)bigend;
bigbeg = big;
if (s >= littleend)
return (char*)(big+1);
}
- return Nullch;
+ return NULL;
}
-#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
-
/* As a space optimization, we do not compile tables for strings of length
0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
special-cased in fbm_instr().
register const U8 *s;
register U32 i;
STRLEN len;
- I32 rarest = 0;
+ U32 rarest = 0;
U32 frequency = 256;
+ PERL_ARGS_ASSERT_FBM_COMPILE;
+
if (flags & FBMcf_TAIL) {
MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
mg->mg_len++;
}
s = (U8*)SvPV_force_mutable(sv, len);
- SvUPGRADE(sv, SVt_PVBM);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
+ SvUPGRADE(sv, SVt_PVGV);
+ SvIOK_off(sv);
+ SvNOK_off(sv);
+ SvVALID_on(sv);
if (len > 2) {
const unsigned char *sb;
const U8 mlen = (len>255) ? 255 : (U8)len;
register U8 *table;
- Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
- table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
- s = table - 1 - FBM_TABLE_OFFSET; /* last char */
+ Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
+ table
+ = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
+ s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
memset((void*)table, mlen, 256);
- table[-1] = (U8)flags;
i = 0;
sb = s - mlen + 1; /* first char (maybe) */
while (s >= sb) {
table[*s] = (U8)i;
s--, i++;
}
+ } else {
+ Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
}
- sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
- SvVALID_on(sv);
+ sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
frequency = PL_freq[s[i]];
}
}
+ BmFLAGS(sv) = (U8)flags;
BmRARE(sv) = s[rarest];
- BmPREVIOUS(sv) = (U16)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 %d\n",
- BmRARE(sv),BmPREVIOUS(sv)));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
+ BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
}
/* If SvTAIL(littlestr), it has a fake '\n' at end. */
=for apidoc fbm_instr
Returns the location of the SV in the string delimited by C<str> and
-C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
+C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
does not have to be fbm_compiled, but the search will not be as fast
then.
register STRLEN littlelen = l;
register const I32 multiline = flags & FBMrf_MULTILINE;
+ PERL_ARGS_ASSERT_FBM_INSTR;
+
if ((STRLEN)(bigend - big) < littlelen) {
if ( SvTAIL(littlestr)
&& ((STRLEN)(bigend - big) == littlelen - 1)
|| (*big == *little &&
memEQ((char *)big, (char *)little, littlelen - 1))))
return (char*)big;
- return Nullch;
+ return NULL;
}
if (littlelen <= 2) { /* Special-cased */
}
if (SvTAIL(littlestr))
return (char *) bigend;
- return Nullch;
+ return NULL;
}
if (!littlelen)
return (char*)big; /* Cannot be SvTAIL! */
return (char*)bigend - 2;
if (bigend[-1] == *little)
return (char*)bigend - 1;
- return Nullch;
+ return NULL;
}
{
/* This should be better than FBM if c1 == c2, and almost
check_1char_anchor: /* One char and anchor! */
if (SvTAIL(littlestr) && (*bigend == *little))
return (char *)bigend; /* bigend is already decremented. */
- return Nullch;
+ return NULL;
}
if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
s = bigend - littlelen;
{
return (char*)s + 1; /* how sweet it is */
}
- return Nullch;
+ return NULL;
}
- if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
+ if (!SvVALID(littlestr)) {
char * const b = ninstr((char*)big,(char*)bigend,
(char*)little, (char*)little + littlelen);
{
return (char*)s;
}
- return Nullch;
+ return NULL;
}
return b;
}
- { /* Do actual FBM. */
- register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
+ /* Do actual FBM. */
+ if (littlelen > (STRLEN)(bigend - big))
+ return NULL;
+
+ {
+ register const unsigned char * const table
+ = little + littlelen + PERL_FBM_TABLE_OFFSET;
register const unsigned char *oldlittle;
- if (littlelen > (STRLEN)(bigend - big))
- return Nullch;
--littlelen; /* Last char found by table lookup */
s = big + littlelen;
}
}
check_end:
- if ( s == bigend && (table[-1] & FBMcf_TAIL)
+ if ( s == bigend
+ && (BmFLAGS(littlestr) & FBMcf_TAIL)
&& memEQ((char *)(bigend - littlelen),
(char *)(oldlittle - littlelen), littlelen) )
return (char*)bigend - littlelen;
- return Nullch;
+ return NULL;
}
}
register const unsigned char *littleend;
I32 found = 0;
+ PERL_ARGS_ASSERT_SCREAMINSTR;
+
+ assert(SvTYPE(littlestr) == SVt_PVGV);
+ assert(SvVALID(littlestr));
+
if (*old_posp == -1
? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
: (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
first = *little++;
goto check_tail;
}
- return Nullch;
+ return NULL;
}
little = (const unsigned char *)(SvPVX_const(littlestr));
if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
goto check_tail;
#endif
- return Nullch;
+ return NULL;
}
while (pos < previous + start_shift) {
if (!(pos += PL_screamnext[pos]))
return (char *)(big+(*old_posp));
check_tail:
if (!SvTAIL(littlestr) || (end_shift > 0))
- return Nullch;
+ return NULL;
/* Ignore the trailing "\n". This code is not microoptimized */
big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
stop_pos = littleend - little; /* Actual littlestr len */
&& ((stop_pos == 1) ||
memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
return (char*)big;
- return Nullch;
+ return NULL;
}
+/*
+=for apidoc foldEQ
+
+Returns true if the leading len bytes of the strings s1 and 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_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, register I32 len)
{
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
+
+ PERL_ARGS_ASSERT_FOLDEQ;
+
while (len--) {
if (*a != *b && *a != PL_fold[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
}
+/*
+=for apidoc foldEQ_locale
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively in the current locale; false otherwise.
+
+=cut
+*/
+
I32
-Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
{
dVAR;
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
+
+ PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
+
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
}
/* copy a string to a safe spot */
char *
Perl_savepv(pTHX_ const char *pv)
{
+ PERL_UNUSED_CONTEXT;
if (!pv)
- return Nullch;
+ return NULL;
else {
char *newaddr;
const STRLEN pvlen = strlen(pv)+1;
- Newx(newaddr,pvlen,char);
- return memcpy(newaddr,pv,pvlen);
+ Newx(newaddr, pvlen, char);
+ return (char*)memcpy(newaddr, pv, pvlen);
}
-
}
/* same thing but with a known length */
Perl's version of what C<strndup()> would be if it existed. Returns a
pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
=cut
*/
Perl_savepvn(pTHX_ const char *pv, register I32 len)
{
register char *newaddr;
+ PERL_UNUSED_CONTEXT;
Newx(newaddr,len+1,char);
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
register char *newaddr;
STRLEN pvlen;
if (!pv)
- return Nullch;
+ return NULL;
pvlen = strlen(pv)+1;
newaddr = (char*)PerlMemShared_malloc(pvlen);
if (!newaddr) {
return write_no_mem();
}
- return memcpy(newaddr,pv,pvlen);
+ return (char*)memcpy(newaddr, pv, pvlen);
+}
+
+/*
+=for apidoc savesharedpvn
+
+A version of C<savepvn()> which allocates the duplicate string in memory
+which is shared between threads. (With the specific difference that a NULL
+pointer is not acceptable)
+
+=cut
+*/
+char *
+Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
+{
+ char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
+
+ PERL_ARGS_ASSERT_SAVESHAREDPVN;
+
+ if (!newaddr) {
+ return write_no_mem();
+ }
+ newaddr[len] = '\0';
+ return (char*)memcpy(newaddr, pv, len);
}
/*
const char * const pv = SvPV_const(sv, len);
register char *newaddr;
+ PERL_ARGS_ASSERT_SAVESVPV;
+
++len;
Newx(newaddr,len,char);
return (char *) CopyD(pv,newaddr,len,char);
XPVMG *any;
if (!PL_dirty)
- return sv_2mortal(newSVpvs(""));
+ return newSVpvs_flags("", SVs_TEMP);
if (PL_mess_sv)
return PL_mess_sv;
dTHX;
char *retval;
va_list args;
+ PERL_ARGS_ASSERT_FORM_NOCONTEXT;
va_start(args, pat);
retval = vform(pat, &args);
va_end(args);
{
char *retval;
va_list args;
+ PERL_ARGS_ASSERT_FORM;
va_start(args, pat);
retval = vform(pat, &args);
va_end(args);
Perl_vform(pTHX_ const char *pat, va_list *args)
{
SV * const sv = mess_alloc();
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ PERL_ARGS_ASSERT_VFORM;
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
return SvPVX(sv);
}
+/*
+=for apidoc Am|SV *|mess|const char *pat|...
+
+Take a sprintf-style format pattern and argument list. These are used to
+generate a string message. If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
#if defined(PERL_IMPLICIT_CONTEXT)
SV *
Perl_mess_nocontext(const char *pat, ...)
dTHX;
SV *retval;
va_list args;
+ PERL_ARGS_ASSERT_MESS_NOCONTEXT;
va_start(args, pat);
retval = vmess(pat, &args);
va_end(args);
{
SV *retval;
va_list args;
+ PERL_ARGS_ASSERT_MESS;
va_start(args, pat);
retval = vmess(pat, &args);
va_end(args);
return retval;
}
-STATIC COP*
-S_closest_cop(pTHX_ COP *cop, const OP *o)
+STATIC const COP*
+S_closest_cop(pTHX_ const COP *cop, const OP *o)
{
dVAR;
/* Look for PL_op starting from o. cop is the last COP we've seen. */
+ PERL_ARGS_ASSERT_CLOSEST_COP;
+
if (!o || o == PL_op)
return cop;
if (o->op_flags & OPf_KIDS) {
- OP *kid;
+ const OP *kid;
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
- COP *new_cop;
+ const COP *new_cop;
/* If the OP_NEXTSTATE has been optimised away we can still use it
* the get the file and line number. */
if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
- cop = (COP *)kid;
+ cop = (const COP *)kid;
/* Keep searching, and return when we've found something. */
/* Nothing found. */
- return Null(COP *);
+ return NULL;
}
+/*
+=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+
+Expands a message, intended for the user, to include an indication of
+the current location in the code, if the message does not already appear
+to be complete.
+
+C<basemsg> is the initial message or object. If it is a reference, it
+will be used as-is and will be the result of this function. Otherwise it
+is used as a string, and if it already ends with a newline, it is taken
+to be complete, and the result of this function will be the same string.
+If the message does not end with a newline, then a segment such as C<at
+foo.pl line 37> will be appended, and possibly other clauses indicating
+the current state of execution. The resulting message will end with a
+dot and a newline.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of this
+function. If C<consume> is true, then the function is permitted (but not
+required) to modify and return C<basemsg> instead of allocating a new SV.
+
+=cut
+*/
+
SV *
-Perl_vmess(pTHX_ const char *pat, va_list *args)
+Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
{
dVAR;
- SV * const sv = mess_alloc();
- static const char dgd[] = " during global destruction.\n";
+ SV *sv;
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
- if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
+ PERL_ARGS_ASSERT_MESS_SV;
+
+ if (SvROK(basemsg)) {
+ if (consume) {
+ sv = basemsg;
+ }
+ else {
+ sv = mess_alloc();
+ sv_setsv(sv, basemsg);
+ }
+ return sv;
+ }
+
+ if (SvPOK(basemsg) && consume) {
+ sv = basemsg;
+ }
+ else {
+ sv = mess_alloc();
+ sv_copypv(sv, basemsg);
+ }
+ if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
/*
* Try and find the file and line for PL_op. This will usually be
* PL_curcop, but it might be a cop that has been optimised away. We
*/
const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
- if (!cop) cop = PL_curcop;
+ if (!cop)
+ cop = PL_curcop;
if (CopLINE(cop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
OutCopFILE(cop), (IV)CopLINE(cop));
- if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
+ /* 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)))
+ {
const bool line_mode = (RsSIMPLE(PL_rs) &&
SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
- PL_last_in_gv == PL_argvgv ?
- "" : GvNAME(PL_last_in_gv),
+ PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
- sv_catpv(sv, PL_dirty ? dgd : ".\n");
+ if (PL_dirty)
+ sv_catpvs(sv, " during global destruction");
+ sv_catpvs(sv, ".\n");
}
return sv;
}
+/*
+=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
+{
+ dVAR;
+ SV * const sv = mess_alloc();
+
+ PERL_ARGS_ASSERT_VMESS;
+
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+ return mess_sv(sv, 1);
+}
+
void
-Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+Perl_write_to_stderr(pTHX_ SV* msv)
{
dVAR;
IO *io;
MAGIC *mg;
+ PERL_ARGS_ASSERT_WRITE_TO_STDERR;
+
if (PL_stderrgv && SvREFCNT(PL_stderrgv)
&& (io = GvIO(PL_stderrgv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
dSP;
ENTER;
save_re_context();
SAVESPTR(PL_stderrgv);
- PL_stderrgv = Nullgv;
+ PL_stderrgv = NULL;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
- PUSHs(SvTIED_obj((SV*)io, mg));
- PUSHs(sv_2mortal(newSVpvn(message, msglen)));
+ PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
+ PUSHs(msv);
PUTBACK;
call_method("PRINT", G_SCALAR);
else {
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
- const int e = errno;
+ dSAVED_ERRNO;
#endif
PerlIO * const serr = Perl_error_log;
+ STRLEN msglen;
+ const char* message = SvPVx_const(msv, msglen);
PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
- errno = e;
+ RESTORE_ERRNO;
#endif
}
}
-/* Common code used by vcroak, vdie, vwarn and vwarner */
+/*
+=head1 Warning and Dieing
+*/
+
+/* Common code used in dieing and warning */
+
+STATIC SV *
+S_with_queued_errors(pTHX_ SV *ex)
+{
+ PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
+ if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
+ sv_catsv(PL_errors, ex);
+ ex = sv_mortalcopy(PL_errors);
+ SvCUR_set(PL_errors, 0);
+ }
+ return ex;
+}
STATIC bool
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
+S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
dVAR;
HV *stash;
/* sv_2cv might call Perl_croak() or Perl_warner() */
SV * const oldhook = *hook;
- assert(oldhook);
+ if (!oldhook)
+ return FALSE;
ENTER;
SAVESPTR(*hook);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
- SV *msg;
+ SV *exarg;
ENTER;
save_re_context();
SAVESPTR(*hook);
*hook = NULL;
}
- if (warn || message) {
- msg = newSVpvn(message, msglen);
- SvFLAGS(msg) |= utf8;
- SvREADONLY_on(msg);
- SAVEFREESV(msg);
- }
- else {
- msg = ERRSV;
- }
+ exarg = newSVsv(ex);
+ SvREADONLY_on(exarg);
+ SAVEFREESV(exarg);
PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
PUSHMARK(SP);
- XPUSHs(msg);
+ XPUSHs(exarg);
PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
+ call_sv(MUTABLE_SV(cv), G_DISCARD);
POPSTACK;
LEAVE;
return TRUE;
return FALSE;
}
-STATIC const char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
- I32* utf8)
-{
- dVAR;
- const char *message;
+/*
+=for apidoc Am|OP *|die_sv|SV *baseex
- if (pat) {
- SV * const msv = vmess(pat, args);
- if (PL_errors && SvCUR(PL_errors)) {
- sv_catsv(PL_errors, msv);
- message = SvPV_const(PL_errors, *msglen);
- SvCUR_set(PL_errors, 0);
- }
- else
- message = SvPV_const(msv,*msglen);
- *utf8 = SvUTF8(msv);
- }
- else {
- message = Nullch;
- }
+Behaves the same as L</croak_sv>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p: die/croak: message = %s\ndiehook = %p\n",
- thr, message, PL_diehook));
- if (PL_diehook) {
- S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
- }
- return message;
-}
+=cut
+*/
OP *
-Perl_vdie(pTHX_ const char* pat, va_list *args)
+Perl_die_sv(pTHX_ SV *baseex)
{
- dVAR;
- const char *message;
- const int was_in_eval = PL_in_eval;
- STRLEN msglen;
- I32 utf8 = 0;
+ PERL_ARGS_ASSERT_DIE_SV;
+ croak_sv(baseex);
+ /* NOTREACHED */
+ return NULL;
+}
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p: die: curstack = %p, mainstack = %p\n",
- thr, PL_curstack, PL_mainstack));
+/*
+=for apidoc Am|OP *|die|const char *pat|...
- message = vdie_croak_common(pat, args, &msglen, &utf8);
+Behaves the same as L</croak>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
- thr, PL_restartop, was_in_eval, PL_top_env));
- if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
- JMPENV_JUMP(3);
- return PL_restartop;
-}
+=cut
+*/
#if defined(PERL_IMPLICIT_CONTEXT)
OP *
Perl_die_nocontext(const char* pat, ...)
{
dTHX;
- OP *o;
va_list args;
va_start(args, pat);
- o = vdie(pat, &args);
+ vcroak(pat, &args);
+ /* NOTREACHED */
va_end(args);
- return o;
+ return NULL;
}
#endif /* PERL_IMPLICIT_CONTEXT */
OP *
Perl_die(pTHX_ const char* pat, ...)
{
- OP *o;
va_list args;
va_start(args, pat);
- o = vdie(pat, &args);
+ vcroak(pat, &args);
+ /* NOTREACHED */
va_end(args);
- return o;
+ return NULL;
}
+/*
+=for apidoc Am|void|croak_sv|SV *baseex
+
+This is an XS interface to Perl's C<die> function.
+
+C<baseex> is the error message or object. If it is a reference, it
+will be used as-is. Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
+function never returns normally.
+
+To die with a simple string message, the L</croak> function may be
+more convenient.
+
+=cut
+*/
+
void
-Perl_vcroak(pTHX_ const char* pat, va_list *args)
+Perl_croak_sv(pTHX_ SV *baseex)
{
- dVAR;
- const char *message;
- STRLEN msglen;
- I32 utf8 = 0;
+ SV *ex = with_queued_errors(mess_sv(baseex, 0));
+ PERL_ARGS_ASSERT_CROAK_SV;
+ invoke_exception_hook(ex, FALSE);
+ die_unwind(ex);
+}
- message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+/*
+=for apidoc Am|void|vcroak|const char *pat|va_list *args
- if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- JMPENV_JUMP(3);
- }
- else if (!message)
- message = SvPVx_const(ERRSV, msglen);
+This is an XS interface to Perl's C<die> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments. If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
- write_to_stderr(message, msglen);
- my_failure_exit();
+void
+Perl_vcroak(pTHX_ const char* pat, va_list *args)
+{
+ SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
+ invoke_exception_hook(ex, FALSE);
+ die_unwind(ex);
}
+/*
+=for apidoc Am|void|croak|const char *pat|...
+
+This is an XS interface to Perl's C<die> function.
+
+Take a sprintf-style format pattern and argument list. These are used to
+generate a string message. If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments. If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
#if defined(PERL_IMPLICIT_CONTEXT)
void
Perl_croak_nocontext(const char *pat, ...)
}
#endif /* PERL_IMPLICIT_CONTEXT */
+void
+Perl_croak(pTHX_ const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ vcroak(pat, &args);
+ /* NOTREACHED */
+ va_end(args);
+}
+
/*
-=head1 Warning and Dieing
+=for apidoc Am|void|croak_no_modify
-=for apidoc croak
+Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
+terser object code than using C<Perl_croak>. Less code used on exception code
+paths reduces CPU cache pressure.
-This is the XSUB-writer's interface to Perl's C<die> function.
-Normally call this function the same way you call the C C<printf>
-function. Calling C<croak> returns control directly to Perl,
-sidestepping the normal C order of execution. See C<warn>.
+=cut
+*/
+
+void
+Perl_croak_no_modify(pTHX)
+{
+ Perl_croak(aTHX_ "%s", PL_no_modify);
+}
+
+/*
+=for apidoc Am|void|warn_sv|SV *baseex
-If you want to throw an exception object, assign the object to
-C<$@> and then pass C<Nullch> to croak():
+This is an XS interface to Perl's C<warn> function.
- errsv = get_sv("@", TRUE);
- sv_setsv(errsv, exception_object);
- croak(Nullch);
+C<baseex> is the error message or object. If it is a reference, it
+will be used as-is. Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+To warn with a simple string message, the L</warn> function may be
+more convenient.
=cut
*/
void
-Perl_croak(pTHX_ const char *pat, ...)
+Perl_warn_sv(pTHX_ SV *baseex)
{
- va_list args;
- va_start(args, pat);
- vcroak(pat, &args);
- /* NOTREACHED */
- va_end(args);
+ SV *ex = mess_sv(baseex, 0);
+ PERL_ARGS_ASSERT_WARN_SV;
+ if (!invoke_exception_hook(ex, TRUE))
+ write_to_stderr(ex);
}
+/*
+=for apidoc Am|void|vwarn|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<warn> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</vcroak>, C<pat> is not permitted to be null.
+
+=cut
+*/
+
void
Perl_vwarn(pTHX_ const char* pat, va_list *args)
{
- dVAR;
- STRLEN msglen;
- SV * const msv = vmess(pat, args);
- const I32 utf8 = SvUTF8(msv);
- const char * const message = SvPV_const(msv, msglen);
+ SV *ex = vmess(pat, args);
+ PERL_ARGS_ASSERT_VWARN;
+ if (!invoke_exception_hook(ex, TRUE))
+ write_to_stderr(ex);
+}
- if (PL_warnhook) {
- if (vdie_common(message, msglen, utf8, TRUE))
- return;
- }
+/*
+=for apidoc Am|void|warn|const char *pat|...
- write_to_stderr(message, msglen);
-}
+This is an XS interface to Perl's C<warn> function.
+
+Take a sprintf-style format pattern and argument list. These are used to
+generate a string message. If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</croak>, C<pat> is not permitted to be null.
+
+=cut
+*/
#if defined(PERL_IMPLICIT_CONTEXT)
void
{
dTHX;
va_list args;
+ PERL_ARGS_ASSERT_WARN_NOCONTEXT;
va_start(args, pat);
vwarn(pat, &args);
va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */
-/*
-=for apidoc warn
-
-This is the XSUB-writer's interface to Perl's C<warn> function. Call this
-function the same way you call the C C<printf> function. See C<croak>.
-
-=cut
-*/
-
void
Perl_warn(pTHX_ const char *pat, ...)
{
va_list args;
+ PERL_ARGS_ASSERT_WARN;
va_start(args, pat);
vwarn(pat, &args);
va_end(args);
{
dTHX;
va_list args;
+ PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
va_start(args, pat);
vwarner(err, pat, &args);
va_end(args);
#endif /* PERL_IMPLICIT_CONTEXT */
void
+Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+{
+ PERL_ARGS_ASSERT_CK_WARNER_D;
+
+ if (Perl_ckwarn_d(aTHX_ err)) {
+ va_list args;
+ va_start(args, pat);
+ vwarner(err, pat, &args);
+ va_end(args);
+ }
+}
+
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+ PERL_ARGS_ASSERT_CK_WARNER;
+
+ if (Perl_ckwarn(aTHX_ err)) {
+ va_list args;
+ va_start(args, pat);
+ vwarner(err, pat, &args);
+ va_end(args);
+ }
+}
+
+void
Perl_warner(pTHX_ U32 err, const char* pat,...)
{
va_list args;
+ PERL_ARGS_ASSERT_WARNER;
va_start(args, pat);
vwarner(err, pat, &args);
va_end(args);
Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
{
dVAR;
- if (ckDEAD(err)) {
+ PERL_ARGS_ASSERT_VWARNER;
+ if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
SV * const msv = vmess(pat, args);
- STRLEN msglen;
- const char * const message = SvPV_const(msv, msglen);
- const I32 utf8 = SvUTF8(msv);
- if (PL_diehook) {
- assert(message);
- S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
- }
- if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- JMPENV_JUMP(3);
- }
- write_to_stderr(message, msglen);
- my_failure_exit();
+ invoke_exception_hook(msv, FALSE);
+ die_unwind(msv);
}
else {
Perl_vwarn(aTHX_ pat, args);
Perl_ckwarn(pTHX_ U32 w)
{
dVAR;
- return
- (
- isLEXWARN_on
- && PL_curcop->cop_warnings != pWARN_NONE
- && (
- PL_curcop->cop_warnings == pWARN_ALL
- || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
- || (unpackWARN2(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
- || (unpackWARN3(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
- || (unpackWARN4(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
- )
- )
- ||
- (
- isLEXWARN_off && PL_dowarn & G_WARN_ON
- )
- ;
+ /* If lexical warnings have not been set, use $^W. */
+ if (isLEXWARN_off)
+ return PL_dowarn & G_WARN_ON;
+
+ return ckwarn_common(w);
}
/* implements the ckWARN?_d macro */
Perl_ckwarn_d(pTHX_ U32 w)
{
dVAR;
- return
- isLEXWARN_off
- || PL_curcop->cop_warnings == pWARN_ALL
- || (
- PL_curcop->cop_warnings != pWARN_NONE
- && (
- isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
- || (unpackWARN2(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
- || (unpackWARN3(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
- || (unpackWARN4(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
- )
- )
- ;
+ /* If lexical warnings have not been set then default classes warn. */
+ if (isLEXWARN_off)
+ return TRUE;
+
+ return ckwarn_common(w);
}
+static bool
+S_ckwarn_common(pTHX_ U32 w)
+{
+ if (PL_curcop->cop_warnings == pWARN_ALL)
+ return TRUE;
+ if (PL_curcop->cop_warnings == pWARN_NONE)
+ return FALSE;
+
+ /* Check the assumption that at least the first slot is non-zero. */
+ assert(unpackWARN1(w));
+
+ /* Check the assumption that it is valid to stop as soon as a zero slot is
+ seen. */
+ if (!unpackWARN2(w)) {
+ assert(!unpackWARN3(w));
+ assert(!unpackWARN4(w));
+ } else if (!unpackWARN3(w)) {
+ assert(!unpackWARN4(w));
+ }
+
+ /* Right, dealt with all the special cases, which are implemented as non-
+ pointers, so there is a pointer to a real warnings mask. */
+ do {
+ if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+ return TRUE;
+ } while (w >>= WARNshift);
+
+ return FALSE;
+}
+
+/* Set buffer=NULL to get a new one. */
+STRLEN *
+Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
+ STRLEN size) {
+ const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+ PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
+
+ buffer = (STRLEN*)
+ (specialWARN(buffer) ?
+ PerlMemShared_malloc(len_wanted) :
+ PerlMemShared_realloc(buffer, len_wanted));
+ buffer[0] = size;
+ Copy(bits, (buffer + 1), size, char);
+ return buffer;
+}
/* since we've already done strlen() for both nam and val
* we can use that info to make things faster than
#ifndef PERL_USE_SAFE_PUTENV
if (!PL_use_safe_putenv) {
/* most putenv()s leak, so we manipulate environ directly */
- register I32 i=setenv_getix(nam); /* where does it go? */
+ register I32 i;
+ register const I32 len = strlen(nam);
int nlen, vlen;
- if (environ == PL_origenviron) { /* need we copy environment? */
- I32 j;
- I32 max;
- char **tmpenv;
-
- for (max = i; environ[max]; max++) ;
- tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
- for (j=0; j<max; j++) { /* copy environment */
- const int len = strlen(environ[j]);
- tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
- Copy(environ[j], tmpenv[j], len+1, char);
- }
- tmpenv[max] = Nullch;
- environ = tmpenv; /* tell exec where it is now */
+ /* where does it go? */
+ for (i = 0; environ[i]; i++) {
+ if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+ break;
+ }
+
+ if (environ == PL_origenviron) { /* need we copy environment? */
+ I32 j;
+ I32 max;
+ char **tmpenv;
+
+ max = i;
+ while (environ[max])
+ max++;
+ tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+ for (j=0; j<max; j++) { /* copy environment */
+ const int len = strlen(environ[j]);
+ tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+ Copy(environ[j], tmpenv[j], len+1, char);
+ }
+ tmpenv[max] = NULL;
+ environ = tmpenv; /* tell exec where it is now */
}
if (!val) {
- safesysfree(environ[i]);
- while (environ[i]) {
- environ[i] = environ[i+1];
- i++;
+ safesysfree(environ[i]);
+ while (environ[i]) {
+ environ[i] = environ[i+1];
+ i++;
}
- return;
+ return;
}
- if (!environ[i]) { /* does not exist yet */
- environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
- environ[i+1] = Nullch; /* make sure it's null terminated */
+ if (!environ[i]) { /* does not exist yet */
+ environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+ environ[i+1] = NULL; /* make sure it's null terminated */
}
else
- safesysfree(environ[i]);
- nlen = strlen(nam);
- vlen = strlen(val);
+ safesysfree(environ[i]);
+ nlen = strlen(nam);
+ vlen = strlen(val);
- environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
- /* all that work just for this */
- my_setenv_format(environ[i], nam, nlen, val, vlen);
+ environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
-# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
+# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
int vlen;
if (!val) {
- val = "";
+ val = "";
}
vlen = strlen(val);
Newx(envstr, nlen+vlen+2, char);
#endif /* WIN32 || NETWARE */
-#ifndef PERL_MICRO
-I32
-Perl_setenv_getix(pTHX_ const char *nam)
-{
- register I32 i;
- register const I32 len = strlen(nam);
-
- for (i = 0; environ[i]; i++) {
- if (
-#ifdef WIN32
- strnicmp(environ[i],nam,len) == 0
-#else
- strnEQ(environ[i],nam,len)
-#endif
- && environ[i][len] == '=')
- break; /* strnEQ must come first to avoid */
- } /* potential SEGV's */
- return i;
-}
-#endif /* !PERL_MICRO */
-
#endif /* !VMS && !EPOC*/
#ifdef UNLINK_ALL_VERSIONS
I32
Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
{
- I32 i;
+ I32 retries = 0;
+
+ PERL_ARGS_ASSERT_UNLNK;
- for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
- return i ? 0 : -1;
+ while (PerlLIO_unlink(f) >= 0)
+ retries++;
+ return retries ? 0 : -1;
}
#endif
{
char * const retval = to;
+ PERL_ARGS_ASSERT_MY_BCOPY;
+
if (from - to >= 0) {
while (len--)
*to++ = *from++;
{
char * const retval = loc;
+ PERL_ARGS_ASSERT_MY_MEMSET;
+
while (len--)
*loc++ = ch;
return retval;
{
char * const retval = loc;
+ PERL_ARGS_ASSERT_MY_BZERO;
+
while (len--)
*loc++ = 0;
return retval;
register const U8 *b = (const U8 *)s2;
register I32 tmp;
+ PERL_ARGS_ASSERT_MY_MEMCMP;
+
while (len--) {
if ((tmp = *a++ - *b++))
return tmp;
#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, char *args)
+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 */
- (void)putc('\0', &fakebuf);
+#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
char c[sizeof(long)];
} u;
-#if BYTEORDER == 0x1234
+#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;
type value; \
char c[sizeof(type)]; \
} u; \
- register I32 i; \
- register I32 s = 0; \
+ register U32 i; \
+ register U32 s = 0; \
for (i = 0; i < sizeof(u.c); i++, s += 8) { \
u.c[i] = (n >> s) & 0xFF; \
} \
type value; \
char c[sizeof(type)]; \
} u; \
- register I32 i; \
- register I32 s = 0; \
+ register U32 i; \
+ register U32 s = 0; \
u.value = n; \
n = 0; \
for (i = 0; i < sizeof(u.c); i++, s += 8) { \
type value; \
char c[sizeof(type)]; \
} u; \
- register I32 i; \
- register I32 s = 8*(sizeof(u.c)-1); \
+ register U32 i; \
+ register U32 s = 8*(sizeof(u.c)-1); \
for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
u.c[i] = (n >> s) & 0xFF; \
} \
type value; \
char c[sizeof(type)]; \
} u; \
- register I32 i; \
- register I32 s = 8*(sizeof(u.c)-1); \
+ register U32 i; \
+ register U32 s = 8*(sizeof(u.c)-1); \
u.value = n; \
n = 0; \
for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
register char *e = s + (n-1);
register char tc;
+ PERL_ARGS_ASSERT_MY_SWABN;
+
for (n /= 2; n > 0; s++, e--, n--) {
tc = *s;
*s = *e;
}
PerlIO *
-Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
+Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
dVAR;
int p[2];
register I32 This, that;
I32 did_pipes = 0;
int pp[2];
+ PERL_ARGS_ASSERT_MY_POPEN_LIST;
+
PERL_FLUSHALL_FOR_CHILD;
This = (*mode == 'w');
that = !This;
taint_proper("Insecure %s%s", "EXEC");
}
if (PerlProc_pipe(p) < 0)
- return Nullfp;
+ return NULL;
/* Try for another pipe pair for error return */
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
}
- return Nullfp;
+ return NULL;
}
+ Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
sleep(5);
}
if (pid == 0) {
}
}
#endif
- do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
+ do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
PerlProc__exit(1);
#undef THIS
#undef THAT
else
PerlLIO_close(p[that]); /* close child's end of pipe */
- LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
- UNLOCK_FDPID_MUTEX;
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
/* If we managed to get status pipe check for exec fail */
if (did_pipes && pid > 0) {
int errkid;
- int n = 0, n1;
+ unsigned n = 0;
+ SSize_t n1;
while (n < sizeof(int)) {
n1 = PerlLIO_read(pp[0],
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
errno = errkid; /* Propagate errno from kid */
- return Nullfp;
+ return NULL;
}
}
if (did_pipes)
PerlLIO_close(pp[0]);
return PerlIO_fdopen(p[This], mode);
#else
+# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
+ return my_syspopen4(aTHX_ NULL, mode, n, args);
+# else
Perl_croak(aTHX_ "List form of piped open not implemented");
return (PerlIO *) NULL;
+# endif
#endif
}
/* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
I32 did_pipes = 0;
int pp[2];
+ PERL_ARGS_ASSERT_MY_POPEN;
+
PERL_FLUSHALL_FOR_CHILD;
#ifdef OS2
if (doexec) {
taint_proper("Insecure %s%s", "EXEC");
}
if (PerlProc_pipe(p) < 0)
- return Nullfp;
+ return NULL;
if (doexec && PerlProc_pipe(pp) >= 0)
did_pipes = 1;
while ((pid = PerlProc_fork()) < 0) {
PerlLIO_close(pp[1]);
}
if (!doexec)
- Perl_croak(aTHX_ "Can't fork");
- return Nullfp;
+ Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
+ return NULL;
}
+ Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
sleep(5);
}
if (pid == 0) {
PerlProc__exit(1);
}
#endif /* defined OS2 */
- if ((tmpgv = gv_fetchpvs("$",TRUE, SVt_PV))) {
+
+#ifdef PERLIO_USING_CRLF
+ /* Since we circumvent IO layers when we manipulate low-level
+ filedescriptors directly, need to manually switch to the
+ default, binary, low-level mode; see PerlIOBuf_open(). */
+ PerlLIO_setmode((*mode == 'r'), O_BINARY);
+#endif
+
+ if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* we have no children */
#endif
- return Nullfp;
+ return NULL;
#undef THIS
#undef THAT
}
else
PerlLIO_close(p[that]);
- LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
- UNLOCK_FDPID_MUTEX;
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
if (did_pipes && pid > 0) {
int errkid;
- int n = 0, n1;
+ unsigned n = 0;
+ SSize_t n1;
while (n < sizeof(int)) {
n1 = PerlLIO_read(pp[0],
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
errno = errkid; /* Propagate errno from kid */
- return Nullfp;
+ return NULL;
}
}
if (did_pipes)
#if defined(atarist) || defined(EPOC)
FILE *popen();
PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
+ PERL_ARGS_ASSERT_MY_POPEN;
PERL_FLUSHALL_FOR_CHILD;
/* Call system's popen() to get a FILE *, then import it.
used 0 for 2nd parameter to PerlIO_importFILE;
#if defined(DJGPP)
FILE *djgpp_popen();
PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
PERL_FLUSHALL_FOR_CHILD;
/* Call system's popen() to get a FILE *, then import it.
*/
return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
}
+#else
+#if defined(__LIBCATAMOUNT__)
+PerlIO *
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
+{
+ return NULL;
+}
+#endif
#endif
#endif
#ifdef DUMP_FDS
void
-Perl_dump_fds(pTHX_ char *s)
+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)
#ifndef PERL_MICRO
#ifdef HAS_SIGACTION
-#ifdef MACOS_TRADITIONAL
-/* We don't want restart behavior on MacOS */
-#undef SA_RESTART
-#endif
-
Sighandler_t
Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
{
Perl_rsignal_state(pTHX_ int signo)
{
struct sigaction oact;
+ PERL_UNUSED_CONTEXT;
if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
return (Sighandler_t) SIG_ERR;
dVAR;
struct sigaction act;
+ PERL_ARGS_ASSERT_RSIGNAL_SAVE;
+
#ifdef USE_ITHREADS
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
#endif /* !PERL_MICRO */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
Pid_t pid;
Pid_t pid2;
bool close_failed;
- int saved_errno = 0;
-#ifdef WIN32
- int saved_win32_errno;
-#endif
+ dSAVEDERRNO;
- LOCK_FDPID_MUTEX;
svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
- UNLOCK_FDPID_MUTEX;
pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
SvREFCNT_dec(*svp);
*svp = &PL_sv_undef;
return my_syspclose(ptr);
}
#endif
- if ((close_failed = (PerlIO_close(ptr) == EOF))) {
- saved_errno = errno;
-#ifdef WIN32
- saved_win32_errno = GetLastError();
-#endif
- }
+ close_failed = (PerlIO_close(ptr) == EOF);
+ SAVE_ERRNO;
#ifdef UTS
if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
rsignal_restore(SIGQUIT, &qstat);
#endif
if (close_failed) {
- SETERRNO(saved_errno, 0);
+ RESTORE_ERRNO;
return -1;
}
return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
}
+#else
+#if defined(__LIBCATAMOUNT__)
+I32
+Perl_my_pclose(pTHX_ PerlIO *ptr)
+{
+ return -1;
+}
+#endif
#endif /* !DOSISH */
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
dVAR;
I32 result = 0;
+ PERL_ARGS_ASSERT_WAIT4PID;
if (!pid)
return -1;
#ifdef PERL_USES_PL_PIDSTATUS
goto finish;
#endif
#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
- result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
+ result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
goto finish;
#endif
#ifdef PERL_USES_PL_PIDSTATUS
#endif
if (result < 0 && errno == EINTR) {
PERL_ASYNC_CHECK();
+ errno = EINTR; /* reset in case a signal handler changed $! */
}
return result;
}
#ifdef PERL_USES_PL_PIDSTATUS
void
-Perl_pidgone(pTHX_ Pid_t pid, int status)
+S_pidgone(pTHX_ Pid_t pid, int status)
{
register SV *sv;
}
#endif
+#define PERL_REPEATCPY_LINEAR 4
void
-Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
{
- register I32 todo;
- register const char * const frombase = from;
+ PERL_ARGS_ASSERT_REPEATCPY;
+
+ if (len == 1)
+ memset(to, *from, count);
+ else if (count) {
+ register char *p = to;
+ I32 items, linear, half;
+
+ linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
+ for (items = 0; items < linear; ++items) {
+ register const char *q = from;
+ I32 todo;
+ for (todo = len; todo > 0; todo--)
+ *p++ = *q++;
+ }
- if (len == 1) {
- register const char c = *from;
- while (count-- > 0)
- *to++ = c;
- return;
- }
- while (count-- > 0) {
- for (todo = len; todo > 0; todo--) {
- *to++ = *from++;
+ half = count / 2;
+ while (items <= half) {
+ I32 size = items * len;
+ memcpy(p, to, size);
+ p += size;
+ items *= 2;
}
- from = frombase;
+
+ if (count > items)
+ memcpy(p, to, (count - items) * len);
}
}
Stat_t tmpstatbuf2;
SV * const tmpsv = sv_newmortal();
+ PERL_ARGS_ASSERT_SAME_DIRENT;
+
if (fa)
fa++;
else
if (strNE(a,b))
return FALSE;
if (fa == a)
- sv_setpvn(tmpsv, ".", 1);
+ sv_setpvs(tmpsv, ".");
else
sv_setpvn(tmpsv, a, fa - a);
if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
return FALSE;
if (fb == b)
- sv_setpvn(tmpsv, ".", 1);
+ sv_setpvs(tmpsv, ".");
else
sv_setpvn(tmpsv, b, fb - b);
if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
const char *const *const search_ext, I32 flags)
{
dVAR;
- const char *xfound = Nullch;
- char *xfailed = Nullch;
+ const char *xfound = NULL;
+ char *xfailed = NULL;
char tmpbuf[MAXPATHLEN];
register char *s;
I32 len = 0;
int retval;
+ char *bufend;
#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
# define SEARCH_EXTS ".bat", ".cmd", NULL
# define MAX_EXT_LEN 4
static const char *const exts[] = { SEARCH_EXTS };
const char *const *const ext = search_ext ? search_ext : exts;
int extidx = 0, i = 0;
- const char *curext = Nullch;
+ const char *curext = NULL;
#else
PERL_UNUSED_ARG(search_ext);
# define MAX_EXT_LEN 0
#endif
+ PERL_ARGS_ASSERT_FIND_SCRIPT;
+
/*
* If dosearch is true and if scriptname does not contain path
* delimiters, search the PATH for scriptname.
int idx = 0, deftypes = 1;
bool seen_dot = 1;
- const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch);
+ const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
# else
if (dosearch) {
int idx = 0, deftypes = 1;
bool seen_dot = 1;
- const int hasdir = (strpbrk(scriptname,":[</") != Nullch);
+ const int hasdir = (strpbrk(scriptname,":[</") != NULL);
# endif
/* The first time through, just add SEARCH_EXTS to whatever we
* already have, so we can check for default file types. */
if ((strlen(tmpbuf) + strlen(scriptname)
+ MAX_EXT_LEN) >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
- strcat(tmpbuf, scriptname);
+ my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
#else /* !VMS */
#ifdef DOSISH
len = strlen(scriptname);
if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
break;
- /* FIXME? Convert to memcpy */
- cur = strcpy(tmpbuf, scriptname);
+ my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
+ cur = tmpbuf;
}
} while (extidx >= 0 && ext[extidx] /* try an extension? */
- && strcpy(tmpbuf+len, ext[extidx++]));
+ && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
#endif
}
#endif
-#ifdef MACOS_TRADITIONAL
- if (dosearch && !strchr(scriptname, ':') &&
- (s = PerlEnv_getenv("Commands")))
-#else
if (dosearch && !strchr(scriptname, '/')
#ifdef DOSISH
&& !strchr(scriptname, '\\')
#endif
&& (s = PerlEnv_getenv("PATH")))
-#endif
{
bool seen_dot = 0;
- PL_bufend = s + strlen(s);
- while (s < PL_bufend) {
-#ifdef MACOS_TRADITIONAL
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
- ',',
- &len);
-#else
+ bufend = s + strlen(s);
+ while (s < bufend) {
#if defined(atarist) || defined(DOSISH)
for (len = 0; *s
# ifdef atarist
if (len < sizeof tmpbuf)
tmpbuf[len] = '\0';
#else /* ! (atarist || DOSISH) */
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
':',
&len);
#endif /* ! (atarist || DOSISH) */
-#endif /* MACOS_TRADITIONAL */
- if (s < PL_bufend)
+ if (s < bufend)
s++;
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
-#ifdef MACOS_TRADITIONAL
- if (len && tmpbuf[len - 1] != ':')
- tmpbuf[len++] = ':';
-#else
if (len
-# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
+# if defined(atarist) || defined(DOSISH)
&& tmpbuf[len - 1] != '/'
&& tmpbuf[len - 1] != '\\'
# endif
tmpbuf[len++] = '/';
if (len == 2 && tmpbuf[0] == '.')
seen_dot = 1;
-#endif
- /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
- */
- (void)strcpy(tmpbuf + len, scriptname);
+ (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
#endif /* !VMS */
#ifdef SEARCH_EXTS
#ifdef SEARCH_EXTS
} while ( retval < 0 /* not there */
&& extidx>=0 && ext[extidx] /* try an extension? */
- && strcpy(tmpbuf+len, ext[extidx++])
+ && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
);
#endif
if (retval < 0)
continue;
if (S_ISREG(PL_statbuf.st_mode)
&& cando(S_IRUSR,TRUE,&PL_statbuf)
-#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
+#if !defined(DOSISH)
&& cando(S_IXUSR,TRUE,&PL_statbuf)
#endif
)
(xfailed ? "" : " on PATH"),
(xfailed || seen_dot) ? "" : ", '.' not in PATH");
}
- scriptname = Nullch;
+ scriptname = NULL;
}
Safefree(xfailed);
scriptname = xfound;
}
- return (scriptname ? savepv(scriptname) : Nullch);
+ return (scriptname ? savepv(scriptname) : NULL);
}
#ifndef PERL_GET_CONTEXT_DEFINED
Perl_set_context(void *t)
{
dVAR;
+ PERL_ARGS_ASSERT_SET_CONTEXT;
#if defined(USE_ITHREADS)
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
char **
Perl_get_op_names(pTHX)
{
- return (char **)PL_op_name;
+ PERL_UNUSED_CONTEXT;
+ return (char **)PL_op_name;
}
char **
Perl_get_op_descs(pTHX)
{
- return (char **)PL_op_desc;
+ PERL_UNUSED_CONTEXT;
+ return (char **)PL_op_desc;
}
const char *
Perl_get_no_modify(pTHX)
{
- return PL_no_modify;
+ PERL_UNUSED_CONTEXT;
+ return PL_no_modify;
}
U32 *
Perl_get_opargs(pTHX)
{
- return (U32 *)PL_opargs;
+ PERL_UNUSED_CONTEXT;
+ return (U32 *)PL_opargs;
}
PPADDR_t*
Perl_get_ppaddr(pTHX)
{
- dVAR;
- return (PPADDR_t*)PL_ppaddr;
+ dVAR;
+ PERL_UNUSED_CONTEXT;
+ return (PPADDR_t*)PL_ppaddr;
}
#ifndef HAS_GETENV_LEN
Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
{
char * const env_trans = PerlEnv_getenv(env_elem);
+ PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_GETENV_LEN;
if (env_trans)
*len = strlen(env_trans);
return env_trans;
Perl_get_vtbl(pTHX_ int vtbl_id)
{
const MGVTBL* result;
+ PERL_UNUSED_CONTEXT;
switch(vtbl_id) {
case want_vtbl_sv:
case want_vtbl_arylen:
result = &PL_vtbl_arylen;
break;
- case want_vtbl_glob:
- result = &PL_vtbl_glob;
- break;
case want_vtbl_mglob:
result = &PL_vtbl_mglob;
break;
result = &PL_vtbl_utf8;
break;
default:
- result = Null(MGVTBL*);
+ result = NULL;
break;
}
return (MGVTBL*)result;
void
Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
{
- const char * const func =
- op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
- op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
- PL_op_desc[op];
- const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
- const char * const type = OP_IS_SOCKET(op)
- || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
- ? "socket" : "filehandle";
const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
if (ckWARN(WARN_IO)) {
- const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
+ const char * const direction =
+ (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
if (name && *name)
Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for %sput",
}
if (ckWARN(warn_type)) {
+ const char * const pars =
+ (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+ const char * const func =
+ (const char *)
+ (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
+ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
+ op < 0 ? "" : /* handle phoney cases */
+ PL_op_desc[op]);
+ const char * const type =
+ (const char *)
+ (OP_IS_SOCKET(op) ||
+ (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
+ "socket" : "filehandle");
if (name && *name) {
Perl_warner(aTHX_ packWARN(warn_type),
"%s%s on %s %s %s", func, pars, vile, type, name);
}
}
-#ifdef EBCDIC
-/* in ASCII order, not that it matters */
-static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+/* XXX Add documentation after final interface and behavior is decided */
+/* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
+ U8 source = *current;
-int
-Perl_ebcdic_control(pTHX_ int ch)
+ May want to add eg, WARN_REGEX
+*/
+
+char
+Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
{
- if (ch > 'a') {
- const char *ctlp;
+
+ U8 result;
- if (islower(ch))
- ch = toupper(ch);
+ if (! isASCII(source)) {
+ Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
+ }
- if ((ctlp = strchr(controllablechars, ch)) == 0) {
- Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
+ result = toCTRL(source);
+ if (! isCNTRL(result)) {
+ if (source == '{') {
+ Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\". If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
}
+ else if (output_warning) {
+ U8 clearer[3];
+ U8 i = 0;
+ if (! isALNUM(result)) {
+ clearer[i++] = '\\';
+ }
+ clearer[i++] = result;
+ clearer[i++] = '\0';
- if (ctlp == controllablechars)
- return('\177'); /* DEL */
- else
- return((unsigned char)(ctlp - controllablechars - 1));
- } else { /* Want uncontrol */
- if (ch == '\177' || ch == -1)
- return('?');
- else if (ch == '\157')
- return('\177');
- else if (ch == '\174')
- return('\000');
- else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
- return('\036');
- else if (ch == '\155')
- return('\037');
- else if (0 < ch && ch < (sizeof(controllablechars) - 1))
- return(controllablechars[ch+1]);
- else
- Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "\"\\c%c\" more clearly written simply as \"%s\"",
+ source,
+ clearer);
+ }
}
+
+ return result;
}
-#endif
/* To workaround core dumps from the uninitialised tm_zone we get the
* system to give us a reasonable struct to copy. This fix means that
#ifdef HAS_TM_TM_ZONE
Time_t now;
const struct tm* my_tm;
+ PERL_ARGS_ASSERT_INIT_TM;
(void)time(&now);
my_tm = localtime(&now);
if (my_tm)
Copy(my_tm, ptm, 1, struct tm);
#else
+ PERL_ARGS_ASSERT_INIT_TM;
PERL_UNUSED_ARG(ptm);
#endif
}
int secs;
int month, mday, year, jday;
int odd_cent, odd_year;
+ PERL_UNUSED_CONTEXT;
+
+ PERL_ARGS_ASSERT_MINI_MKTIME;
#define DAYS_PER_YEAR 365
#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
struct tm mytm;
int len;
+ PERL_ARGS_ASSERT_MY_STRFTIME;
+
init_tm(&mytm); /* XXX workaround - see init_tm() above */
mytm.tm_sec = sec;
mytm.tm_min = min;
else {
/* Possibly buf overflowed - try again with a bigger buf */
const int fmtlen = strlen(fmt);
- const int bufsize = fmtlen + buflen;
+ int bufsize = fmtlen + buflen;
Newx(buf, bufsize, char);
while (buf) {
buf = NULL;
break;
}
- Renew(buf, bufsize*2, char);
+ bufsize *= 2;
+ Renew(buf, bufsize, char);
}
return buf;
}
SvTAINTED_on(sv);
#endif
+ PERL_ARGS_ASSERT_GETCWD_SV;
+
#ifdef HAS_GETCWD
{
char buf[MAXPATHLEN];
for (;;) {
DIR *dir;
+ int namelen;
odev = cdev;
oino = cino;
while ((dp = PerlDir_read(dir)) != NULL) {
#ifdef DIRNAMLEN
- const int namelen = dp->d_namlen;
+ namelen = dp->d_namlen;
#else
- const int namelen = strlen(dp->d_name);
+ namelen = strlen(dp->d_name);
#endif
/* skip . and .. */
if (SV_CWD_ISDOT(dp)) {
"current directory changed unexpectedly");
}
- return TRUE;
-#endif
+ return TRUE;
+#endif
+
+#else
+ return FALSE;
+#endif
+}
+
+#define VERSION_MAX 0x7FFFFFFF
+
+/*
+=for apidoc prescan_version
+
+=cut
+*/
+const char *
+Perl_prescan_version(pTHX_ const char *s, bool strict,
+ const char **errstr,
+ bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
+ bool qv = (sqv ? *sqv : FALSE);
+ int width = 3;
+ int saw_decimal = 0;
+ bool alpha = FALSE;
+ const char *d = s;
+
+ PERL_ARGS_ASSERT_PRESCAN_VERSION;
+
+ if (qv && isDIGIT(*d))
+ goto dotted_decimal_version;
+
+ if (*d == 'v') { /* explicit v-string */
+ d++;
+ if (isDIGIT(*d)) {
+ qv = TRUE;
+ }
+ else { /* degenerate v-string */
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+
+dotted_decimal_version:
+ if (strict && d[0] == '0' && isDIGIT(d[1])) {
+ /* no leading zeros allowed */
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+
+ while (isDIGIT(*d)) /* integer part */
+ d++;
+
+ if (*d == '.')
+ {
+ saw_decimal++;
+ d++; /* decimal point */
+ }
+ else
+ {
+ if (strict) {
+ /* require v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ else {
+ goto version_prescan_finish;
+ }
+ }
+
+ {
+ int i = 0;
+ int j = 0;
+ while (isDIGIT(*d)) { /* just keep reading */
+ i++;
+ while (isDIGIT(*d)) {
+ d++; j++;
+ /* maximum 3 digits between decimal */
+ if (strict && j > 3) {
+ BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
+ }
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ else if (*d == '.') {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ saw_decimal++;
+ d++;
+ }
+ else if (!isDIGIT(*d)) {
+ break;
+ }
+ j = 0;
+ }
+
+ if (strict && i < 2) {
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ }
+ } /* end if dotted-decimal */
+ else
+ { /* decimal versions */
+ /* special strict case for leading '.' or '0' */
+ if (strict) {
+ if (*d == '.') {
+ BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
+ }
+ if (*d == '0' && isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+ }
+
+ /* consume all of the integer part */
+ while (isDIGIT(*d))
+ d++;
+
+ /* look for a fractional part */
+ if (*d == '.') {
+ /* we found it, so consume it */
+ saw_decimal++;
+ d++;
+ }
+ else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
+ if ( d == s ) {
+ /* found nothing */
+ BADVERSION(s,errstr,"Invalid version format (version required)");
+ }
+ /* found just an integer */
+ goto version_prescan_finish;
+ }
+ else if ( d == s ) {
+ /* didn't find either integer or period */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+ else if (*d == '_') {
+ /* underscore can't come after integer part */
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ else if (isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
+ }
+ else {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ }
+ else {
+ /* anything else after integer part is just invalid data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ /* scan the fractional part after the decimal point*/
+
+ if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
+ /* strict or lax-but-not-the-end */
+ BADVERSION(s,errstr,"Invalid version format (fractional part required)");
+ }
+
+ while (isDIGIT(*d)) {
+ d++;
+ if (*d == '.' && isDIGIT(d[-1])) {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+ }
+ d = (char *)s; /* start all over again */
+ qv = TRUE;
+ goto dotted_decimal_version;
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ if ( ! isDIGIT(d[1]) ) {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ }
+ }
+
+version_prescan_finish:
+ while (isSPACE(*d))
+ d++;
-#else
- return FALSE;
-#endif
+ if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
+ /* trailing non-numeric data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ if (sqv)
+ *sqv = qv;
+ if (swidth)
+ *swidth = width;
+ if (ssaw_decimal)
+ *ssaw_decimal = saw_decimal;
+ if (salpha)
+ *salpha = alpha;
+ return d;
}
/*
Function must be called with an already existing SV like
sv = newSV(0);
- s = scan_version(s,SV *sv, bool qv);
+ s = scan_version(s, SV *sv, bool qv);
Performs some preprocessing to the string to ensure that
it has the correct characteristics of a version. Flags the
object if it contains an underscore (which denotes this
-is a alpha version). The boolean qv denotes that the version
+is an alpha version). The boolean qv denotes that the version
should be interpreted as if it had multiple decimals, even if
it doesn't.
const char *start;
const char *pos;
const char *last;
- int saw_period = 0;
- int alpha = 0;
+ const char *errstr = NULL;
+ int saw_decimal = 0;
int width = 3;
+ bool alpha = FALSE;
+ bool vinf = FALSE;
AV * const av = newAV();
SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+
+ PERL_ARGS_ASSERT_SCAN_VERSION;
+
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
#ifndef NODEFAULT_SHAREKEYS
while (isSPACE(*s)) /* leading whitespace is OK */
s++;
- if (*s == 'v') {
- s++; /* get past 'v' */
- qv = 1; /* force quoted version processing */
- }
-
- start = last = pos = s;
-
- /* pre-scan the input string to check for decimals/underbars */
- while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
- {
- if ( *pos == '.' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
- saw_period++ ;
- last = pos;
+ last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
+ if (errstr) {
+ /* "undef" is a special case and not an error */
+ if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+ Perl_croak(aTHX_ "%s", errstr);
}
- else if ( *pos == '_' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
- alpha = 1;
- width = pos - last - 1; /* natural width of sub-version */
- }
- pos++;
}
- if ( alpha && !saw_period )
- Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
-
- if ( saw_period > 1 )
- qv = 1; /* force quoted version processing */
-
+ start = s;
+ if (*s == 'v')
+ s++;
pos = s;
if ( qv )
- hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
+ (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
if ( alpha )
- hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
+ (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
if ( !qv && width < 3 )
- hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+ (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
while (isDIGIT(*pos))
pos++;
/* this is atoi() that delimits on underscores */
const char *end = pos;
I32 mult = 1;
- I32 orev;
+ I32 orev;
/* the following if() will only be true after the decimal
* point of a version originally created with a bare
* floating point number, i.e. not quoted in any way
*/
- if ( !qv && s > start && saw_period == 1 ) {
+ if ( !qv && s > start && saw_decimal == 1 ) {
mult *= 100;
while ( s < end ) {
- orev = rev;
+ orev = rev;
rev += (*s - '0') * mult;
mult /= 10;
- if ( PERL_ABS(orev) > PERL_ABS(rev) )
- Perl_croak(aTHX_ "Integer overflow in version");
+ if ( (PERL_ABS(orev) > PERL_ABS(rev))
+ || (PERL_ABS(rev) > VERSION_MAX )) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version %d",VERSION_MAX);
+ s = end - 1;
+ rev = VERSION_MAX;
+ vinf = 1;
+ }
s++;
if ( *s == '_' )
s++;
}
else {
while (--end >= s) {
- orev = rev;
+ orev = rev;
rev += (*end - '0') * mult;
mult *= 10;
- if ( PERL_ABS(orev) > PERL_ABS(rev) )
- Perl_croak(aTHX_ "Integer overflow in version");
+ if ( (PERL_ABS(orev) > PERL_ABS(rev))
+ || (PERL_ABS(rev) > VERSION_MAX )) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version");
+ end = s - 1;
+ rev = VERSION_MAX;
+ vinf = 1;
+ }
}
}
}
/* Append revision */
av_push(av, newSViv(rev));
- if ( *pos == '.' && isDIGIT(pos[1]) )
+ if ( vinf ) {
+ s = last;
+ break;
+ }
+ else if ( *pos == '.' )
s = ++pos;
else if ( *pos == '_' && isDIGIT(pos[1]) )
s = ++pos;
+ else if ( *pos == ',' && isDIGIT(pos[1]) )
+ s = ++pos;
else if ( isDIGIT(*pos) )
s = pos;
else {
Compiler in question is:
gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
for ( len = 2 - len; len > 0; len-- )
- av_push((AV *)sv, newSViv(0));
+ av_push(MUTABLE_AV(sv), newSViv(0));
*/
len = 2 - len;
while (len-- > 0)
av_push(av, newSViv(0));
}
- if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
+ /* need to save off the current version string for later */
+ if ( vinf ) {
+ SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
+ (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+ (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
+ }
+ else if ( s > start ) {
+ SV * orig = newSVpvn(start,s-start);
+ if ( qv && saw_decimal == 1 && *start != 'v' ) {
+ /* need to insert a v to be consistent */
+ sv_insert(orig, 0, 0, "v", 1);
+ }
+ (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+ }
+ else {
+ (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
av_push(av, newSViv(0));
+ }
/* And finally, store the AV in the hash */
- hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+ (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
+
+ /* fix RT#19517 - special case 'undef' as string */
+ if ( *s == 'u' && strEQ(s,"undef") ) {
+ s += 5;
+ }
+
return s;
}
{
dVAR;
SV * const rv = newSV(0);
+ PERL_ARGS_ASSERT_NEW_VERSION;
if ( sv_derived_from(ver,"version") ) /* can just copy directly */
{
I32 key;
ver = SvRV(ver);
/* Begin copying all of the elements */
- if ( hv_exists((HV *)ver, "qv", 2) )
- hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
+ if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
+ (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
- if ( hv_exists((HV *)ver, "alpha", 5) )
- hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
+ if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
+ (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
- if ( hv_exists((HV*)ver, "width", 5 ) )
+ if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
+ {
+ const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
+ (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+ }
+
+ if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
{
- const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
- hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+ SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+ (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
}
- sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
+ sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
/* This will get reblessed later if a derived class*/
for ( key = 0; key <= av_len(sav); key++ )
{
av_push(av, newSViv(rev));
}
- hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+ (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
return rv;
}
#ifdef SvVOK
{
- const MAGIC* const mg = SvVOK(ver);
+ const MAGIC* const mg = SvVSTRING_mg(ver);
if ( mg ) { /* already a v-string */
const STRLEN len = mg->mg_len;
char * const version = savepvn( (const char*)mg->mg_ptr, len);
sv_setpvn(rv,version,len);
+ /* this is for consistency with the pure Perl class */
+ if ( isDIGIT(*version) )
+ sv_insert(rv, 0, 0, "v", 1);
Safefree(version);
}
else {
}
}
#endif
- return upg_version(rv);
+ return upg_version(rv, FALSE);
}
/*
In-place upgrade of the supplied SV to a version object.
- SV *sv = upg_version(SV *sv);
+ SV *sv = upg_version(SV *sv, bool qv);
-Returns a pointer to the upgraded SV.
+Returns a pointer to the upgraded SV. Set the boolean qv if you want
+to force this SV to be interpreted as an "extended" version.
=cut
*/
SV *
-Perl_upg_version(pTHX_ SV *ver)
+Perl_upg_version(pTHX_ SV *ver, bool qv)
{
const char *version, *s;
- bool qv = 0;
#ifdef SvVOK
const MAGIC *mg;
#endif
- if ( SvNOK(ver) ) /* may get too much accuracy */
+ PERL_ARGS_ASSERT_UPG_VERSION;
+
+ if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
{
+ /* may get too much accuracy */
char tbuf[64];
- const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+ char *loc = setlocale(LC_NUMERIC, "C");
+#endif
+ STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+ setlocale(LC_NUMERIC, loc);
+#endif
+ while (tbuf[len-1] == '0' && len > 0) len--;
+ if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
version = savepvn(tbuf, len);
}
#ifdef SvVOK
- else if ( (mg = SvVOK(ver)) ) { /* already a v-string */
+ else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
- qv = 1;
+ qv = TRUE;
}
#endif
else /* must be a string or something like a string */
{
- version = savepv(SvPV_nolen(ver));
+ STRLEN len;
+ version = savepv(SvPV(ver,len));
+#ifndef SvVOK
+# if PERL_VERSION > 5
+ /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
+ if ( len >= 3 && !instr(version,".") && !instr(version,"_")
+ && !(*version == 'u' && strEQ(version, "undef"))
+ && (*version < '0' || *version > '9') ) {
+ /* may be a v-string */
+ SV * const nsv = sv_newmortal();
+ const char *nver;
+ const char *pos;
+ int saw_decimal = 0;
+ sv_setpvf(nsv,"v%vd",ver);
+ pos = nver = savepv(SvPV_nolen(nsv));
+
+ /* scan the resulting formatted string */
+ pos++; /* skip the leading 'v' */
+ while ( *pos == '.' || isDIGIT(*pos) ) {
+ if ( *pos == '.' )
+ saw_decimal++ ;
+ pos++;
+ }
+
+ /* is definitely a v-string */
+ if ( saw_decimal >= 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ }
+# endif
+#endif
}
+
s = scan_version(version, ver, qv);
if ( *s != '\0' )
- if(ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Version string '%s' contains invalid data; "
- "ignoring: '%s'", version, s);
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Version string '%s' contains invalid data; "
+ "ignoring: '%s'", version, s);
Safefree(version);
return ver;
}
Perl_vverify(pTHX_ SV *vs)
{
SV *sv;
+
+ PERL_ARGS_ASSERT_VVERIFY;
+
if ( SvROK(vs) )
vs = SvRV(vs);
/* see if the appropriate elements exist */
if ( SvTYPE(vs) == SVt_PVHV
- && hv_exists((HV*)vs, "version", 7)
- && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
+ && hv_exists(MUTABLE_HV(vs), "version", 7)
+ && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
&& SvTYPE(sv) == SVt_PVAV )
return TRUE;
else
I32 i, len, digit;
int width;
bool alpha = FALSE;
- SV * const sv = newSV(0);
+ SV *sv;
AV *av;
+
+ PERL_ARGS_ASSERT_VNUMIFY;
+
if ( SvROK(vs) )
vs = SvRV(vs);
Perl_croak(aTHX_ "Invalid version object");
/* see if various flags exist */
- if ( hv_exists((HV*)vs, "alpha", 5 ) )
+ if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
alpha = TRUE;
- if ( hv_exists((HV*)vs, "width", 5 ) )
- width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
+ if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
+ width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
else
width = 3;
/* attempt to retrieve the version array */
- if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
- sv_catpvs(sv,"0");
- return sv;
+ if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
+ return newSVpvs("0");
}
len = av_len(av);
if ( len == -1 )
{
- sv_catpvs(sv,"0");
- return sv;
+ return newSVpvs("0");
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
+ sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
for ( i = 1 ; i < len ; i++ )
{
digit = SvIV(*av_fetch(av, i, 0));
{
I32 i, len, digit;
bool alpha = FALSE;
- SV * const sv = newSV(0);
+ SV *sv;
AV *av;
+
+ PERL_ARGS_ASSERT_VNORMAL;
+
if ( SvROK(vs) )
vs = SvRV(vs);
if ( !vverify(vs) )
Perl_croak(aTHX_ "Invalid version object");
- if ( hv_exists((HV*)vs, "alpha", 5 ) )
+ if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
alpha = TRUE;
- av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
+ av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
len = av_len(av);
if ( len == -1 )
{
- sv_catpvs(sv,"");
- return sv;
+ return newSVpvs("");
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
+ sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
for ( i = 1 ; i < len ; i++ ) {
digit = SvIV(*av_fetch(av, i, 0));
Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
SV *
Perl_vstringify(pTHX_ SV *vs)
{
+ PERL_ARGS_ASSERT_VSTRINGIFY;
+
if ( SvROK(vs) )
vs = SvRV(vs);
-
+
if ( !vverify(vs) )
Perl_croak(aTHX_ "Invalid version object");
- if ( hv_exists((HV *)vs, "qv", 2) )
- return vnormal(vs);
- else
- return vnumify(vs);
+ if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
+ SV *pv;
+ pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+ if ( SvPOK(pv) )
+ return newSVsv(pv);
+ else
+ return &PL_sv_undef;
+ }
+ else {
+ if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
+ return vnormal(vs);
+ else
+ return vnumify(vs);
+ }
}
/*
I32 left = 0;
I32 right = 0;
AV *lav, *rav;
+
+ PERL_ARGS_ASSERT_VCMP;
+
if ( SvROK(lhv) )
lhv = SvRV(lhv);
if ( SvROK(rhv) )
Perl_croak(aTHX_ "Invalid version object");
/* get the left hand term */
- lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
- if ( hv_exists((HV*)lhv, "alpha", 5 ) )
+ lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
+ if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
lalpha = TRUE;
/* and the right hand term */
- rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
- if ( hv_exists((HV*)rhv, "alpha", 5 ) )
+ rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
+ if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
ralpha = TRUE;
l = av_len(lav);
errno = ECONNABORTED;
tidy_up_and_fail:
{
- const int save_errno = errno;
+ dSAVE_ERRNO;
if (sockets[0] != -1)
PerlLIO_close(sockets[0]);
if (sockets[1] != -1)
PerlLIO_close(sockets[1]);
- errno = save_errno;
+ RESTORE_ERRNO;
return -1;
}
}
#endif
tidy_up_and_fail:
{
- const int save_errno = errno;
+ dSAVE_ERRNO;
if (listener != -1)
PerlLIO_close(listener);
if (connector != -1)
PerlLIO_close(connector);
if (acceptor != -1)
PerlLIO_close(acceptor);
- errno = save_errno;
+ RESTORE_ERRNO;
return -1;
}
}
void
Perl_sv_nosharing(pTHX_ SV *sv)
{
+ PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(sv);
+}
+
+/*
+
+=for apidoc sv_destroyable
+
+Dummy routine which reports that object can be destroyed when there is no
+sharing module present. It ignores its single SV argument, and returns
+'true'. Exists to avoid test for a NULL function pointer and because it
+could potentially warn under some level of strict-ness.
+
+=cut
+*/
+
+bool
+Perl_sv_destroyable(pTHX_ SV *sv)
+{
+ PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
+ return TRUE;
}
U32
const char *p = *popt;
U32 opt = 0;
+ PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
+
if (*p) {
if (isDIGIT(*p)) {
opt = (U32) atoi(p);
- while (isDIGIT(*p)) p++;
+ while (isDIGIT(*p))
+ p++;
if (*p && *p != '\n' && *p != '\r')
Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
}
opt |= PERL_UNICODE_LOCALE_FLAG; break;
case PERL_UNICODE_ARGV:
opt |= PERL_UNICODE_ARGV_FLAG; break;
+ case PERL_UNICODE_UTF8CACHEASSERT:
+ opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
default:
if (*p != '\n' && *p != '\r')
Perl_croak(aTHX_
UV myseed = 0;
if (s)
- while (isSPACE(*s)) s++;
+ while (isSPACE(*s))
+ s++;
if (s && isDIGIT(*s))
myseed = (UV)Atoul(s);
else
* help. Sum in another random number that will
* fill in the low bits. */
myseed +=
- (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
+ (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
#endif /* RANDBITS < (UVSIZE * 8) */
if (myseed == 0) { /* Superparanoia. */
myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
{
const char * const stashpv = CopSTASHPV(c);
const char * const name = HvNAME_get(hv);
+ PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
if (stashpv == name)
return TRUE;
#ifdef PERL_GLOBAL_STRUCT
+#define PERL_GLOBAL_STRUCT_INIT
+#include "opcode.h" /* the ppaddr and check */
+
struct perl_vars *
Perl_init_global_struct(pTHX)
{
struct perl_vars *plvarsp = NULL;
-#ifdef PERL_GLOBAL_STRUCT
-# define PERL_GLOBAL_STRUCT_INIT
-# include "opcode.h" /* the ppaddr and check */
+# ifdef PERL_GLOBAL_STRUCT
const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
# undef PERLVARIC
# undef PERLVARISC
# ifdef PERL_GLOBAL_STRUCT
- plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
+ plvarsp->Gppaddr =
+ (Perl_ppaddr_t*)
+ PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
if (!plvarsp->Gppaddr)
exit(1);
- plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
+ plvarsp->Gcheck =
+ (Perl_check_t*)
+ PerlMem_malloc(ncheck * sizeof(Perl_check_t));
if (!plvarsp->Gcheck)
exit(1);
Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
# ifdef PERL_SET_VARS
PERL_SET_VARS(plvarsp);
# endif
-# undef PERL_GLOBAL_STRUCT_INIT
-#endif
+# undef PERL_GLOBAL_STRUCT_INIT
+# endif
return plvarsp;
}
void
Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
{
-#ifdef PERL_GLOBAL_STRUCT
+ PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
+# ifdef PERL_GLOBAL_STRUCT
# ifdef PERL_UNSET_VARS
PERL_UNSET_VARS(plvarsp);
# endif
free(plvarsp->Gppaddr);
free(plvarsp->Gcheck);
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
+# ifdef PERL_GLOBAL_STRUCT_PRIVATE
free(plvarsp);
-# endif
-#endif
+# endif
+# endif
}
#endif /* PERL_GLOBAL_STRUCT */
#ifdef PERL_MEM_LOG
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+ * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
+ * given, and you supply your own implementation.
+ *
+ * The default implementation reads a single env var, PERL_MEM_LOG,
+ * expecting one or more of the following:
+ *
+ * \d+ - fd fd to write to : must be 1st (atoi)
+ * 'm' - memlog was PERL_MEM_LOG=1
+ * 's' - svlog was PERL_SV_LOG=1
+ * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
+ *
+ * This makes the logger controllable enough that it can reasonably be
+ * added to the system perl.
+ */
+
+/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
+ * the Perl_mem_log_...() will use (either via sprintf or snprintf).
+ */
#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
-Malloc_t
-Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
-{
-#ifdef PERL_MEM_LOG_STDERR
- /* We can't use PerlIO for obvious reasons. */
- char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
- const STRLEN len = my_sprintf(buf,
- "alloc: %s:%d:%s: %"IVdf" %"UVuf
- " %s = %"IVdf": %"UVxf"\n",
- filename, linenumber, funcname, n, typesize,
- typename, n * typesize, PTR2UV(newalloc));
- PerlLIO_write(2, buf, len);
+/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
+ * writes to. In the default logger, this is settable at runtime.
+ */
+#ifndef PERL_MEM_LOG_FD
+# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
+#endif
+
+#ifndef PERL_MEM_LOG_NOIMPL
+
+# ifdef DEBUG_LEAKING_SCALARS
+# define SV_LOG_SERIAL_FMT " [%lu]"
+# define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
+# else
+# define SV_LOG_SERIAL_FMT
+# define _SV_LOG_SERIAL_ARG(sv)
+# endif
+
+static void
+S_mem_log_common(enum mem_log_type mlt, const UV n,
+ const UV typesize, const char *type_name, const SV *sv,
+ Malloc_t oldalloc, Malloc_t newalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
+{
+ const char *pmlenv;
+
+ PERL_ARGS_ASSERT_MEM_LOG_COMMON;
+
+ pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
+ if (!pmlenv)
+ return;
+ if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
+ {
+ /* We can't use SVs or PerlIO for obvious reasons,
+ * so we'll use stdio and low-level IO instead. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+
+# ifdef HAS_GETTIMEOFDAY
+# define MEM_LOG_TIME_FMT "%10d.%06d: "
+# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
+ struct timeval tv;
+ gettimeofday(&tv, 0);
+# else
+# define MEM_LOG_TIME_FMT "%10d: "
+# define MEM_LOG_TIME_ARG (int)when
+ Time_t when;
+ (void)time(&when);
+# endif
+ /* If there are other OS specific ways of hires time than
+ * gettimeofday() (see ext/Time-HiRes), the easiest way is
+ * probably that they would be used to fill in the struct
+ * timeval. */
+ {
+ STRLEN len;
+ int fd = atoi(pmlenv);
+ if (!fd)
+ fd = PERL_MEM_LOG_FD;
+
+ if (strchr(pmlenv, 't')) {
+ len = my_snprintf(buf, sizeof(buf),
+ MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
+ PerlLIO_write(fd, buf, len);
+ }
+ switch (mlt) {
+ case MLT_ALLOC:
+ len = my_snprintf(buf, sizeof(buf),
+ "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",
+ 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",
+ 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",
+ mlt == MLT_NEW_SV ? "new" : "del",
+ filename, linenumber, funcname,
+ PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
+ break;
+ default:
+ len = 0;
+ }
+ PerlLIO_write(fd, buf, len);
+ }
+ }
+}
+#endif /* !PERL_MEM_LOG_NOIMPL */
+
+#ifndef PERL_MEM_LOG_NOIMPL
+# define \
+ mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
+ mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
+#else
+/* this is suboptimal, but bug compatible. User is providing their
+ own implemenation, but is getting these functions anyway, and they
+ do nothing. But _NOIMPL users should be able to cope or fix */
+# define \
+ mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
+ /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
#endif
+
+Malloc_t
+Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
+ Malloc_t newalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
+{
+ mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
+ NULL, NULL, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
-Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
-{
-#ifdef PERL_MEM_LOG_STDERR
- /* We can't use PerlIO for obvious reasons. */
- char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
- const STRLEN len = my_sprintf(buf, "realloc: %s:%d:%s: %"IVdf" %"UVuf
- " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
- filename, linenumber, funcname, n, typesize,
- typename, n * typesize, PTR2UV(oldalloc),
- PTR2UV(newalloc));
- PerlLIO_write(2, buf, len);
-#endif
+Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
+ Malloc_t oldalloc, Malloc_t newalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
+{
+ mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
+ NULL, oldalloc, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
-Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_free(Malloc_t oldalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
-#ifdef PERL_MEM_LOG_STDERR
- /* We can't use PerlIO for obvious reasons. */
- char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
- const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
- filename, linenumber, funcname,
- PTR2UV(oldalloc));
- PerlLIO_write(2, buf, len);
-#endif
+ mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
+ filename, linenumber, funcname);
return oldalloc;
}
+void
+Perl_mem_log_new_sv(const SV *sv,
+ const char *filename, const int linenumber,
+ const char *funcname)
+{
+ mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
+ filename, linenumber, funcname);
+}
+
+void
+Perl_mem_log_del_sv(const SV *sv,
+ const char *filename, const int linenumber,
+ const char *funcname)
+{
+ mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
+ filename, linenumber, funcname);
+}
+
#endif /* PERL_MEM_LOG */
/*
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);
}
#endif
+/*
+=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>.
+
+=cut
+*/
+int
+Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
+{
+ dTHX;
+ int retval;
+ va_list ap;
+ PERL_ARGS_ASSERT_MY_SNPRINTF;
+ va_start(ap, format);
+#ifdef HAS_VSNPRINTF
+ retval = vsnprintf(buffer, len, format, ap);
+#else
+ retval = vsprintf(buffer, format, ap);
+#endif
+ va_end(ap);
+ /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
+ if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+ Perl_croak(aTHX_ "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>.
+
+=cut
+*/
+int
+Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
+{
+ dTHX;
+ int retval;
+#ifdef NEED_VA_COPY
+ va_list apc;
+
+ PERL_ARGS_ASSERT_MY_VSNPRINTF;
+
+ Perl_va_copy(ap, apc);
+# ifdef HAS_VSNPRINTF
+ retval = vsnprintf(buffer, len, format, apc);
+# else
+ retval = vsprintf(buffer, format, apc);
+# endif
+#else
+# ifdef HAS_VSNPRINTF
+ retval = vsnprintf(buffer, len, format, ap);
+# else
+ retval = vsprintf(buffer, format, ap);
+# endif
+#endif /* #ifdef NEED_VA_COPY */
+ /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
+ if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+ Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
+ return retval;
+}
+
void
Perl_my_clearenv(pTHX)
{
(void)clearenv();
# elif defined(HAS_UNSETENV)
int bsiz = 80; /* Most envvar names will be shorter than this. */
- char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
+ int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
+ char *buf = (char*)safesysmalloc(bufsiz);
while (*environ != NULL) {
char *e = strchr(*environ, '=');
- int l = e ? e - *environ : strlen(*environ);
+ int l = e ? e - *environ : (int)strlen(*environ);
if (bsiz < l + 1) {
(void)safesysfree(buf);
- bsiz = l + 1;
- buf = (char*)safesysmalloc(bsiz * sizeof(char));
+ bsiz = l + 1; /* + 1 for the \0. */
+ buf = (char*)safesysmalloc(bufsiz);
}
- strncpy(buf, *environ, l);
- *(buf + l) = '\0';
+ memcpy(buf, *environ, l);
+ buf[l] = '\0';
(void)unsetenv(buf);
}
(void)safesysfree(buf);
#ifdef PERL_IMPLICIT_CONTEXT
-/* implements the MY_CXT_INIT macro. The first time a module is loaded,
+/* Implements the MY_CXT_INIT macro. The first time a module is loaded,
the global PL_my_cxt_index is incremented, and that value is assigned to
that module's static my_cxt_index (who's address is passed as an arg).
Then, for each interpreter this function is called for, it makes sure a
void* slot is available to hang the static data off, by allocating or
extending the interpreter's PL_my_cxt_list array */
+#ifndef PERL_GLOBAL_STRUCT_PRIVATE
void *
Perl_my_cxt_init(pTHX_ int *index, size_t size)
{
dVAR;
void *p;
+ 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 */
Zero(p, size, char);
return p;
}
+
+#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+
+int
+Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
+{
+ dVAR;
+ int index;
+
+ PERL_ARGS_ASSERT_MY_CXT_INDEX;
+
+ for (index = 0; index < PL_my_cxt_index; index++) {
+ const char *key = PL_my_cxt_keys[index];
+ /* try direct pointer compare first - there are chances to success,
+ * and it's much faster.
+ */
+ if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
+ return index;
+ }
+ return -1;
+}
+
+void *
+Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
+{
+ dVAR;
+ void *p;
+ int index;
+
+ PERL_ARGS_ASSERT_MY_CXT_INIT;
+
+ 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 */
+ if (PL_my_cxt_size <= index) {
+ 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 *);
+ }
+ else {
+ PL_my_cxt_size = 16;
+ Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+ Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+ }
+ for (i = old_size; i < PL_my_cxt_size; i++) {
+ PL_my_cxt_keys[i] = 0;
+ PL_my_cxt_list[i] = 0;
+ }
+ }
+ PL_my_cxt_keys[index] = my_cxt_key;
+ /* newSV() allocates one more than needed */
+ p = (void*)SvPVX(newSV(size-1));
+ PL_my_cxt_list[index] = p;
+ Zero(p, size, char);
+ return p;
+}
+#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+#ifndef HAS_STRLCAT
+Size_t
+Perl_my_strlcat(char *dst, const char *src, Size_t size)
+{
+ Size_t used, length, copy;
+
+ used = strlen(dst);
+ length = strlen(src);
+ if (size > 0 && used < size - 1) {
+ copy = (length >= size - used) ? size - used - 1 : length;
+ memcpy(dst + used, src, copy);
+ dst[used + copy] = '\0';
+ }
+ return used + length;
+}
+#endif
+
+#ifndef HAS_STRLCPY
+Size_t
+Perl_my_strlcpy(char *dst, const char *src, Size_t size)
+{
+ Size_t length, copy;
+
+ length = strlen(src);
+ if (size > 0) {
+ copy = (length >= size) ? size - 1 : length;
+ memcpy(dst, src, copy);
+ dst[copy] = '\0';
+ }
+ return length;
+}
#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. */
+long _ftol2( double dblSource ) { return _ftol( dblSource ); }
+#endif
+
+void
+Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
+{
+ dVAR;
+ SV * const dbsv = GvSVn(PL_DBsub);
+ /* We do not care about using sv to call CV;
+ * it's for informational purposes only.
+ */
+
+ PERL_ARGS_ASSERT_GET_DB_SUB;
+
+ save_item(dbsv);
+ if (!PERLDB_SUB_NN) {
+ GV * const gv = CvGV(cv);
+
+ if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ || strEQ(GvNAME(gv), "END")
+ || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+ !( (SvTYPE(*svp) == SVt_PVGV)
+ && (GvCV((const GV *)*svp) == cv) )))) {
+ /* Use GV from the stack as a fallback. */
+ /* GV is potentially non-unique, or contain different CV. */
+ SV * const tmp = newRV(MUTABLE_SV(cv));
+ sv_setsv(dbsv, tmp);
+ SvREFCNT_dec(tmp);
+ }
+ else {
+ gv_efullname3(dbsv, gv, NULL);
+ }
+ }
+ else {
+ const int type = SvTYPE(dbsv);
+ if (type < SVt_PVIV && type != SVt_IV)
+ sv_upgrade(dbsv, SVt_PVIV);
+ (void)SvIOK_on(dbsv);
+ SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
+ }
+}
+
+int
+Perl_my_dirfd(pTHX_ DIR * dir) {
+
+ /* Most dirfd implementations have problems when passed NULL. */
+ if(!dir)
+ return -1;
+#ifdef HAS_DIRFD
+ return dirfd(dir);
+#elif defined(HAS_DIR_DD_FD)
+ return dir->dd_fd;
+#else
+ Perl_die(aTHX_ PL_no_func, "dirfd");
+ /* NOT REACHED */
+ return 0;
+#endif
+}
+
+REGEXP *
+Perl_get_re_arg(pTHX_ SV *sv) {
+
+ if (sv) {
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if (SvROK(sv))
+ sv = MUTABLE_SV(SvRV(sv));
+ if (SvTYPE(sv) == SVt_REGEXP)
+ return (REGEXP*) sv;
+ }
+
+ return NULL;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff