* '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"]
+ * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
*/
/* This file contains assorted utility routines.
#include "EXTERN.h"
#define PERL_IN_UTIL_C
#include "perl.h"
+#include "reentr.h"
+
+#ifdef USE_PERLIO
+#include "perliol.h" /* For PerlIOUnix_refcnt */
+#endif
#ifndef PERL_MICRO
#include <signal.h>
int putenv(char *);
#endif
-#ifdef I_SYS_WAIT
-# include <sys/wait.h>
-#endif
-
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
-static char *
-S_write_no_mem(pTHX)
-{
- dVAR;
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
- NORETURN_FUNCTION_END;
-}
-
#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
# define ALWAYS_NEED_THX
#endif
size += sTHX;
#endif
#ifdef DEBUGGING
- if ((long)size < 0)
- Perl_croak_nocontext("panic: malloc");
+ if ((SSize_t)size < 0)
+ Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
#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) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
struct perl_memory_debug_header *const header
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
return ptr;
}
else {
if (PL_nomemok)
return NULL;
else {
- return write_no_mem();
+ croak_no_mem();
}
}
/*NOTREACHED*/
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool");
+ Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
}
assert(header->next->prev == header);
assert(header->prev->next == header);
}
#endif
#ifdef DEBUGGING
- if ((long)size < 0)
- Perl_croak_nocontext("panic: realloc");
+ if ((SSize_t)size < 0)
+ Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
#endif
ptr = (Malloc_t)PerlMem_realloc(where,size);
PERL_ALLOC_CHECK(ptr);
if (PL_nomemok)
return NULL;
else {
- return write_no_mem();
+ croak_no_mem();
}
}
/*NOTREACHED*/
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: free from wrong pool");
+ Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
}
if (!header->prev) {
Perl_croak_nocontext("panic: duplicate free");
}
- if (!(header->next) || header->next->prev != header
- || header->prev->next != header) {
- Perl_croak_nocontext("panic: bad free");
+ if (!(header->next))
+ Perl_croak_nocontext("panic: bad free, header->next==NULL");
+ if (header->next->prev != header || header->prev->next != header) {
+ Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
+ "header=%p, ->prev->next=%p",
+ header->next->prev, header,
+ header->prev->next);
}
/* Unlink us from the chain. */
header->next->prev = header->prev;
dTHX;
#endif
Malloc_t ptr;
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
MEM_SIZE total_size = 0;
+#endif
/* Even though calloc() for zero bytes is strange, be robust. */
- if (size && (count <= MEM_SIZE_MAX / size))
+ if (size && (count <= MEM_SIZE_MAX / size)) {
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
total_size = size * count;
+#endif
+ }
else
- Perl_croak_nocontext("%s", PL_memory_wrap);
+ Perl_croak_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);
+ Perl_croak_memory_wrap();
#endif
#ifdef HAS_64K_LIMIT
if (total_size > 0xffff) {
}
#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
- if ((long)size < 0 || (long)count < 0)
- Perl_croak_nocontext("panic: calloc");
+ if ((SSize_t)size < 0 || (SSize_t)count < 0)
+ Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+ (UV)size, (UV)count);
#endif
#ifdef PERL_TRACK_MEMPOOL
/* Have to use malloc() because we've added some space for our tracking
#endif
if (PL_nomemok)
return NULL;
- return write_no_mem();
+ croak_no_mem();
}
}
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
{
- register I32 tolen;
+ I32 tolen;
PERL_ARGS_ASSERT_DELIMCPY;
/* This routine was donated by Corey Satten. */
char *
-Perl_instr(register const char *big, register const char *little)
+Perl_instr(const char *big, const char *little)
{
- register I32 first;
PERL_ARGS_ASSERT_INSTR;
+ /* libc prior to 4.6.27 did not work properly on a NULL 'little' */
if (!little)
return (char*)big;
- first = *little++;
- if (!first)
- return (char*)big;
- while (*big) {
- register const char *s, *x;
- if (*big++ != first)
- continue;
- for (x=big,s=little; *s; /**/ ) {
- if (!*x)
- return NULL;
- if (*s != *x)
- break;
- else {
- s++;
- x++;
- }
- }
- if (!*s)
- return (char*)(big-1);
- }
- return NULL;
+ return strstr((char*)big, (char*)little);
}
-/* same as instr but allow embedded nulls */
+/* same as instr but allow embedded nulls. The end pointers point to 1 beyond
+ * the final character desired to be checked */
char *
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
/* reverse of the above--find last substring */
char *
-Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(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;
+ const char *bigbeg;
+ const I32 first = *little;
+ const char * const littleend = lend;
PERL_ARGS_ASSERT_RNINSTR;
bigbeg = big;
big = bigend - (littleend - little++);
while (big >= bigbeg) {
- register const char *s, *x;
+ const char *s, *x;
if (*big-- != first)
continue;
for (x=big+2,s=little; s < littleend; /**/ ) {
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
dVAR;
- register const U8 *s;
- register U32 i;
+ const U8 *s;
+ STRLEN i;
STRLEN len;
- U32 rarest = 0;
U32 frequency = 256;
+ MAGIC *mg;
+ PERL_DEB( STRLEN rarest = 0 );
PERL_ARGS_ASSERT_FBM_COMPILE;
+ if (isGV_with_GP(sv) || SvROK(sv))
+ return;
+
+ if (SvVALID(sv))
+ return;
+
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() */
if (mg && mg->mg_len >= 0)
mg->mg_len++;
}
- s = (U8*)SvPV_force_mutable(sv, len);
+ if (!SvPOK(sv) || SvNIOKp(sv) || SvIsCOW(sv))
+ s = (U8*)SvPV_force_mutable(sv, len);
+ else s = (U8 *)SvPV_mutable(sv, len);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
- SvUPGRADE(sv, SVt_PVGV);
+ SvUPGRADE(sv, SVt_PVMG);
SvIOK_off(sv);
SvNOK_off(sv);
SvVALID_on(sv);
+
+ /* "deep magic", the comment used to add. The use of MAGIC itself isn't
+ really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
+ to call SvVALID_off() if the scalar was assigned to.
+
+ The comment itself (and "deeper magic" below) date back to
+ 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
+ str->str_pok |= 2;
+ where the magic (presumably) was that the scalar had a BM table hidden
+ inside itself.
+
+ As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
+ the table instead of the previous (somewhat hacky) approach of co-opting
+ the string buffer and storing it after the string. */
+
+ assert(!mg_find(sv, PERL_MAGIC_bm));
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
+ assert(mg);
+
if (len > 2) {
- const unsigned char *sb;
+ /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
+ the BM table. */
const U8 mlen = (len>255) ? 255 : (U8)len;
- register U8 *table;
+ const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
+ U8 *table;
- 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 */
+ Newx(table, 256, U8);
memset((void*)table, mlen, 256);
+ mg->mg_ptr = (char *)table;
+ mg->mg_len = 256;
+
+ s += len - 1; /* last char */
i = 0;
- sb = s - mlen + 1; /* first char (maybe) */
while (s >= sb) {
if (table[*s] == mlen)
table[*s] = (U8)i;
s--, i++;
}
- } else {
- Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
}
- 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++) {
if (PL_freq[s[i]] < frequency) {
- rarest = i;
+ PERL_DEB( rarest = i );
frequency = PL_freq[s[i]];
}
}
- BmFLAGS(sv) = (U8)flags;
- BmRARE(sv) = s[rarest];
- BmPREVIOUS(sv) = rarest;
BmUSEFUL(sv) = 100; /* Initial value */
if (flags & FBMcf_TAIL)
SvTAIL_on(sv);
- DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
- BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
+ s[rarest], rarest));
}
/* 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<NULL> if the string can't be found. The C<sv>
+Returns the location of the SV in the string delimited by C<big> and
+C<bigend>. 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.
*/
char *
-Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
+Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
{
- register unsigned char *s;
+ unsigned char *s;
STRLEN l;
- register const unsigned char *little
- = (const unsigned char *)SvPV_const(littlestr,l);
- register STRLEN littlelen = l;
- register const I32 multiline = flags & FBMrf_MULTILINE;
+ const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
+ STRLEN littlelen = l;
+ const I32 multiline = flags & FBMrf_MULTILINE;
PERL_ARGS_ASSERT_FBM_INSTR;
return NULL;
}
- if (littlelen <= 2) { /* Special-cased */
-
- if (littlelen == 1) {
+ switch (littlelen) { /* Special cases for 0, 1 and 2 */
+ case 0:
+ return (char*)big; /* Cannot be SvTAIL! */
+ case 1:
if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
/* Know that bigend != big. */
if (bigend[-1] == '\n')
if (SvTAIL(littlestr))
return (char *) bigend;
return NULL;
- }
- if (!littlelen)
- return (char*)big; /* Cannot be SvTAIL! */
-
- /* littlelen is 2 */
+ case 2:
if (SvTAIL(littlestr) && !multiline) {
if (bigend[-1] == '\n' && bigend[-2] == *little)
return (char*)bigend - 2;
if (SvTAIL(littlestr) && (*bigend == *little))
return (char *)bigend; /* bigend is already decremented. */
return NULL;
+ default:
+ break; /* Only lengths 0 1 and 2 have special-case code. */
}
+
if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
s = bigend - littlelen;
if (s >= big && bigend[-1] == '\n' && *s == *little
return NULL;
{
- register const unsigned char * const table
- = little + littlelen + PERL_FBM_TABLE_OFFSET;
- register const unsigned char *oldlittle;
+ const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
+ const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
+ const unsigned char *oldlittle;
--littlelen; /* Last char found by table lookup */
little += littlelen; /* last char */
oldlittle = little;
if (s < bigend) {
- register I32 tmp;
+ I32 tmp;
top2:
if ((tmp = table[*s])) {
goto check_end;
}
else { /* less expensive than calling strncmp() */
- register unsigned char * const olds = s;
+ unsigned char * const olds = s;
tmp = littlelen;
}
check_end:
if ( s == bigend
- && (BmFLAGS(littlestr) & FBMcf_TAIL)
+ && SvTAIL(littlestr)
&& memEQ((char *)(bigend - littlelen),
(char *)(oldlittle - littlelen), littlelen) )
return (char*)bigend - littlelen;
}
}
-/* start_shift, end_shift are positive quantities which give offsets
- of ends of some substring of bigstr.
- If "last" we want the last occurrence.
- old_posp is the way of communication between consequent calls if
- the next call needs to find the .
- The initial *old_posp should be -1.
-
- Note that we take into account SvTAIL, so one can get extra
- optimizations if _ALL flag is set.
- */
-
-/* If SvTAIL is actually due to \Z or \z, this gives false positives
- if PL_multiline. In fact if !PL_multiline the authoritative answer
- is not supported yet. */
-
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
dVAR;
- register const unsigned char *big;
- register I32 pos;
- register I32 previous;
- register I32 first;
- register const unsigned char *little;
- register I32 stop_pos;
- 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)) {
- cant_find:
- if ( BmRARE(littlestr) == '\n'
- && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
- little = (const unsigned char *)(SvPVX_const(littlestr));
- littleend = little + SvCUR(littlestr);
- first = *little++;
- goto check_tail;
- }
- return NULL;
- }
-
- little = (const unsigned char *)(SvPVX_const(littlestr));
- littleend = little + SvCUR(littlestr);
- first = *little++;
- /* The value of pos we can start at: */
- previous = BmPREVIOUS(littlestr);
- big = (const unsigned char *)(SvPVX_const(bigstr));
- /* The value of pos we can stop at: */
- stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
- if (previous + start_shift > stop_pos) {
-/*
- stop_pos does not include SvTAIL in the count, so this check is incorrect
- (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
-*/
-#if 0
- if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
- goto check_tail;
-#endif
- return NULL;
- }
- while (pos < previous + start_shift) {
- if (!(pos += PL_screamnext[pos]))
- goto cant_find;
- }
- big -= previous;
- do {
- register const unsigned char *s, *x;
- if (pos >= stop_pos) break;
- if (big[pos] != first)
- continue;
- for (x=big+pos+1,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
- break;
- }
- }
- if (s == littleend) {
- *old_posp = pos;
- if (!last) return (char *)(big+pos);
- found = 1;
- }
- } while ( pos += PL_screamnext[pos] );
- if (last && found)
- return (char *)(big+(*old_posp));
- check_tail:
- if (!SvTAIL(littlestr) || (end_shift > 0))
- 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 */
- if (stop_pos == 0)
- return (char*)big;
- big -= stop_pos;
- if (*big == first
- && ((stop_pos == 1) ||
- memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
- return (char*)big;
+ PERL_UNUSED_ARG(bigstr);
+ PERL_UNUSED_ARG(littlestr);
+ PERL_UNUSED_ARG(start_shift);
+ PERL_UNUSED_ARG(end_shift);
+ PERL_UNUSED_ARG(old_posp);
+ PERL_UNUSED_ARG(last);
+
+ /* This function must only ever be called on a scalar with study magic,
+ but those do not happen any more. */
+ Perl_croak(aTHX_ "panic: screaminstr");
return NULL;
}
I32
-Perl_foldEQ(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, I32 len)
{
- register const U8 *a = (const U8 *)s1;
- register const U8 *b = (const U8 *)s2;
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
PERL_ARGS_ASSERT_FOLDEQ;
+ assert(len >= 0);
+
while (len--) {
if (*a != *b && *a != PL_fold[*b])
return 0;
}
return 1;
}
+I32
+Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
+{
+ /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
+ * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
+ * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
+ * does it check that the strings each have at least 'len' characters */
+
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
+
+ PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+
+ assert(len >= 0);
+
+ while (len--) {
+ if (*a != *b && *a != PL_fold_latin1[*b]) {
+ return 0;
+ }
+ a++, b++;
+ }
+ return 1;
+}
/*
=for apidoc foldEQ_locale
*/
I32
-Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
{
dVAR;
- register const U8 *a = (const U8 *)s1;
- register const U8 *b = (const U8 *)s2;
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
+ assert(len >= 0);
+
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
return 0;
*/
char *
-Perl_savepvn(pTHX_ const char *pv, register I32 len)
+Perl_savepvn(pTHX_ const char *pv, I32 len)
{
- register char *newaddr;
+ char *newaddr;
PERL_UNUSED_CONTEXT;
+ assert(len >= 0);
+
Newx(newaddr,len+1,char);
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
if (pv) {
char *
Perl_savesharedpv(pTHX_ const char *pv)
{
- register char *newaddr;
+ char *newaddr;
STRLEN pvlen;
if (!pv)
return NULL;
pvlen = strlen(pv)+1;
newaddr = (char*)PerlMemShared_malloc(pvlen);
if (!newaddr) {
- return write_no_mem();
+ croak_no_mem();
}
return (char*)memcpy(newaddr, pv, pvlen);
}
{
char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
- PERL_ARGS_ASSERT_SAVESHAREDPVN;
+ /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
if (!newaddr) {
- return write_no_mem();
+ croak_no_mem();
}
newaddr[len] = '\0';
return (char*)memcpy(newaddr, pv, len);
{
STRLEN len;
const char * const pv = SvPV_const(sv, len);
- register char *newaddr;
+ char *newaddr;
PERL_ARGS_ASSERT_SAVESVPV;
return (char *) CopyD(pv,newaddr,len,char);
}
+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+ STRLEN len;
+ const char * const pv = SvPV_const(sv, len);
+
+ PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+ return savesharedpvn(pv, len);
+}
/* the SV for Perl_form() and mess() is not kept in an arena */
SV *sv;
XPVMG *any;
- if (!PL_dirty)
+ if (PL_phase != PERL_PHASE_DESTRUCT)
return newSVpvs_flags("", SVs_TEMP);
if (PL_mess_sv)
if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
&& IoLINES(GvIOp(PL_last_in_gv)))
{
+ STRLEN l;
const bool line_mode = (RsSIMPLE(PL_rs) &&
- 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),
+ *SvPV_const(PL_rs,l) == '\n' && l == 1);
+ Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
+ SVfARG(PL_last_in_gv == PL_argvgv
+ ? &PL_sv_no
+ : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
- if (PL_dirty)
+ if (PL_phase == PERL_PHASE_DESTRUCT)
sv_catpvs(sv, " during global destruction");
sv_catpvs(sv, ".\n");
}
if (PL_stderrgv && SvREFCNT(PL_stderrgv)
&& (io = GvIO(PL_stderrgv))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
- {
- dSP;
- ENTER;
- SAVETMPS;
-
- save_re_context();
- SAVESPTR(PL_stderrgv);
- PL_stderrgv = NULL;
-
- PUSHSTACKi(PERLSI_MAGIC);
-
- PUSHMARK(SP);
- EXTEND(SP,2);
- PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
- PUSHs(msv);
- PUTBACK;
- call_method("PRINT", G_SCALAR);
-
- POPSTACK;
- FREETMPS;
- LEAVE;
- }
+ Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
+ G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
else {
#ifdef USE_SFIO
/* SFIO can really mess with your 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);
+ do_print(msv, serr);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
RESTORE_ERRNO;
{
PERL_ARGS_ASSERT_DIE_SV;
croak_sv(baseex);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
return NULL;
}
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
va_end(args);
return NULL;
}
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
va_end(args);
return NULL;
}
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
va_end(args);
}
*/
void
-Perl_croak_no_modify(pTHX)
+Perl_croak_no_modify()
+{
+ Perl_croak_nocontext( "%s", PL_no_modify);
+}
+
+/* does not return, used in util.c perlio.c and win32.c
+ This is typically called when malloc returns NULL.
+*/
+void
+Perl_croak_no_mem()
+{
+ dTHX;
+
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, sizeof(PL_no_mem)-1);
+ my_exit(1);
+}
+
+/* saves machine code for a common noreturn idiom typically used in Newx*() */
+void
+Perl_croak_memory_wrap(void)
+{
+ Perl_croak_nocontext("%s",PL_memory_wrap);
+}
+
+
+/* does not return, used only in POPSTACK */
+void
+Perl_croak_popstack(void)
{
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ dTHX;
+ PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
+ my_exit(1);
}
/*
STRLEN *
Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
STRLEN size) {
- const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+ const MEM_SIZE len_wanted =
+ sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
PerlMemShared_realloc(buffer, len_wanted));
buffer[0] = size;
Copy(bits, (buffer + 1), size, char);
+ if (size < WARNsize)
+ Zero((char *)(buffer + 1) + size, WARNsize - size, char);
return buffer;
}
#ifndef PERL_USE_SAFE_PUTENV
if (!PL_use_safe_putenv) {
/* most putenv()s leak, so we manipulate environ directly */
- register I32 i;
- register const I32 len = strlen(nam);
+ I32 i;
+ const I32 len = strlen(nam);
int nlen, vlen;
/* where does it go? */
my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
-# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
+# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
# else
# if defined(HAS_UNSETENV)
if (val == NULL) {
- (void)unsetenv(nam);
+ if (environ) /* old glibc can crash with null environ */
+ (void)unsetenv(nam);
} else {
const int nlen = strlen(nam);
const int vlen = strlen(val);
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
- register char *envstr;
+ char *envstr;
const int nlen = strlen(nam);
int vlen;
#endif /* WIN32 || NETWARE */
-#endif /* !VMS && !EPOC*/
+#endif /* !VMS */
#ifdef UNLINK_ALL_VERSIONS
I32
/* this is a drop-in replacement for bcopy() */
#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
char *
-Perl_my_bcopy(register const char *from,register char *to,register I32 len)
+Perl_my_bcopy(const char *from, char *to, I32 len)
{
char * const retval = to;
PERL_ARGS_ASSERT_MY_BCOPY;
+ assert(len >= 0);
+
if (from - to >= 0) {
while (len--)
*to++ = *from++;
/* this is a drop-in replacement for memset() */
#ifndef HAS_MEMSET
void *
-Perl_my_memset(register char *loc, register I32 ch, register I32 len)
+Perl_my_memset(char *loc, I32 ch, I32 len)
{
char * const retval = loc;
PERL_ARGS_ASSERT_MY_MEMSET;
+ assert(len >= 0);
+
while (len--)
*loc++ = ch;
return retval;
/* this is a drop-in replacement for bzero() */
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
char *
-Perl_my_bzero(register char *loc, register I32 len)
+Perl_my_bzero(char *loc, I32 len)
{
char * const retval = loc;
PERL_ARGS_ASSERT_MY_BZERO;
+ assert(len >= 0);
+
while (len--)
*loc++ = 0;
return retval;
/* this is a drop-in replacement for memcmp() */
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
I32
-Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
+Perl_my_memcmp(const char *s1, const char *s2, I32 len)
{
- register const U8 *a = (const U8 *)s1;
- register const U8 *b = (const U8 *)s2;
- register I32 tmp;
+ const U8 *a = (const U8 *)s1;
+ const U8 *b = (const U8 *)s2;
+ I32 tmp;
PERL_ARGS_ASSERT_MY_MEMCMP;
+ assert(len >= 0);
+
while (len--) {
if ((tmp = *a++ - *b++))
return tmp;
#endif /* HAS_VPRINTF */
-#ifdef MYSWAP
-#if BYTEORDER != 0x4321
-short
-Perl_my_swap(pTHX_ short s)
-{
-#if (BYTEORDER & 1) == 0
- short result;
-
- result = ((s & 255) << 8) + ((s >> 8) & 255);
- return result;
-#else
- return s;
-#endif
-}
-
-long
-Perl_my_htonl(pTHX_ long l)
-{
- union {
- long result;
- char c[sizeof(long)];
- } u;
-
-#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
-#if BYTEORDER == 0x12345678
- u.result = 0;
-#endif
- u.c[0] = (l >> 24) & 255;
- u.c[1] = (l >> 16) & 255;
- u.c[2] = (l >> 8) & 255;
- u.c[3] = l & 255;
- return u.result;
-#else
-#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
- Perl_croak(aTHX_ "Unknown BYTEORDER\n");
-#else
- register I32 o;
- register I32 s;
-
- for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
- u.c[o & 0xf] = (l >> s) & 255;
- }
- return u.result;
-#endif
-#endif
-}
-
-long
-Perl_my_ntohl(pTHX_ long l)
-{
- union {
- long l;
- char c[sizeof(long)];
- } u;
-
-#if BYTEORDER == 0x1234
- u.c[0] = (l >> 24) & 255;
- u.c[1] = (l >> 16) & 255;
- u.c[2] = (l >> 8) & 255;
- u.c[3] = l & 255;
- return u.l;
-#else
-#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
- Perl_croak(aTHX_ "Unknown BYTEORDER\n");
-#else
- register I32 o;
- register I32 s;
-
- u.l = l;
- l = 0;
- for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
- l |= (u.c[o & 0xf] & 255) << s;
- }
- return l;
-#endif
-#endif
-}
-
-#endif /* BYTEORDER != 0x4321 */
-#endif /* MYSWAP */
-
-/*
- * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
- * If these functions are defined,
- * the BYTEORDER is neither 0x1234 nor 0x4321.
- * However, this is not assumed.
- * -DWS
- */
-
-#define HTOLE(name,type) \
- type \
- name (register type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- register U32 i; \
- register U32 s = 0; \
- for (i = 0; i < sizeof(u.c); i++, s += 8) { \
- u.c[i] = (n >> s) & 0xFF; \
- } \
- return u.value; \
- }
-
-#define LETOH(name,type) \
- type \
- name (register type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- register U32 i; \
- register U32 s = 0; \
- u.value = n; \
- n = 0; \
- for (i = 0; i < sizeof(u.c); i++, s += 8) { \
- n |= ((type)(u.c[i] & 0xFF)) << s; \
- } \
- return n; \
- }
-
-/*
- * Big-endian byte order functions.
- */
-
-#define HTOBE(name,type) \
- type \
- name (register type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- 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; \
- } \
- return u.value; \
- }
-
-#define BETOH(name,type) \
- type \
- name (register type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- 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) { \
- n |= ((type)(u.c[i] & 0xFF)) << s; \
- } \
- return n; \
- }
-
-/*
- * If we just can't do it...
- */
-
-#define NOT_AVAIL(name,type) \
- type \
- name (register type n) \
- { \
- Perl_croak_nocontext(#name "() not available"); \
- return n; /* not reached */ \
- }
-
-
-#if defined(HAS_HTOVS) && !defined(htovs)
-HTOLE(htovs,short)
-#endif
-#if defined(HAS_HTOVL) && !defined(htovl)
-HTOLE(htovl,long)
-#endif
-#if defined(HAS_VTOHS) && !defined(vtohs)
-LETOH(vtohs,short)
-#endif
-#if defined(HAS_VTOHL) && !defined(vtohl)
-LETOH(vtohl,long)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE16
-# if U16SIZE == 2
-HTOLE(Perl_my_htole16,U16)
-# else
-NOT_AVAIL(Perl_my_htole16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH16
-# if U16SIZE == 2
-LETOH(Perl_my_letoh16,U16)
-# else
-NOT_AVAIL(Perl_my_letoh16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE16
-# if U16SIZE == 2
-HTOBE(Perl_my_htobe16,U16)
-# else
-NOT_AVAIL(Perl_my_htobe16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH16
-# if U16SIZE == 2
-BETOH(Perl_my_betoh16,U16)
-# else
-NOT_AVAIL(Perl_my_betoh16,U16)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE32
-# if U32SIZE == 4
-HTOLE(Perl_my_htole32,U32)
-# else
-NOT_AVAIL(Perl_my_htole32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH32
-# if U32SIZE == 4
-LETOH(Perl_my_letoh32,U32)
-# else
-NOT_AVAIL(Perl_my_letoh32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE32
-# if U32SIZE == 4
-HTOBE(Perl_my_htobe32,U32)
-# else
-NOT_AVAIL(Perl_my_htobe32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH32
-# if U32SIZE == 4
-BETOH(Perl_my_betoh32,U32)
-# else
-NOT_AVAIL(Perl_my_betoh32,U32)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE64
-# if U64SIZE == 8
-HTOLE(Perl_my_htole64,U64)
-# else
-NOT_AVAIL(Perl_my_htole64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH64
-# if U64SIZE == 8
-LETOH(Perl_my_letoh64,U64)
-# else
-NOT_AVAIL(Perl_my_letoh64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE64
-# if U64SIZE == 8
-HTOBE(Perl_my_htobe64,U64)
-# else
-NOT_AVAIL(Perl_my_htobe64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH64
-# if U64SIZE == 8
-BETOH(Perl_my_betoh64,U64)
-# else
-NOT_AVAIL(Perl_my_betoh64,U64)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLES
-HTOLE(Perl_my_htoles,short)
-#endif
-#ifdef PERL_NEED_MY_LETOHS
-LETOH(Perl_my_letohs,short)
-#endif
-#ifdef PERL_NEED_MY_HTOBES
-HTOBE(Perl_my_htobes,short)
-#endif
-#ifdef PERL_NEED_MY_BETOHS
-BETOH(Perl_my_betohs,short)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLEI
-HTOLE(Perl_my_htolei,int)
-#endif
-#ifdef PERL_NEED_MY_LETOHI
-LETOH(Perl_my_letohi,int)
-#endif
-#ifdef PERL_NEED_MY_HTOBEI
-HTOBE(Perl_my_htobei,int)
-#endif
-#ifdef PERL_NEED_MY_BETOHI
-BETOH(Perl_my_betohi,int)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLEL
-HTOLE(Perl_my_htolel,long)
-#endif
-#ifdef PERL_NEED_MY_LETOHL
-LETOH(Perl_my_letohl,long)
-#endif
-#ifdef PERL_NEED_MY_HTOBEL
-HTOBE(Perl_my_htobel,long)
-#endif
-#ifdef PERL_NEED_MY_BETOHL
-BETOH(Perl_my_betohl,long)
-#endif
-
-void
-Perl_my_swabn(void *ptr, int n)
-{
- register char *s = (char *)ptr;
- 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;
- *e = tc;
- }
-}
-
PerlIO *
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(NETWARE) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
dVAR;
int p[2];
- register I32 This, that;
- register Pid_t pid;
+ I32 This, that;
+ Pid_t pid;
SV *sv;
I32 did_pipes = 0;
int pp[2];
PERL_FLUSHALL_FOR_CHILD;
This = (*mode == 'w');
that = !This;
- if (PL_tainting) {
+ if (TAINTING_get) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
int pid2, status;
PerlLIO_close(p[This]);
if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read");
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
}
/* 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(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
dVAR;
int p[2];
- register I32 This, that;
- register Pid_t pid;
+ I32 This, that;
+ Pid_t pid;
SV *sv;
const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
I32 did_pipes = 0;
#endif
This = (*mode == 'w');
that = !This;
- if (doexec && PL_tainting) {
+ if (doexec && TAINTING_get) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
sleep(5);
}
if (pid == 0) {
- GV* tmpgv;
#undef THIS
#undef THAT
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 THREADS_HAVE_PIDS
- PL_ppid = (IV)getppid();
-#endif
PL_forkprocess = 0;
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* we have no children */
int pid2, status;
PerlLIO_close(p[This]);
if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read");
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
return PerlIO_fdopen(p[This], mode);
}
#else
-#if defined(atarist) || defined(EPOC)
-FILE *popen();
-PerlIO *
-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;
- apparently not used
- */
- return PerlIO_importFILE(popen(cmd, mode), 0);
-}
-#else
#if defined(DJGPP)
FILE *djgpp_popen();
PerlIO *
}
#endif
#endif
-#endif
#endif /* !DOSISH */
dVAR;
#if defined(USE_ITHREADS)
/* locks must be held in locking order (if any) */
+# ifdef USE_PERLIO
+ MUTEX_LOCK(&PL_perlio_mutex);
+# endif
# ifdef MYMALLOC
MUTEX_LOCK(&PL_malloc_mutex);
# endif
dVAR;
#if defined(USE_ITHREADS)
/* locks must be released in same order as in atfork_lock() */
+# ifdef USE_PERLIO
+ MUTEX_UNLOCK(&PL_perlio_mutex);
+# endif
# ifdef MYMALLOC
MUTEX_UNLOCK(&PL_malloc_mutex);
# endif
#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(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
dVAR;
- Sigsave_t hstat, istat, qstat;
int status;
SV **svp;
Pid_t pid;
- Pid_t pid2;
+ Pid_t pid2 = 0;
bool close_failed;
dSAVEDERRNO;
+ const int fd = PerlIO_fileno(ptr);
- svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
+#ifdef USE_PERLIO
+ /* Find out whether the refcount is low enough for us to wait for the
+ child proc without blocking. */
+ const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
+#else
+ const bool should_wait = 1;
+#endif
+
+ svp = av_fetch(PL_fdpid,fd,TRUE);
pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
SvREFCNT_dec(*svp);
*svp = &PL_sv_undef;
#endif
close_failed = (PerlIO_close(ptr) == EOF);
SAVE_ERRNO;
-#ifdef UTS
- if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
-#endif
-#ifndef PERL_MICRO
- rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
- rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
- rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
-#endif
- do {
+ if (should_wait) do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
-#ifndef PERL_MICRO
- rsignal_restore(SIGHUP, &hstat);
- rsignal_restore(SIGINT, &istat);
- rsignal_restore(SIGQUIT, &qstat);
-#endif
if (close_failed) {
RESTORE_ERRNO;
return -1;
}
- return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
+ return(
+ should_wait
+ ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
+ : 0
+ );
}
#else
#if defined(__LIBCATAMOUNT__)
void
S_pidgone(pTHX_ Pid_t pid, int status)
{
- register SV *sv;
+ SV *sv;
sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
SvUPGRADE(sv,SVt_IV);
}
#endif
-#if defined(atarist) || defined(OS2) || defined(EPOC)
+#if defined(OS2)
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
#define PERL_REPEATCPY_LINEAR 4
void
-Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
{
PERL_ARGS_ASSERT_REPEATCPY;
+ assert(len >= 0);
+
+ if (count < 0)
+ Perl_croak_memory_wrap();
+
if (len == 1)
memset(to, *from, count);
else if (count) {
- register char *p = to;
- I32 items, linear, half;
+ char *p = to;
+ IV 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;
+ const char *q = from;
+ IV todo;
for (todo = len; todo > 0; todo--)
*p++ = *q++;
}
half = count / 2;
while (items <= half) {
- I32 size = items * len;
+ IV size = items * len;
memcpy(p, to, size);
p += size;
items *= 2;
const char *xfound = NULL;
char *xfailed = NULL;
char tmpbuf[MAXPATHLEN];
- register char *s;
+ char *s;
I32 len = 0;
int retval;
char *bufend;
-#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
+#if defined(DOSISH) && !defined(OS2)
# define SEARCH_EXTS ".bat", ".cmd", NULL
# define MAX_EXT_LEN 4
#endif
bufend = s + strlen(s);
while (s < bufend) {
-#if defined(atarist) || defined(DOSISH)
+# ifdef DOSISH
for (len = 0; *s
-# ifdef atarist
- && *s != ','
-# endif
&& *s != ';'; len++, s++) {
if (len < sizeof tmpbuf)
tmpbuf[len] = *s;
}
if (len < sizeof tmpbuf)
tmpbuf[len] = '\0';
-#else /* ! (atarist || DOSISH) */
+# else
s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
':',
&len);
-#endif /* ! (atarist || DOSISH) */
+# endif
if (s < bufend)
s++;
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
if (len
-# if defined(atarist) || defined(DOSISH)
+# ifdef DOSISH
&& tmpbuf[len - 1] != '/'
&& tmpbuf[len - 1] != '\\'
# endif
seen_dot = 1; /* Disable message. */
if (!xfound) {
if (flags & 1) { /* do or die? */
+ /* diag_listed_as: Can't execute %s */
Perl_croak(aTHX_ "Can't %s %s%s%s",
(xfailed ? "execute" : "find"),
(xfailed ? xfailed : scriptname),
#if defined(USE_ITHREADS)
# ifdef OLD_PTHREADS_API
pthread_addr_t t;
- if (pthread_getspecific(PL_thr_key, &t))
- Perl_croak_nocontext("panic: pthread_getspecific");
+ int error = pthread_getspecific(PL_thr_key, &t)
+ if (error)
+ Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
return (void*)t;
# else
# ifdef I_MACH_CTHREADS
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
# else
- if (pthread_setspecific(PL_thr_key, t))
- Perl_croak_nocontext("panic: pthread_setspecific");
+ {
+ const int error = pthread_setspecific(PL_thr_key, t);
+ if (error)
+ Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
+ }
# endif
#else
PERL_UNUSED_ARG(t);
MGVTBL*
Perl_get_vtbl(pTHX_ int vtbl_id)
{
- const MGVTBL* result;
PERL_UNUSED_CONTEXT;
- switch(vtbl_id) {
- case want_vtbl_sv:
- result = &PL_vtbl_sv;
- break;
- case want_vtbl_env:
- result = &PL_vtbl_env;
- break;
- case want_vtbl_envelem:
- result = &PL_vtbl_envelem;
- break;
- case want_vtbl_sig:
- result = &PL_vtbl_sig;
- break;
- case want_vtbl_sigelem:
- result = &PL_vtbl_sigelem;
- break;
- case want_vtbl_pack:
- result = &PL_vtbl_pack;
- break;
- case want_vtbl_packelem:
- result = &PL_vtbl_packelem;
- break;
- case want_vtbl_dbline:
- result = &PL_vtbl_dbline;
- break;
- case want_vtbl_isa:
- result = &PL_vtbl_isa;
- break;
- case want_vtbl_isaelem:
- result = &PL_vtbl_isaelem;
- break;
- case want_vtbl_arylen:
- result = &PL_vtbl_arylen;
- break;
- case want_vtbl_mglob:
- result = &PL_vtbl_mglob;
- break;
- case want_vtbl_nkeys:
- result = &PL_vtbl_nkeys;
- break;
- case want_vtbl_taint:
- result = &PL_vtbl_taint;
- break;
- case want_vtbl_substr:
- result = &PL_vtbl_substr;
- break;
- case want_vtbl_vec:
- result = &PL_vtbl_vec;
- break;
- case want_vtbl_pos:
- result = &PL_vtbl_pos;
- break;
- case want_vtbl_bm:
- result = &PL_vtbl_bm;
- break;
- case want_vtbl_fm:
- result = &PL_vtbl_fm;
- break;
- case want_vtbl_uvar:
- result = &PL_vtbl_uvar;
- break;
- case want_vtbl_defelem:
- result = &PL_vtbl_defelem;
- break;
- case want_vtbl_regexp:
- result = &PL_vtbl_regexp;
- break;
- case want_vtbl_regdata:
- result = &PL_vtbl_regdata;
- break;
- case want_vtbl_regdatum:
- result = &PL_vtbl_regdatum;
- break;
-#ifdef USE_LOCALE_COLLATE
- case want_vtbl_collxfrm:
- result = &PL_vtbl_collxfrm;
- break;
-#endif
- case want_vtbl_amagic:
- result = &PL_vtbl_amagic;
- break;
- case want_vtbl_amagicelem:
- result = &PL_vtbl_amagicelem;
- break;
- case want_vtbl_backref:
- result = &PL_vtbl_backref;
- break;
- case want_vtbl_utf8:
- result = &PL_vtbl_utf8;
- break;
- default:
- result = NULL;
- break;
- }
- return (MGVTBL*)result;
+ return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
+ ? NULL : PL_magic_vtables + vtbl_id;
}
I32
}
void
-Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
-{
- 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 =
- (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for %sput",
- name, direction);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for %sput", direction);
- }
- }
- else {
- const char *vile;
- I32 warn_type;
-
- if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
- vile = "closed";
- warn_type = WARN_CLOSED;
- }
- else {
- vile = "unopened";
- warn_type = WARN_UNOPENED;
- }
-
- 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);
- if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
- Perl_warner(
- aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle %s?)\n",
- func, pars, name
- );
- }
- else {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s", func, pars, vile, type);
- if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
- Perl_warner(
- aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle?)\n",
- func, pars
- );
- }
- }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
+{
+ if (ckWARN(WARN_IO)) {
+ HEK * const name
+ = gv && (isGV_with_GP(gv))
+ ? GvENAME_HEK((gv))
+ : NULL;
+ const char * const direction = have == '>' ? "out" : "in";
+
+ if (name && HEK_LEN(name))
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle %"HEKf" opened only for %sput",
+ name, direction);
+ else
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle opened only for %sput", direction);
}
}
-/* 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;
-
- May want to add eg, WARN_REGEX
-*/
-
-char
-Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
+void
+Perl_report_evil_fh(pTHX_ const GV *gv)
{
+ const IO *io = gv ? GvIO(gv) : NULL;
+ const PERL_BITFIELD16 op = PL_op->op_type;
+ const char *vile;
+ I32 warn_type;
- U8 result;
-
- if (! isASCII(source)) {
- Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
- }
-
- 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';
-
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "\"\\c%c\" more clearly written simply as \"%s\"",
- source,
- clearer);
- }
- }
-
- return result;
-}
-
-char *
-Perl_grok_bslash_o(pTHX_ const char *s, UV *uv, STRLEN *len, const bool output_warning)
-{
-
-/* Documentation to be supplied when interface nailed down finally
- * This returns NULL on success, otherwise a pointer to an internal constant
- * error message. On input:
- * s points to a string that begins with o, and the previous character was
- * a backslash.
- * uv points to a UV that will hold the output value
- * len will point to the next character in the string past the end of this
- * construct
- * output_warning says whether to output any warning messages, or suppress
- * them
- */
- char* e;
- STRLEN numbers_len;
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
- | PERL_SCAN_DISALLOW_PREFIX
- /* XXX Until the message is improved in grok_oct, handle errors
- * ourselves */
- | PERL_SCAN_SILENT_ILLDIGIT;
-
- PERL_ARGS_ASSERT_GROK_BSLASH_O;
-
-
- assert(*s == 'o');
- s++;
-
- if (*s != '{') {
- *len = 1; /* Move past the o */
- return "Missing braces on \\o{}";
- }
-
- e = strchr(s, '}');
- if (!e) {
- *len = 2; /* Move past the o{ */
- return "Missing right brace on \\o{";
+ if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+ vile = "closed";
+ warn_type = WARN_CLOSED;
}
-
- /* Return past the '}' no matter what is inside the braces */
- *len = e - s + 2; /* 2 = 1 for the o + 1 for the '}' */
-
- s++; /* Point to first digit */
-
- numbers_len = e - s;
- if (numbers_len == 0) {
- return "Number with no digits";
- }
-
- *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
- /* Note that if has non-octal, will ignore everything starting with that up
- * to the '}' */
-
- if (output_warning && numbers_len != (STRLEN) (e - s)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
- /* diag_listed_as: Non-octal character '%c'. Resolved as "%s" */
- "Non-octal character '%c'. Resolved as \"\\o{%.*s}\"",
- *(s + numbers_len),
- (int) numbers_len,
- s);
+ else {
+ vile = "unopened";
+ warn_type = WARN_UNOPENED;
+ }
+
+ if (ckWARN(warn_type)) {
+ SV * const name
+ = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
+ sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
+ 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 */
+ PL_op_desc[op]);
+ const char * const type =
+ (const char *)
+ (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+ ? "socket" : "filehandle");
+ const bool have_name = name && SvCUR(name);
+ Perl_warner(aTHX_ packWARN(warn_type),
+ "%s%s on %s %s%s%"SVf, func, pars, vile, type,
+ have_name ? " " : "",
+ SVfARG(have_name ? name : &PL_sv_no));
+ if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ Perl_warner(
+ aTHX_ packWARN(warn_type),
+ "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
+ func, pars, have_name ? " " : "",
+ SVfARG(have_name ? name : &PL_sv_no)
+ );
}
-
- return NULL;
}
/* To workaround core dumps from the uninitialised tm_zone we get the
* outside the scope for this routine. Since we convert back based on the
* same rules we used to build the yearday, you'll only get strange results
* for input which needed normalising, or for the 'odd' century years which
- * were leap years in the Julian calander but not in the Gregorian one.
+ * were leap years in the Julian calendar but not in the Gregorian one.
* I can live with that.
*
* This algorithm also fails to handle years before A.D. 1 gracefully, but
year = 1900 + ptm->tm_year;
month = ptm->tm_mon;
mday = ptm->tm_mday;
- /* allow given yday with no month & mday to dominate the result */
- if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
- month = 0;
- mday = 0;
- jday = 1 + ptm->tm_yday;
- }
- else {
- jday = 0;
- }
+ jday = 0;
if (month >= 2)
month+=2;
else
yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
yearday += 14*MONTH_TO_DAYS + 1;
ptm->tm_yday = jday - yearday;
- /* fix tm_wday if not overridden by caller */
- if ((unsigned)ptm->tm_wday > 6)
- ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
+ ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
}
char *
* back into. */
int
-Perl_getcwd_sv(pTHX_ register SV *sv)
+Perl_getcwd_sv(pTHX_ SV *sv)
{
#ifndef PERL_MICRO
dVAR;
/*
=for apidoc prescan_version
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing. Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+
=cut
*/
const char *
} /* end if dotted-decimal */
else
{ /* decimal versions */
+ int j = 0; /* may need this later */
/* special strict case for leading '.' or '0' */
if (strict) {
if (*d == '.') {
}
}
+ /* and we never support negative versions */
+ if ( *d == '-') {
+ BADVERSION(s,errstr,"Invalid version format (negative version number)");
+ }
+
/* consume all of the integer part */
while (isDIGIT(*d))
d++;
}
while (isDIGIT(*d)) {
- d++;
+ d++; j++;
if (*d == '.' && isDIGIT(d[-1])) {
if (alpha) {
BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
if ( ! isDIGIT(d[1]) ) {
BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
}
+ width = j;
d++;
alpha = TRUE;
}
const char *
Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
{
- const char *start;
+ const char *start = s;
const char *pos;
const char *last;
const char *errstr = NULL;
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 */
+ AV * av;
+ SV * hv;
PERL_ARGS_ASSERT_SCAN_VERSION;
- (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-
-#ifndef NODEFAULT_SHAREKEYS
- HvSHAREKEYS_on(hv); /* key-sharing on by default */
-#endif
-
while (isSPACE(*s)) /* leading whitespace is OK */
s++;
if (errstr) {
/* "undef" is a special case and not an error */
if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+ Safefree(start);
Perl_croak(aTHX_ "%s", errstr);
}
}
s++;
pos = s;
+ /* Now that we are through the prescan, start creating the object */
+ av = newAV();
+ hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+ (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
+
if ( qv )
(void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
if ( alpha )
(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
if ( !qv && width < 3 )
(void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
-
+
while (isDIGIT(*pos))
pos++;
if (!isALPHA(*pos)) {
dVAR;
SV * const rv = newSV(0);
PERL_ARGS_ASSERT_NEW_VERSION;
- if ( sv_derived_from(ver,"version") ) /* can just copy directly */
+ if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
+ /* can just copy directly */
{
I32 key;
AV * const av = newAV();
if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
-
+
if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
{
const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
{
+ STRLEN len;
+
/* may get too much accuracy */
char tbuf[64];
+ SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
+ char *buf;
#ifdef USE_LOCALE_NUMERIC
- char *loc = setlocale(LC_NUMERIC, "C");
+ char *loc = NULL;
+ if (! PL_numeric_standard) {
+ loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
+ }
#endif
- STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+ if (sv) {
+ Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
+ buf = SvPV(sv, len);
+ }
+ else {
+ len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+ buf = tbuf;
+ }
#ifdef USE_LOCALE_NUMERIC
- setlocale(LC_NUMERIC, loc);
+ if (loc) {
+ setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
+ }
#endif
- while (tbuf[len-1] == '0' && len > 0) len--;
- if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
- version = savepvn(tbuf, len);
+ while (buf[len-1] == '0' && len > 0) len--;
+ if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
+ version = savepvn(buf, len);
+ SvREFCNT_dec(sv);
}
#ifdef SvVOK
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
#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') ) {
+ if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
/* 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++;
- }
+ char *testv = (char *)version;
+ STRLEN tlen = len;
+ for (tlen=0; tlen < len; tlen++, testv++) {
+ /* if one of the characters is non-text assume v-string */
+ if (testv[0] < ' ') {
+ 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;
+ /* is definitely a v-string */
+ if ( saw_decimal >= 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ break;
+ }
}
}
# endif
/*
=for apidoc vverify
-Validates that the SV contains a valid version object.
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV). If
+the structure is valid, it returns the HV. If the structure is invalid,
+it returns NULL.
- bool vverify(SV *vobj);
+ SV *hv = vverify(sv);
Note that it only confirms the bare minimum structure (so as not to get
confused by derived classes which may contain additional hash entries):
=over 4
-=item * The SV contains a [reference to a] hash
+=item * The SV is an HV or a reference to an HV
=item * The hash contains a "version" key
-=item * The "version" key has [a reference to] an AV as its value
+=item * The "version" key has a reference to an AV as its value
=back
=cut
*/
-bool
+SV *
Perl_vverify(pTHX_ SV *vs)
{
SV *sv;
&& hv_exists(MUTABLE_HV(vs), "version", 7)
&& (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
&& SvTYPE(sv) == SVt_PVAV )
- return TRUE;
+ return vs;
else
- return FALSE;
+ return NULL;
}
/*
NOTE: you can pass either the object directly or the SV
contained within the RV.
+The SV returned has a refcount of 1.
+
=cut
*/
PERL_ARGS_ASSERT_VNUMIFY;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
/* see if various flags exist */
NOTE: you can pass either the object directly or the SV
contained within the RV.
+The SV returned has a refcount of 1.
+
=cut
*/
PERL_ARGS_ASSERT_VNORMAL;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
In order to maintain maximum compatibility with earlier versions
of Perl, this function will return either the floating point
notation or the multiple dotted notation, depending on whether
-the original version contained 1 or more dots, respectively
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.
=cut
*/
{
PERL_ARGS_ASSERT_VSTRINGIFY;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
PERL_ARGS_ASSERT_VCMP;
- if ( SvROK(lhv) )
- lhv = SvRV(lhv);
- if ( SvROK(rhv) )
- rhv = SvRV(rhv);
-
- if ( !vverify(lhv) )
- Perl_croak(aTHX_ "Invalid version object");
-
- if ( !vverify(rhv) )
+ /* extract the HVs from the objects */
+ lhv = vverify(lhv);
+ rhv = vverify(rhv);
+ if ( ! ( lhv && rhv ) )
Perl_croak(aTHX_ "Invalid version object");
/* get the left hand term */
Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
/* Stevens says that family must be AF_LOCAL, protocol 0.
I'm going to enforce that, then ignore it, and use TCP (or UDP). */
- dTHX;
+ dTHXa(NULL);
int listener = -1;
int connector = -1;
int acceptor = -1;
return S_socketpair_udp(fd);
#endif
+ aTHXa(PERL_GET_THX);
listener = PerlSock_socket(AF_INET, type, 0);
if (listener == -1)
return -1;
}
#else
/* In any case have a stub so that there's code corresponding
- * to the my_socketpair in global.sym. */
+ * to the my_socketpair in embed.fnc. */
int
Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
#ifdef HAS_SOCKETPAIR
opt = (U32) atoi(p);
while (isDIGIT(*p))
p++;
- if (*p && *p != '\n' && *p != '\r')
+ if (*p && *p != '\n' && *p != '\r') {
+ if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+ else
Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+ }
}
else {
for (; *p; p++) {
case PERL_UNICODE_UTF8CACHEASSERT:
opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
default:
- if (*p != '\n' && *p != '\r')
+ if (*p != '\n' && *p != '\r') {
+ if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+ else
Perl_croak(aTHX_
"Unknown Unicode option letter '%c'", *p);
+ }
}
}
}
else
opt = PERL_UNICODE_DEFAULT_FLAGS;
+ the_end_of_the_opts_parser:
+
if (opt & ~PERL_UNICODE_ALL_FLAGS)
Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
(UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
return opt;
}
+#ifdef VMS
+# include <starlet.h>
+#endif
+
U32
Perl_seed(pTHX)
{
#endif
U32 u;
#ifdef VMS
-# include <starlet.h>
/* when[] = (low 32 bits, high 32 bits) of time since epoch
* in 100-ns units, typically incremented ever 10 ms. */
unsigned int when[2];
return u;
}
-UV
-Perl_get_hash_seed(pTHX)
+void
+Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
{
dVAR;
- const char *s = PerlEnv_getenv("PERL_HASH_SEED");
- UV myseed = 0;
-
- if (s)
- while (isSPACE(*s))
- s++;
- if (s && isDIGIT(*s))
- myseed = (UV)Atoul(s);
- else
-#ifdef USE_HASH_SEED_EXPLICIT
- if (s)
-#endif
- {
- /* Compute a random seed */
- (void)seedDrand01((Rand_seed_t)seed());
- myseed = (UV)(Drand01() * (NV)UV_MAX);
-#if RANDBITS < (UVSIZE * 8)
- /* Since there are not enough randbits to to reach all
- * the bits of a UV, the low bits might need extra
- * help. Sum in another random number that will
- * fill in the low bits. */
- myseed +=
- (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. */
- if (myseed == 0)
- Perl_croak(aTHX_ "Your random numbers are not that random");
- }
- }
- PL_rehash_seed_set = TRUE;
-
- return myseed;
-}
+ const char *env_pv;
+ unsigned long i;
-#ifdef USE_ITHREADS
-bool
-Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
-{
- const char * const stashpv = CopSTASHPV(c);
- const char * const name = HvNAME_get(hv);
- PERL_UNUSED_CONTEXT;
- PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
+ PERL_ARGS_ASSERT_GET_HASH_SEED;
- if (stashpv == name)
- return TRUE;
- if (stashpv && name)
- if (strEQ(stashpv, name))
- return TRUE;
- return FALSE;
-}
+ env_pv= PerlEnv_getenv("PERL_HASH_SEED");
+
+ if ( env_pv )
+#ifndef USE_HASH_SEED_EXPLICIT
+ {
+ /* ignore leading spaces */
+ while (isSPACE(*env_pv))
+ env_pv++;
+#ifdef USE_PERL_PERTURB_KEYS
+ /* if they set it to "0" we disable key traversal randomization completely */
+ if (strEQ(env_pv,"0")) {
+ PL_hash_rand_bits_enabled= 0;
+ } else {
+ /* otherwise switch to deterministic mode */
+ PL_hash_rand_bits_enabled= 2;
+ }
#endif
+ /* ignore a leading 0x... if it is there */
+ if (env_pv[0] == '0' && env_pv[1] == 'x')
+ env_pv += 2;
+
+ for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
+ seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
+ if ( isXDIGIT(*env_pv)) {
+ seed_buffer[i] |= READ_XDIGIT(env_pv);
+ }
+ }
+ while (isSPACE(*env_pv))
+ env_pv++;
+ if (*env_pv && !isXDIGIT(*env_pv)) {
+ Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
+ }
+ /* should we check for unparsed crap? */
+ /* should we warn about unused hex? */
+ /* should we warn about insufficient hex? */
+ }
+ else
+#endif
+ {
+ (void)seedDrand01((Rand_seed_t)seed());
+
+ for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
+ seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
+ }
+ }
+#ifdef USE_PERL_PERTURB_KEYS
+ { /* initialize PL_hash_rand_bits from the hash seed.
+ * This value is highly volatile, it is updated every
+ * hash insert, and is used as part of hash bucket chain
+ * randomization and hash iterator randomization. */
+ PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
+ for( i = 0; i < sizeof(UV) ; i++ ) {
+ PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
+ PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
+ }
+ }
+ env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
+ if (env_pv) {
+ if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
+ PL_hash_rand_bits_enabled= 0;
+ } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
+ PL_hash_rand_bits_enabled= 1;
+ } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
+ PL_hash_rand_bits_enabled= 2;
+ } else {
+ Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
+ }
+ }
+#endif
+}
#ifdef PERL_GLOBAL_STRUCT
# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
-# undef PERLVARISC
-# define PERLVAR(var,type) /**/
-# define PERLVARA(var,n,type) /**/
-# define PERLVARI(var,type,init) plvarsp->var = init;
-# define PERLVARIC(var,type,init) plvarsp->var = init;
-# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
+# define PERLVAR(prefix,var,type) /**/
+# define PERLVARA(prefix,var,n,type) /**/
+# define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
+# define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
# include "perlvars.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
-# undef PERLVARISC
# ifdef PERL_GLOBAL_STRUCT
plvarsp->Gppaddr =
(Perl_ppaddr_t*)
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
+ own implementation, 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) \
int
Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
{
- dTHX;
int retval;
va_list ap;
PERL_ARGS_ASSERT_MY_SNPRINTF;
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");
+ /* vsprintf() shows failure with < 0 */
+ if (retval < 0
+#ifdef HAS_VSNPRINTF
+ /* vsnprintf() shows failure with >= len */
+ ||
+ (len > 0 && (Size_t)retval >= len)
+#endif
+ )
+ Perl_croak_nocontext("panic: my_snprintf buffer overflow");
return retval;
}
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;
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");
+ /* vsprintf() shows failure with < 0 */
+ if (retval < 0
+#ifdef HAS_VSNPRINTF
+ /* vsnprintf() shows failure with >= len */
+ ||
+ (len > 0 && (Size_t)retval >= len)
+#endif
+ )
+ Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
return retval;
}
(void)clearenv();
# elif defined(HAS_UNSETENV)
int bsiz = 80; /* Most envvar names will be shorter than this. */
- int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
- char *buf = (char*)safesysmalloc(bufsiz);
+ char *buf = (char*)safesysmalloc(bsiz);
while (*environ != NULL) {
char *e = strchr(*environ, '=');
int l = e ? e - *environ : (int)strlen(*environ);
if (bsiz < l + 1) {
(void)safesysfree(buf);
bsiz = l + 1; /* + 1 for the \0. */
- buf = (char*)safesysmalloc(bufsiz);
+ buf = (char*)safesysmalloc(bsiz);
}
memcpy(buf, *environ, l);
buf[l] = '\0';
#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
#endif /* PERL_IMPLICIT_CONTEXT */
+void
+Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+ STRLEN xs_len)
+{
+ SV *sv;
+ const char *vn = NULL;
+ SV *const module = PL_stack_base[ax];
+
+ PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
+
+ if (items >= 2) /* version supplied as bootstrap arg */
+ sv = PL_stack_base[ax + 1];
+ else {
+ /* XXX GV_ADDWARN */
+ vn = "XS_VERSION";
+ sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+ if (!sv || !SvOK(sv)) {
+ vn = "VERSION";
+ sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+ }
+ }
+ if (sv) {
+ SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
+ SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
+ ? sv : sv_2mortal(new_version(sv));
+ xssv = upg_version(xssv, 0);
+ if ( vcmp(pmsv,xssv) ) {
+ SV *string = vstringify(xssv);
+ SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+ " does not match ", module, string);
+
+ SvREFCNT_dec(string);
+ string = vstringify(pmsv);
+
+ if (vn) {
+ Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
+ string);
+ } else {
+ Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
+ }
+ SvREFCNT_dec(string);
+
+ Perl_sv_2mortal(aTHX_ xpt);
+ Perl_croak_sv(aTHX_ xpt);
+ }
+ }
+}
+
+void
+Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
+ STRLEN api_len)
+{
+ SV *xpt = NULL;
+ SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
+ SV *runver;
+
+ PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
+
+ /* This might croak */
+ compver = upg_version(compver, 0);
+ /* This should never croak */
+ runver = new_version(PL_apiversion);
+ if (vcmp(compver, runver)) {
+ SV *compver_string = vstringify(compver);
+ SV *runver_string = vstringify(runver);
+ xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
+ " of %"SVf" does not match %"SVf,
+ compver_string, module, runver_string);
+ Perl_sv_2mortal(aTHX_ xpt);
+
+ SvREFCNT_dec(compver_string);
+ SvREFCNT_dec(runver_string);
+ }
+ SvREFCNT_dec(runver);
+ if (xpt)
+ Perl_croak_sv(aTHX_ xpt);
+}
+
#ifndef HAS_STRLCAT
Size_t
Perl_my_strlcat(char *dst, const char *src, Size_t size)
long _ftol2( double dblSource ) { return _ftol( dblSource ); }
#endif
+PERL_STATIC_INLINE bool
+S_gv_has_usable_name(pTHX_ GV *gv)
+{
+ GV **gvp;
+ return GvSTASH(gv)
+ && HvENAME(GvSTASH(gv))
+ && (gvp = (GV **)hv_fetch(
+ GvSTASH(gv), GvNAME(gv),
+ GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
+ ))
+ && *gvp == gv;
+}
+
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;
+ const bool save_taint = TAINT_get;
+
+ /* When we are called from pp_goto (svp is null),
+ * we do not care about using dbsv to call CV;
* it's for informational purposes only.
*/
PERL_ARGS_ASSERT_GET_DB_SUB;
+ TAINT_set(FALSE);
save_item(dbsv);
if (!PERLDB_SUB_NN) {
- GV * const gv = CvGV(cv);
+ GV *gv = CvGV(cv);
- if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ if (!svp) {
+ gv_efullname3(dbsv, gv, NULL);
+ }
+ else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
- || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+ || ( /* Could be imported, and old sub redefined. */
+ (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
+ &&
!( (SvTYPE(*svp) == SVt_PVGV)
- && (GvCV((const GV *)*svp) == cv) )))) {
- /* Use GV from the stack as a fallback. */
+ && (GvCV((const GV *)*svp) == cv)
+ /* Use GV from the stack as a fallback. */
+ && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
+ )
+ )
+ ) {
/* 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);
+ sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
+ sv_catpvs(dbsv, "::");
+ sv_catpvn_flags(
+ dbsv, GvNAME(gv), GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
}
else {
(void)SvIOK_on(dbsv);
SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
}
+ TAINT_IF(save_taint);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(save_taint);
+#endif
}
int
return dir->dd_fd;
#else
Perl_die(aTHX_ PL_no_func, "dirfd");
- /* NOT REACHED */
+ assert(0); /* NOT REACHED */
return 0;
#endif
}
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/