X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/91152fc19d1c59a1213e39f74ac8a80f4a015f5e..7e0d5ad7c9cdb21b681e611b888acd41d34c4d05:/util.c diff --git a/util.c b/util.c index 9b11ada..8bd2094 100644 --- a/util.c +++ b/util.c @@ -12,7 +12,7 @@ * '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. @@ -25,6 +25,10 @@ #define PERL_IN_UTIL_C #include "perl.h" +#ifdef USE_PERLIO +#include "perliol.h" /* For PerlIOUnix_refcnt */ +#endif + #ifndef PERL_MICRO #include #ifndef SIG_ERR @@ -37,10 +41,6 @@ int putenv(char *); #endif -#ifdef I_SYS_WAIT -# include -#endif - #ifdef HAS_SELECT # ifdef I_SYS_SELECT # include @@ -70,12 +70,18 @@ S_write_no_mem(pTHX) 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) { @@ -88,12 +94,11 @@ Perl_safesysmalloc(MEM_SIZE size) 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 @@ -116,12 +121,18 @@ Perl_safesysmalloc(MEM_SIZE size) # 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(); +#ifndef ALWAYS_NEED_THX + dTHX; +#endif + if (PL_nomemok) + return NULL; + else { + return write_no_mem(); + } } /*NOTREACHED*/ } @@ -131,7 +142,9 @@ Perl_safesysmalloc(MEM_SIZE size) 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(); @@ -159,7 +172,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) = (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); @@ -174,8 +188,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) } #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); @@ -213,10 +227,15 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (ptr != NULL) { return ptr; } - else if (PL_nomemok) - return NULL; else { - return write_no_mem(); +#ifndef ALWAYS_NEED_THX + dTHX; +#endif + if (PL_nomemok) + return NULL; + else { + return write_no_mem(); + } } /*NOTREACHED*/ } @@ -226,7 +245,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t Perl_safesysfree(Malloc_t where) { -#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL) +#ifdef ALWAYS_NEED_THX dTHX; #else dVAR; @@ -240,14 +259,19 @@ Perl_safesysfree(Malloc_t where) = (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; @@ -268,13 +292,20 @@ Perl_safesysfree(Malloc_t where) Malloc_t Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { +#ifdef ALWAYS_NEED_THX 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); #ifdef PERL_TRACK_MEMPOOL @@ -291,8 +322,9 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) } #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 @@ -330,9 +362,14 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #endif return ptr; } - else if (PL_nomemok) - return NULL; - 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 @@ -371,7 +408,7 @@ Free_t Perl_mfree (Malloc_t where) char * 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; + I32 tolen; PERL_ARGS_ASSERT_DELIMCPY; @@ -401,7 +438,7 @@ Perl_delimcpy(register char *to, register const char *toend, register const char char * Perl_instr(register const char *big, register const char *little) { - register I32 first; + I32 first; PERL_ARGS_ASSERT_INSTR; @@ -411,7 +448,7 @@ Perl_instr(register const char *big, register const char *little) if (!first) return (char*)big; while (*big) { - register const char *s, *x; + const char *s, *x; if (*big++ != first) continue; for (x=big,s=little; *s; /**/ ) { @@ -430,7 +467,8 @@ Perl_instr(register const char *big, register const char *little) return NULL; } -/* 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) @@ -461,9 +499,9 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char char * 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; + const char *bigbeg; + const I32 first = *little; + const char * const littleend = lend; PERL_ARGS_ASSERT_RNINSTR; @@ -472,7 +510,7 @@ Perl_rninstr(register const char *big, const char *bigend, const char *little, c 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; /**/ ) { @@ -510,14 +548,21 @@ void 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; + STRLEN rarest = 0; U32 frequency = 256; + MAGIC *mg; PERL_ARGS_ASSERT_FBM_COMPILE; + if (isGV_with_GP(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() */ @@ -527,31 +572,49 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s = (U8*)SvPV_force_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++) { @@ -560,14 +623,13 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) 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", + BmRARE(sv), BmPREVIOUS(sv))); } /* If SvTAIL(littlestr), it has a fake '\n' at end. */ @@ -577,8 +639,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) /* =for apidoc fbm_instr -Returns the location of the SV in the string delimited by C and -C. It returns C if the string can't be found. The C +Returns the location of the SV in the string delimited by C and +C. It returns C if the string can't be found. The C does not have to be fbm_compiled, but the search will not be as fast then. @@ -588,12 +650,11 @@ then. char * Perl_fbm_instr(pTHX_ unsigned char *big, register 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; @@ -607,9 +668,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit 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') @@ -625,11 +687,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit 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; @@ -689,7 +747,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit 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 @@ -727,9 +788,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit 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 */ @@ -737,7 +798,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit little += littlelen; /* last char */ oldlittle = little; if (s < bigend) { - register I32 tmp; + I32 tmp; top2: if ((tmp = table[*s])) { @@ -746,7 +807,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit goto check_end; } else { /* less expensive than calling strncmp() */ - register unsigned char * const olds = s; + unsigned char * const olds = s; tmp = littlelen; @@ -764,7 +825,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } check_end: if ( s == bigend - && (BmFLAGS(littlestr) & FBMcf_TAIL) + && SvTAIL(littlestr) && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; @@ -772,143 +833,97 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } } -/* 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; + 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; +} - 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 +=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 */ -#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; - return NULL; -} + I32 -Perl_ibcmp(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; + const U8 *a = (const U8 *)s1; + const U8 *b = (const U8 *)s2; - PERL_ARGS_ASSERT_IBCMP; + PERL_ARGS_ASSERT_FOLDEQ; while (len--) { if (*a != *b && *a != PL_fold[*b]) - return 1; + return 0; a++,b++; } - return 0; + return 1; +} +I32 +Perl_foldEQ_latin1(const char *s1, const char *s2, register 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; + + while (len--) { + if (*a != *b && *a != PL_fold_latin1[*b]) { + return 0; + } + a++, b++; + } + return 1; } +/* +=for apidoc foldEQ_locale + +Returns true if the leading len bytes of the strings s1 and s2 are the same +case-insensitively in the current locale; false otherwise. + +=cut +*/ + I32 -Perl_ibcmp_locale(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; + const U8 *a = (const U8 *)s1; + const U8 *b = (const U8 *)s2; - PERL_ARGS_ASSERT_IBCMP_LOCALE; + 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 */ @@ -956,7 +971,7 @@ the new string can be freed with the C function. char * Perl_savepvn(pTHX_ const char *pv, register I32 len) { - register char *newaddr; + char *newaddr; PERL_UNUSED_CONTEXT; Newx(newaddr,len+1,char); @@ -982,7 +997,7 @@ which is shared between threads. char * Perl_savesharedpv(pTHX_ const char *pv) { - register char *newaddr; + char *newaddr; STRLEN pvlen; if (!pv) return NULL; @@ -1009,7 +1024,7 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) { char *const newaddr = (char*)PerlMemShared_malloc(len + 1); - PERL_ARGS_ASSERT_SAVESHAREDPVN; + /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ if (!newaddr) { return write_no_mem(); @@ -1032,7 +1047,7 @@ Perl_savesvpv(pTHX_ SV *sv) { STRLEN len; const char * const pv = SvPV_const(sv, len); - register char *newaddr; + char *newaddr; PERL_ARGS_ASSERT_SAVESVPV; @@ -1041,6 +1056,25 @@ Perl_savesvpv(pTHX_ SV *sv) return (char *) CopyD(pv,newaddr,len,char); } +/* +=for apidoc savesharedsvpv + +A version of C 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 */ @@ -1051,7 +1085,7 @@ S_mess_alloc(pTHX) SV *sv; XPVMG *any; - if (!PL_dirty) + if (PL_phase != PERL_PHASE_DESTRUCT) return newSVpvs_flags("", SVs_TEMP); if (PL_mess_sv) @@ -1124,6 +1158,21 @@ Perl_vform(pTHX_ const char *pat, va_list *args) 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. + +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, ...) @@ -1186,15 +1235,57 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o) 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 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 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 is true, then the function is permitted (but not +required) to modify and return C 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(); + SV *sv; - PERL_ARGS_ASSERT_VMESS; + 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); + } - sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { /* * Try and find the file and line for PL_op. This will usually be @@ -1214,20 +1305,51 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) 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"); } return sv; } +/* +=for apidoc Am|SV *|vmess|const char *pat|va_list *args + +C and C 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. + +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_ SV* msv) { @@ -1240,38 +1362,16 @@ Perl_write_to_stderr(pTHX_ SV* msv) 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, "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; @@ -1279,10 +1379,26 @@ Perl_write_to_stderr(pTHX_ SV* msv) } } -/* 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_ SV *message, bool warn) +S_invoke_exception_hook(pTHX_ SV *ex, bool warn) { dVAR; HV *stash; @@ -1292,7 +1408,8 @@ S_vdie_common(pTHX_ SV *message, bool warn) /* sv_2cv might call Perl_croak() or Perl_warner() */ SV * const oldhook = *hook; - assert(oldhook); + if (!oldhook) + return FALSE; ENTER; SAVESPTR(*hook); @@ -1301,7 +1418,7 @@ S_vdie_common(pTHX_ SV *message, bool warn) LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; - SV *msg; + SV *exarg; ENTER; save_re_context(); @@ -1309,18 +1426,13 @@ S_vdie_common(pTHX_ SV *message, bool warn) SAVESPTR(*hook); *hook = NULL; } - if (warn || message) { - msg = newSVsv(message); - 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(MUTABLE_SV(cv), G_DISCARD); POPSTACK; @@ -1330,81 +1442,147 @@ S_vdie_common(pTHX_ SV *message, bool warn) return FALSE; } -STATIC SV * -S_vdie_croak_common(pTHX_ const char* pat, va_list* args) -{ - dVAR; - SV *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 = sv_mortalcopy(PL_errors); - SvCUR_set(PL_errors, 0); - } - else - message = msv; - } - else { - message = NULL; - } +Behaves the same as L, except for the return type. +It should be used only where the C return type is required. +The function never actually returns. - if (PL_diehook) { - S_vdie_common(aTHX_ message, FALSE); - } - return message; -} +=cut +*/ -static OP * -S_vdie(pTHX_ const char* pat, va_list *args) +OP * +Perl_die_sv(pTHX_ SV *baseex) { - dVAR; - SV *message; - - message = vdie_croak_common(pat, args); - - die_where(message); - /* NOTREACHED */ + PERL_ARGS_ASSERT_DIE_SV; + croak_sv(baseex); + assert(0); /* NOTREACHED */ return NULL; } +/* +=for apidoc Am|OP *|die|const char *pat|... + +Behaves the same as L, except for the return type. +It should be used only where the C return type is required. +The function never actually returns. + +=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); + assert(0); /* 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); + assert(0); /* 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 function. + +C 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. + +The error message or object will be used as an exception, by default +returning control to the nearest enclosing C, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C +function never returns normally. + +To die with a simple string message, the L function may be +more convenient. + +=cut +*/ + void -Perl_vcroak(pTHX_ const char* pat, va_list *args) +Perl_croak_sv(pTHX_ SV *baseex) { - dVAR; - SV *msv; + SV *ex = with_queued_errors(mess_sv(baseex, 0)); + PERL_ARGS_ASSERT_CROAK_SV; + invoke_exception_hook(ex, FALSE); + die_unwind(ex); +} + +/* +=for apidoc Am|void|vcroak|const char *pat|va_list *args + +This is an XS interface to Perl's C function. + +C and C 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. + +The error message will be used as an exception, by default +returning control to the nearest enclosing C, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C +function never returns normally. + +For historical reasons, if C is null then the contents of C +(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 function, which does not involve clobbering C. - msv = S_vdie_croak_common(aTHX_ pat, args); +=cut +*/ - die_where(msv); +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 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. + +The error message will be used as an exception, by default +returning control to the nearest enclosing C, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C +function never returns normally. + +For historical reasons, if C is null then the contents of C +(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 function, which does not involve clobbering C. + +=cut +*/ + #if defined(PERL_IMPLICIT_CONTEXT) void Perl_croak_nocontext(const char *pat, ...) @@ -1413,56 +1591,110 @@ Perl_croak_nocontext(const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ +void +Perl_croak(pTHX_ const char *pat, ...) +{ + va_list args; + va_start(args, pat); + vcroak(pat, &args); + assert(0); /* NOTREACHED */ + va_end(args); +} + /* -=head1 Warning and Dieing +=for apidoc Am|void|croak_no_modify -=for apidoc croak +Exactly equivalent to C, but generates +terser object code than using C. Less code used on exception code +paths reduces CPU cache pressure. -This is the XSUB-writer's interface to Perl's C function. -Normally call this function the same way you call the C C -function. Calling C returns control directly to Perl, -sidestepping the normal C order of execution. See C. +=cut +*/ -If you want to throw an exception object, assign the object to -C<$@> and then pass C to croak(): +void +Perl_croak_no_modify(pTHX) +{ + Perl_croak(aTHX_ "%s", PL_no_modify); +} - errsv = get_sv("@", GV_ADD); - sv_setsv(errsv, exception_object); - croak(NULL); +/* +=for apidoc Am|void|warn_sv|SV *baseex + +This is an XS interface to Perl's C function. + +C 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. + +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 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 function. + +C and C 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. + +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, C is not permitted to be null. + +=cut +*/ + void Perl_vwarn(pTHX_ const char* pat, va_list *args) { - dVAR; - SV * const msv = vmess(pat, args); - + 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(msv, TRUE)) - return; - } +/* +=for apidoc Am|void|warn|const char *pat|... - write_to_stderr(msv); -} +This is an XS interface to Perl's C 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. + +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, C is not permitted to be null. + +=cut +*/ #if defined(PERL_IMPLICIT_CONTEXT) void @@ -1477,15 +1709,6 @@ Perl_warn_nocontext(const char *pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ -/* -=for apidoc warn - -This is the XSUB-writer's interface to Perl's C function. Call this -function the same way you call the C C function. See C. - -=cut -*/ - void Perl_warn(pTHX_ const char *pat, ...) { @@ -1553,11 +1776,8 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { SV * const msv = vmess(pat, args); - if (PL_diehook) { - assert(msv); - S_vdie_common(aTHX_ msv, FALSE); - } - die_where(msv); + invoke_exception_hook(msv, FALSE); + die_unwind(msv); } else { Perl_vwarn(aTHX_ pat, args); @@ -1625,7 +1845,8 @@ S_ckwarn_common(pTHX_ U32 w) 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; @@ -1635,6 +1856,8 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, 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; } @@ -1663,8 +1886,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) #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? */ @@ -1760,7 +1983,7 @@ void Perl_my_setenv(pTHX_ const char *nam, const char *val) { dVAR; - register char *envstr; + char *envstr; const int nlen = strlen(nam); int vlen; @@ -1850,9 +2073,9 @@ Perl_my_bzero(register char *loc, register I32 len) I32 Perl_my_memcmp(const char *s1, const char *s2, register 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; @@ -1955,8 +2178,8 @@ Perl_my_htonl(pTHX_ long l) #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) Perl_croak(aTHX_ "Unknown BYTEORDER\n"); #else - register I32 o; - register I32 s; + I32 o; + I32 s; for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { u.c[o & 0xf] = (l >> s) & 255; @@ -1984,8 +2207,8 @@ Perl_my_ntohl(pTHX_ long l) #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) Perl_croak(aTHX_ "Unknown BYTEORDER\n"); #else - register I32 o; - register I32 s; + I32 o; + I32 s; u.l = l; l = 0; @@ -2016,8 +2239,8 @@ Perl_my_ntohl(pTHX_ long l) type value; \ char c[sizeof(type)]; \ } u; \ - register U32 i; \ - register U32 s = 0; \ + U32 i; \ + U32 s = 0; \ for (i = 0; i < sizeof(u.c); i++, s += 8) { \ u.c[i] = (n >> s) & 0xFF; \ } \ @@ -2032,8 +2255,8 @@ Perl_my_ntohl(pTHX_ long l) type value; \ char c[sizeof(type)]; \ } u; \ - register U32 i; \ - register U32 s = 0; \ + U32 i; \ + U32 s = 0; \ u.value = n; \ n = 0; \ for (i = 0; i < sizeof(u.c); i++, s += 8) { \ @@ -2054,8 +2277,8 @@ Perl_my_ntohl(pTHX_ long l) type value; \ char c[sizeof(type)]; \ } u; \ - register U32 i; \ - register U32 s = 8*(sizeof(u.c)-1); \ + U32 i; \ + U32 s = 8*(sizeof(u.c)-1); \ for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ u.c[i] = (n >> s) & 0xFF; \ } \ @@ -2070,8 +2293,8 @@ Perl_my_ntohl(pTHX_ long l) type value; \ char c[sizeof(type)]; \ } u; \ - register U32 i; \ - register U32 s = 8*(sizeof(u.c)-1); \ + U32 i; \ + U32 s = 8*(sizeof(u.c)-1); \ u.value = n; \ n = 0; \ for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ @@ -2235,9 +2458,9 @@ BETOH(Perl_my_betohl,long) void Perl_my_swabn(void *ptr, int n) { - register char *s = (char *)ptr; - register char *e = s + (n-1); - register char tc; + char *s = (char *)ptr; + char *e = s + (n-1); + char tc; PERL_ARGS_ASSERT_MY_SWABN; @@ -2251,11 +2474,11 @@ Perl_my_swabn(void *ptr, int n) 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(EPOC) && !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]; @@ -2366,7 +2589,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) 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); @@ -2388,14 +2611,14 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) } /* 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(EPOC) && !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; @@ -2435,7 +2658,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) sleep(5); } if (pid == 0) { - GV* tmpgv; #undef THIS #undef THAT @@ -2481,15 +2703,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) 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 */ @@ -2532,7 +2745,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) 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); @@ -2545,7 +2758,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) return PerlIO_fdopen(p[This], mode); } #else -#if defined(atarist) || defined(EPOC) +#if defined(EPOC) FILE *popen(); PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) @@ -2840,7 +3053,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) #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(EPOC) && !defined(__LIBCATAMOUNT__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { @@ -2849,11 +3062,20 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) 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; @@ -2864,15 +3086,12 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #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 @@ -2884,7 +3103,11 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) 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__) @@ -2985,7 +3208,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 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); @@ -2994,7 +3217,7 @@ S_pidgone(pTHX_ Pid_t pid, int status) } #endif -#if defined(atarist) || defined(OS2) || defined(EPOC) +#if defined(OS2) || defined(EPOC) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -3029,27 +3252,27 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #define PERL_REPEATCPY_LINEAR 4 void -Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count) +Perl_repeatcpy(register char *to, register const char *from, I32 len, register IV count) { PERL_ARGS_ASSERT_REPEATCPY; 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; @@ -3107,11 +3330,11 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, 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 @@ -3234,28 +3457,25 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, 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 @@ -3306,6 +3526,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, 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), @@ -3329,8 +3550,9 @@ Perl_get_context(void) #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 @@ -3353,8 +3575,11 @@ Perl_set_context(void *t) # 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); @@ -3424,104 +3649,10 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) 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 @@ -3575,113 +3706,71 @@ Perl_my_fflush_all(pTHX) } 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" : /* "" 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); } } -#ifdef EBCDIC -/* in ASCII order, not that it matters */ -static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; - -int -Perl_ebcdic_control(pTHX_ int ch) +void +Perl_report_evil_fh(pTHX_ const GV *gv) { - if (ch > 'a') { - const char *ctlp; + const IO *io = gv ? GvIO(gv) : NULL; + const PERL_BITFIELD16 op = PL_op->op_type; + const char *vile; + I32 warn_type; - if (islower(ch)) - ch = toupper(ch); - - if ((ctlp = strchr(controllablechars, ch)) == 0) { - Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); - } - - 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); + if (io && IoTYPE(io) == IoTYPE_CLOSED) { + vile = "closed"; + warn_type = WARN_CLOSED; + } + 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" : /* "" 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) + ); } } -#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 @@ -3803,7 +3892,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) * 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 @@ -3814,15 +3903,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) 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 @@ -3917,9 +3998,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) 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 * @@ -3982,7 +4061,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in const int fmtlen = strlen(fmt); int bufsize = fmtlen + buflen; - Newx(buf, bufsize, char); + Renew(buf, bufsize, char); while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); if (buflen > 0 && buflen < bufsize) @@ -4182,6 +4261,16 @@ Perl_getcwd_sv(pTHX_ register SV *sv) #define VERSION_MAX 0x7FFFFFFF +/* +=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 * Perl_prescan_version(pTHX_ const char *s, bool strict, const char **errstr, @@ -4275,6 +4364,7 @@ dotted_decimal_version: } /* 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 == '.') { @@ -4285,6 +4375,11 @@ dotted_decimal_version: } } + /* 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++; @@ -4295,7 +4390,7 @@ dotted_decimal_version: saw_decimal++; d++; } - else if (!*d || *d == ';' || isSPACE(*d) || *d == '}') { + else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') { if ( d == s ) { /* found nothing */ BADVERSION(s,errstr,"Invalid version format (version required)"); @@ -4326,13 +4421,13 @@ dotted_decimal_version: /* scan the fractional part after the decimal point*/ - if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '}') )) { + 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++; + d++; j++; if (*d == '.' && isDIGIT(d[-1])) { if (alpha) { BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); @@ -4354,6 +4449,7 @@ dotted_decimal_version: if ( ! isDIGIT(d[1]) ) { BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); } + width = j; d++; alpha = TRUE; } @@ -4364,7 +4460,7 @@ version_prescan_finish: while (isSPACE(*d)) d++; - if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '}') )) { + if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) { /* trailing non-numeric data */ BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); } @@ -4595,7 +4691,8 @@ Perl_new_version(pTHX_ SV *ver) 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(); @@ -4687,18 +4784,32 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) 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 = 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); + 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 */ @@ -4713,29 +4824,35 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) #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 @@ -4754,27 +4871,30 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) /* =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; @@ -4789,9 +4909,9 @@ Perl_vverify(pTHX_ SV *vs) && 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; } /* @@ -4805,6 +4925,8 @@ point representation. Call like: NOTE: you can pass either the object directly or the SV contained within the RV. +The SV returned has a refcount of 1. + =cut */ @@ -4814,15 +4936,14 @@ Perl_vnumify(pTHX_ SV *vs) 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); - - 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 */ @@ -4836,19 +4957,17 @@ Perl_vnumify(pTHX_ SV *vs) /* attempt to retrieve the version array */ if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { - sv_catpvs(sv,"0"); - return sv; + 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)); @@ -4887,6 +5006,8 @@ representation. Call like: NOTE: you can pass either the object directly or the SV contained within the RV. +The SV returned has a refcount of 1. + =cut */ @@ -4895,15 +5016,14 @@ Perl_vnormal(pTHX_ SV *vs) { 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) ) + /* 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 ) ) @@ -4913,11 +5033,10 @@ Perl_vnormal(pTHX_ SV *vs) 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); @@ -4946,7 +5065,9 @@ Perl_vnormal(pTHX_ SV *vs) 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 */ @@ -4956,10 +5077,9 @@ Perl_vstringify(pTHX_ SV *vs) { 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)) { @@ -4999,15 +5119,10 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) 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 */ @@ -5324,7 +5439,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { } #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 @@ -5387,8 +5502,11 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) 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++) { @@ -5414,9 +5532,12 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) 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); + } } } } @@ -5424,6 +5545,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) 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)); @@ -5433,6 +5556,10 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) return opt; } +#ifdef VMS +# include +#endif + U32 Perl_seed(pTHX) { @@ -5464,7 +5591,6 @@ Perl_seed(pTHX) #endif U32 u; #ifdef VMS -# include /* when[] = (low 32 bits, high 32 bits) of time since epoch * in 100-ns units, typically incremented ever 10 ms. */ unsigned int when[2]; @@ -5554,25 +5680,6 @@ Perl_get_hash_seed(pTHX) return myseed; } -#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; - - if (stashpv == name) - return TRUE; - if (stashpv && name) - if (strEQ(stashpv, name)) - return TRUE; - return FALSE; -} -#endif - - #ifdef PERL_GLOBAL_STRUCT #define PERL_GLOBAL_STRUCT_INIT @@ -5597,18 +5704,15 @@ Perl_init_global_struct(pTHX) # 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*) @@ -5784,7 +5888,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, 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) \ @@ -5893,8 +5997,14 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) 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)) + /* 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(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } @@ -5933,8 +6043,14 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap 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)) + /* 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(aTHX_ "panic: my_vsnprintf buffer overflow"); return retval; } @@ -6112,6 +6228,84 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) #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) @@ -6151,34 +6345,65 @@ long _ftol( double ); /* Defined by VC6 C libs. */ 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 = PL_tainted; + + /* 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; + PL_tainted = 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 { @@ -6188,6 +6413,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) (void)SvIOK_on(dbsv); SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ } + TAINT_IF(save_taint); } int @@ -6202,7 +6428,7 @@ Perl_my_dirfd(pTHX_ DIR * dir) { return dir->dd_fd; #else Perl_die(aTHX_ PL_no_func, "dirfd"); - /* NOT REACHED */ + assert(0); /* NOT REACHED */ return 0; #endif } @@ -6226,8 +6452,8 @@ Perl_get_re_arg(pTHX_ SV *sv) { * 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: */