X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/63e3af20059610d29fa934e8330849fee9c115c5..0924b5a49d76dcfb6cd7a2e52c607e0bc707d0f5:/util.c diff --git a/util.c b/util.c index 7e26322..0ea39c6 100644 --- a/util.c +++ b/util.c @@ -1,7 +1,7 @@ /* util.c * - * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, + * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -9,8 +9,10 @@ */ /* - * "Very useful, no doubt, that was to Saruman; yet it seems that he was - * not content." --Gandalf + * 'Very useful, no doubt, that was to Saruman; yet it seems that he was + * not content.' --Gandalf to Pippin + * + * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* This file contains assorted utility routines. @@ -23,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 @@ -68,12 +74,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) { @@ -91,7 +103,6 @@ Perl_safesysmalloc(MEM_SIZE 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 @@ -114,12 +125,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*/ } @@ -129,7 +146,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(); @@ -178,11 +197,11 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) ptr = (Malloc_t)PerlMem_realloc(where,size); PERL_ALLOC_CHECK(ptr); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - - if (ptr != NULL) { + /* MUST do this fixup first, before doing ANYTHING else, as anything else + might allocate memory/free/move memory, and until we do the fixup, it + may well be chasing (and writing to) free memory. */ #ifdef PERL_TRACK_MEMPOOL + if (ptr != NULL) { struct perl_memory_debug_header *const header = (struct perl_memory_debug_header *)ptr; @@ -198,13 +217,28 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) header->prev->next = header; ptr = (Malloc_t)((char*)ptr+sTHX); + } #endif + + /* In particular, must do that fixup above before logging anything via + *printf(), as it can reallocate memory, which can cause SEGVs. */ + + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); + + + if (ptr != NULL) { return ptr; } - else if (PL_nomemok) - return NULL; else { - return write_no_mem(); +#ifndef ALWAYS_NEED_THX + dTHX; +#endif + if (PL_nomemok) + return NULL; + else { + return write_no_mem(); + } } /*NOTREACHED*/ } @@ -214,7 +248,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; @@ -256,13 +290,27 @@ Perl_safesysfree(Malloc_t where) Malloc_t Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { +#ifdef ALWAYS_NEED_THX dTHX; +#endif Malloc_t ptr; + MEM_SIZE total_size = 0; + /* Even though calloc() for zero bytes is strange, be robust. */ + if (size && (count <= MEM_SIZE_MAX / size)) + total_size = size * count; + else + Perl_croak_nocontext("%s", PL_memory_wrap); +#ifdef PERL_TRACK_MEMPOOL + if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) + total_size += sTHX; + else + Perl_croak_nocontext("%s", PL_memory_wrap); +#endif #ifdef HAS_64K_LIMIT - if (size * count > 0xffff) { + if (total_size > 0xffff) { PerlIO_printf(Perl_error_log, - "Allocation too large: %lx\n", size * count) FLUSH; + "Allocation too large: %lx\n", total_size) FLUSH; my_exit(1); } #endif /* HAS_64K_LIMIT */ @@ -270,20 +318,28 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) if ((long)size < 0 || (long)count < 0) Perl_croak_nocontext("panic: calloc"); #endif - size *= count; #ifdef PERL_TRACK_MEMPOOL - size += sTHX; + /* Have to use malloc() because we've added some space for our tracking + header. */ + /* malloc(0) is non-portable. */ + ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1); +#else + /* Use calloc() because it might save a memset() if the memory is fresh + and clean from the OS. */ + if (count && size) + ptr = (Malloc_t)PerlMem_calloc(count, size); + else /* calloc(0) is non-portable. */ + ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); #endif - ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ PERL_ALLOC_CHECK(ptr); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size)); if (ptr != NULL) { - memset((void*)ptr, 0, size); #ifdef PERL_TRACK_MEMPOOL { struct perl_memory_debug_header *const header = (struct perl_memory_debug_header *)ptr; + memset((void*)ptr, 0, total_size); header->interpreter = aTHX; /* Link us into the list. */ header->prev = &PL_memory_debug_header; @@ -291,16 +347,21 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) PL_memory_debug_header.next = header; header->next->prev = header; # ifdef PERL_POISON - header->size = size; + header->size = total_size; # endif ptr = (Malloc_t)((char*)ptr+sTHX); } #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 @@ -337,10 +398,11 @@ Free_t Perl_mfree (Malloc_t where) /* copy a string up to some (non-backslashed) delimiter, if any */ char * -Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) +Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) { register I32 tolen; - PERL_UNUSED_CONTEXT; + + PERL_ARGS_ASSERT_DELIMCPY; for (tolen = 0; from < fromend; from++, tolen++) { if (*from == '\\') { @@ -366,10 +428,11 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons /* This routine was donated by Corey Satten. */ char * -Perl_instr(pTHX_ register const char *big, register const char *little) +Perl_instr(register const char *big, register const char *little) { register I32 first; - PERL_UNUSED_CONTEXT; + + PERL_ARGS_ASSERT_INSTR; if (!little) return (char*)big; @@ -399,24 +462,24 @@ Perl_instr(pTHX_ register const char *big, register const char *little) /* same as instr but allow embedded nulls */ char * -Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend) +Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) { - PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_NINSTR; if (little >= lend) return (char*)big; { - char first = *little++; + const char first = *little; const char *s, *x; - bigend -= lend - little; + bigend -= lend - little++; OUTER: while (big <= bigend) { - if (*big++ != first) - goto OUTER; - for (x=big,s=little; s < lend; x++,s++) { - if (*s != *x) - goto OUTER; + if (*big++ == first) { + for (x=big,s=little; s < lend; x++,s++) { + if (*s != *x) + goto OUTER; + } + return (char*)(big-1); } - return (char*)(big-1); } } return NULL; @@ -425,12 +488,13 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const /* reverse of the above--find last substring */ char * -Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) +Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend) { register const char *bigbeg; register const I32 first = *little; register const char * const littleend = lend; - PERL_UNUSED_CONTEXT; + + PERL_ARGS_ASSERT_RNINSTR; if (little >= littleend) return (char*)bigend; @@ -454,8 +518,6 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit return NULL; } -#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ - /* As a space optimization, we do not compile tables for strings of length 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are special-cased in fbm_instr(). @@ -480,9 +542,11 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) register const U8 *s; register U32 i; STRLEN len; - I32 rarest = 0; + U32 rarest = 0; U32 frequency = 256; + PERL_ARGS_ASSERT_FBM_COMPILE; + if (flags & FBMcf_TAIL) { MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ @@ -490,19 +554,22 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) mg->mg_len++; } s = (U8*)SvPV_force_mutable(sv, len); - SvUPGRADE(sv, SVt_PVBM); if (len == 0) /* TAIL might be on a zero-length string. */ return; + SvUPGRADE(sv, SVt_PVGV); + SvIOK_off(sv); + SvNOK_off(sv); + SvVALID_on(sv); if (len > 2) { const unsigned char *sb; const U8 mlen = (len>255) ? 255 : (U8)len; register U8 *table; - Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); - table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET); - s = table - 1 - FBM_TABLE_OFFSET; /* last char */ + Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET); + table + = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET); + s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */ memset((void*)table, mlen, 256); - table[-1] = (U8)flags; i = 0; sb = s - mlen + 1; /* first char (maybe) */ while (s >= sb) { @@ -510,9 +577,10 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) 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 */ - SvVALID_on(sv); s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ for (i = 0; i < len; i++) { @@ -521,13 +589,14 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) frequency = PL_freq[s[i]]; } } + BmFLAGS(sv) = (U8)flags; BmRARE(sv) = s[rarest]; - BmPREVIOUS(sv) = (U16)rarest; + BmPREVIOUS(sv) = rarest; BmUSEFUL(sv) = 100; /* Initial value */ if (flags & FBMcf_TAIL) SvTAIL_on(sv); - DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n", - BmRARE(sv),BmPREVIOUS(sv))); + DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n", + BmRARE(sv),(unsigned long)BmPREVIOUS(sv))); } /* If SvTAIL(littlestr), it has a fake '\n' at end. */ @@ -555,6 +624,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register STRLEN littlelen = l; register const I32 multiline = flags & FBMrf_MULTILINE; + PERL_ARGS_ASSERT_FBM_INSTR; + if ((STRLEN)(bigend - big) < littlelen) { if ( SvTAIL(littlestr) && ((STRLEN)(bigend - big) == littlelen - 1) @@ -663,7 +734,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } return NULL; } - if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { + if (!SvVALID(littlestr)) { char * const b = ninstr((char*)big,(char*)bigend, (char*)little, (char*)little + littlelen); @@ -680,12 +751,15 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit return b; } - { /* Do actual FBM. */ - register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET; + /* Do actual FBM. */ + if (littlelen > (STRLEN)(bigend - big)) + return NULL; + + { + register const unsigned char * const table + = little + littlelen + PERL_FBM_TABLE_OFFSET; register const unsigned char *oldlittle; - if (littlelen > (STRLEN)(bigend - big)) - return NULL; --littlelen; /* Last char found by table lookup */ s = big + littlelen; @@ -718,7 +792,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } } check_end: - if ( s == bigend && (table[-1] & FBMcf_TAIL) + if ( s == bigend + && (BmFLAGS(littlestr) & FBMcf_TAIL) && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; @@ -754,6 +829,11 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift 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)) { @@ -827,35 +907,79 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift return NULL; } +/* +=for apidoc foldEQ + +Returns true if the leading len bytes of the strings s1 and s2 are the same +case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes +match themselves and their opposite case counterparts. Non-cased and non-ASCII +range bytes match only themselves. + +=cut +*/ + + I32 -Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) +Perl_foldEQ(const char *s1, const char *s2, register I32 len) { register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; - PERL_UNUSED_CONTEXT; + + 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 */ + + register const U8 *a = (const U8 *)s1; + register 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(pTHX_ const char *s1, const char *s2, register I32 len) +Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len) { dVAR; register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; - PERL_UNUSED_CONTEXT; + + 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 */ @@ -943,6 +1067,29 @@ Perl_savesharedpv(pTHX_ const char *pv) } /* +=for apidoc savesharedpvn + +A version of C which allocates the duplicate string in memory +which is shared between threads. (With the specific difference that a NULL +pointer is not acceptable) + +=cut +*/ +char * +Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) +{ + char *const newaddr = (char*)PerlMemShared_malloc(len + 1); + + PERL_ARGS_ASSERT_SAVESHAREDPVN; + + if (!newaddr) { + return write_no_mem(); + } + newaddr[len] = '\0'; + return (char*)memcpy(newaddr, pv, len); +} + +/* =for apidoc savesvpv A version of C/C which gets the string to duplicate from @@ -958,11 +1105,32 @@ Perl_savesvpv(pTHX_ SV *sv) const char * const pv = SvPV_const(sv, len); register char *newaddr; + PERL_ARGS_ASSERT_SAVESVPV; + ++len; Newx(newaddr,len,char); return (char *) CopyD(pv,newaddr,len,char); } +/* +=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 */ @@ -973,8 +1141,8 @@ S_mess_alloc(pTHX) SV *sv; XPVMG *any; - if (!PL_dirty) - return sv_2mortal(newSVpvs("")); + if (PL_phase != PERL_PHASE_DESTRUCT) + return newSVpvs_flags("", SVs_TEMP); if (PL_mess_sv) return PL_mess_sv; @@ -997,6 +1165,7 @@ Perl_form_nocontext(const char* pat, ...) dTHX; char *retval; va_list args; + PERL_ARGS_ASSERT_FORM_NOCONTEXT; va_start(args, pat); retval = vform(pat, &args); va_end(args); @@ -1029,6 +1198,7 @@ Perl_form(pTHX_ const char* pat, ...) { char *retval; va_list args; + PERL_ARGS_ASSERT_FORM; va_start(args, pat); retval = vform(pat, &args); va_end(args); @@ -1039,10 +1209,26 @@ char * Perl_vform(pTHX_ const char *pat, va_list *args) { SV * const sv = mess_alloc(); + PERL_ARGS_ASSERT_VFORM; sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); return SvPVX(sv); } +/* +=for apidoc Am|SV *|mess|const char *pat|... + +Take a sprintf-style format pattern and argument list. These are used to +generate a string message. If the message does not end with a newline, +then it will be extended with some indication of the current location +in the code, as described for L. + +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, ...) @@ -1050,6 +1236,7 @@ Perl_mess_nocontext(const char *pat, ...) dTHX; SV *retval; va_list args; + PERL_ARGS_ASSERT_MESS_NOCONTEXT; va_start(args, pat); retval = vmess(pat, &args); va_end(args); @@ -1062,6 +1249,7 @@ Perl_mess(pTHX_ const char *pat, ...) { SV *retval; va_list args; + PERL_ARGS_ASSERT_MESS; va_start(args, pat); retval = vmess(pat, &args); va_end(args); @@ -1074,6 +1262,8 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o) dVAR; /* Look for PL_op starting from o. cop is the last COP we've seen. */ + PERL_ARGS_ASSERT_CLOSEST_COP; + if (!o || o == PL_op) return cop; @@ -1101,13 +1291,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_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 @@ -1123,7 +1357,10 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, OutCopFILE(cop), (IV)CopLINE(cop)); - if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { + /* Seems that GvIO() can be untrustworthy during global destruction. */ + if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) + && IoLINES(GvIOp(PL_last_in_gv))) + { const bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, @@ -1131,64 +1368,90 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) 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_ const char* message, int msglen) +Perl_write_to_stderr(pTHX_ SV* msv) { dVAR; IO *io; MAGIC *mg; + PERL_ARGS_ASSERT_WRITE_TO_STDERR; + if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIO(PL_stderrgv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) - { - dSP; - ENTER; - SAVETMPS; - - save_re_context(); - SAVESPTR(PL_stderrgv); - PL_stderrgv = NULL; - - PUSHSTACKi(PERLSI_MAGIC); - - PUSHMARK(SP); - EXTEND(SP,2); - PUSHs(SvTIED_obj((SV*)io, mg)); - PUSHs(sv_2mortal(newSVpvn(message, msglen))); - PUTBACK; - call_method("PRINT", G_SCALAR); - - POPSTACK; - FREETMPS; - LEAVE; - } + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) + 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 */ - const int e = errno; + dSAVED_ERRNO; #endif PerlIO * const serr = Perl_error_log; - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); + do_print(msv, serr); (void)PerlIO_flush(serr); #ifdef USE_SFIO - errno = e; + RESTORE_ERRNO; #endif } } -/* Common code used by vcroak, vdie, vwarn and vwarner */ +/* +=head1 Warning and Dieing +*/ + +/* Common code used in dieing and warning */ + +STATIC SV * +S_with_queued_errors(pTHX_ SV *ex) +{ + PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS; + if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) { + sv_catsv(PL_errors, ex); + ex = sv_mortalcopy(PL_errors); + SvCUR_set(PL_errors, 0); + } + return ex; +} STATIC bool -S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) +S_invoke_exception_hook(pTHX_ SV *ex, bool warn) { dVAR; HV *stash; @@ -1198,7 +1461,8 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) /* sv_2cv might call Perl_croak() or Perl_warner() */ SV * const oldhook = *hook; - assert(oldhook); + if (!oldhook) + return FALSE; ENTER; SAVESPTR(*hook); @@ -1207,7 +1471,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; - SV *msg; + SV *exarg; ENTER; save_re_context(); @@ -1215,21 +1479,15 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) SAVESPTR(*hook); *hook = NULL; } - if (warn || message) { - msg = newSVpvn(message, msglen); - SvFLAGS(msg) |= utf8; - SvREADONLY_on(msg); - SAVEFREESV(msg); - } - else { - msg = ERRSV; - } + exarg = newSVsv(ex); + SvREADONLY_on(exarg); + SAVEFREESV(exarg); PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); PUSHMARK(SP); - XPUSHs(msg); + XPUSHs(exarg); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv(MUTABLE_SV(cv), G_DISCARD); POPSTACK; LEAVE; return TRUE; @@ -1237,194 +1495,278 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) return FALSE; } -STATIC const char * -S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, - I32* utf8) -{ - dVAR; - const char *message; +/* +=for apidoc Am|OP *|die_sv|SV *baseex - if (pat) { - SV * const msv = vmess(pat, args); - if (PL_errors && SvCUR(PL_errors)) { - sv_catsv(PL_errors, msv); - message = SvPV_const(PL_errors, *msglen); - SvCUR_set(PL_errors, 0); - } - else - message = SvPV_const(msv,*msglen); - *utf8 = SvUTF8(msv); - } - else { - message = 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. - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die/croak: message = %s\ndiehook = %p\n", - thr, message, PL_diehook)); - if (PL_diehook) { - S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE); - } - return message; -} +=cut +*/ OP * -Perl_vdie(pTHX_ const char* pat, va_list *args) +Perl_die_sv(pTHX_ SV *baseex) { - dVAR; - const char *message; - const int was_in_eval = PL_in_eval; - STRLEN msglen; - I32 utf8 = 0; + PERL_ARGS_ASSERT_DIE_SV; + croak_sv(baseex); + /* NOTREACHED */ + return NULL; +} - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: curstack = %p, mainstack = %p\n", - thr, PL_curstack, PL_mainstack)); +/* +=for apidoc Am|OP *|die|const char *pat|... - message = vdie_croak_common(pat, args, &msglen, &utf8); +Behaves the same as L, except for the return type. +It should be used only where the C return type is required. +The function never actually returns. - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", - thr, PL_restartop, was_in_eval, PL_top_env)); - if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) - JMPENV_JUMP(3); - return PL_restartop; -} +=cut +*/ #if defined(PERL_IMPLICIT_CONTEXT) OP * Perl_die_nocontext(const char* pat, ...) { dTHX; - OP *o; va_list args; va_start(args, pat); - o = vdie(pat, &args); + vcroak(pat, &args); + /* NOTREACHED */ va_end(args); - return o; + return NULL; } #endif /* PERL_IMPLICIT_CONTEXT */ OP * Perl_die(pTHX_ const char* pat, ...) { - OP *o; va_list args; va_start(args, pat); - o = vdie(pat, &args); + vcroak(pat, &args); + /* NOTREACHED */ va_end(args); - return o; + return NULL; } -void -Perl_vcroak(pTHX_ const char* pat, va_list *args) -{ - dVAR; - const char *message; - STRLEN msglen; - I32 utf8 = 0; +/* +=for apidoc Am|void|croak_sv|SV *baseex - message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); +This is an XS interface to Perl's C function. - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - JMPENV_JUMP(3); - } - else if (!message) - message = SvPVx_const(ERRSV, msglen); +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. - write_to_stderr(message, msglen); - my_failure_exit(); -} +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 +*/ -#if defined(PERL_IMPLICIT_CONTEXT) void -Perl_croak_nocontext(const char *pat, ...) +Perl_croak_sv(pTHX_ SV *baseex) { - dTHX; - va_list args; - va_start(args, pat); - vcroak(pat, &args); - /* NOTREACHED */ - va_end(args); + SV *ex = with_queued_errors(mess_sv(baseex, 0)); + PERL_ARGS_ASSERT_CROAK_SV; + invoke_exception_hook(ex, FALSE); + die_unwind(ex); } -#endif /* PERL_IMPLICIT_CONTEXT */ /* -=head1 Warning and Dieing +=for apidoc Am|void|vcroak|const char *pat|va_list *args -=for apidoc croak +This is an XS interface to Perl's C function. -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. +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. -If you want to throw an exception object, assign the object to -C<$@> and then pass C to croak(): +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. - errsv = get_sv("@", TRUE); - sv_setsv(errsv, exception_object); - croak(NULL); +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 */ void -Perl_croak(pTHX_ const char *pat, ...) +Perl_vcroak(pTHX_ const char* pat, va_list *args) { - va_list args; - va_start(args, pat); - vcroak(pat, &args); - /* NOTREACHED */ - va_end(args); + SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0)); + invoke_exception_hook(ex, FALSE); + die_unwind(ex); } -void -Perl_vwarn(pTHX_ const char* pat, va_list *args) -{ - dVAR; - STRLEN msglen; - SV * const msv = vmess(pat, args); - const I32 utf8 = SvUTF8(msv); - const char * const message = SvPV_const(msv, msglen); +/* +=for apidoc Am|void|croak|const char *pat|... - if (PL_warnhook) { - if (vdie_common(message, msglen, utf8, TRUE)) - return; - } +This is an XS interface to Perl's C function. - write_to_stderr(message, msglen); -} +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_warn_nocontext(const char *pat, ...) +Perl_croak_nocontext(const char *pat, ...) { dTHX; va_list args; va_start(args, pat); - vwarn(pat, &args); + vcroak(pat, &args); + /* 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); + /* NOTREACHED */ + va_end(args); +} + +/* +=for apidoc Am|void|croak_no_modify + +Exactly equivalent to C, but generates +terser object code than using C. Less code used on exception code +paths reduces CPU cache pressure. + +=cut +*/ + +void +Perl_croak_no_modify(pTHX) +{ + Perl_croak(aTHX_ "%s", PL_no_modify); +} + /* -=for apidoc warn +=for apidoc Am|void|warn_sv|SV *baseex -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. +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_warn_sv(pTHX_ SV *baseex) +{ + 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) +{ + SV *ex = vmess(pat, args); + PERL_ARGS_ASSERT_VWARN; + if (!invoke_exception_hook(ex, TRUE)) + write_to_stderr(ex); +} + +/* +=for apidoc Am|void|warn|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 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 +Perl_warn_nocontext(const char *pat, ...) +{ + dTHX; + va_list args; + PERL_ARGS_ASSERT_WARN_NOCONTEXT; + va_start(args, pat); + vwarn(pat, &args); + va_end(args); +} +#endif /* PERL_IMPLICIT_CONTEXT */ + +void Perl_warn(pTHX_ const char *pat, ...) { va_list args; + PERL_ARGS_ASSERT_WARN; va_start(args, pat); vwarn(pat, &args); va_end(args); @@ -1436,6 +1778,7 @@ Perl_warner_nocontext(U32 err, const char *pat, ...) { dTHX; va_list args; + PERL_ARGS_ASSERT_WARNER_NOCONTEXT; va_start(args, pat); vwarner(err, pat, &args); va_end(args); @@ -1443,9 +1786,36 @@ Perl_warner_nocontext(U32 err, const char *pat, ...) #endif /* PERL_IMPLICIT_CONTEXT */ void +Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) +{ + PERL_ARGS_ASSERT_CK_WARNER_D; + + if (Perl_ckwarn_d(aTHX_ err)) { + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); + } +} + +void +Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) +{ + PERL_ARGS_ASSERT_CK_WARNER; + + if (Perl_ckwarn(aTHX_ err)) { + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); + } +} + +void Perl_warner(pTHX_ U32 err, const char* pat,...) { va_list args; + PERL_ARGS_ASSERT_WARNER; va_start(args, pat); vwarner(err, pat, &args); va_end(args); @@ -1455,23 +1825,12 @@ void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { dVAR; + PERL_ARGS_ASSERT_VWARNER; if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { SV * const msv = vmess(pat, args); - STRLEN msglen; - const char * const message = SvPV_const(msv, msglen); - const I32 utf8 = SvUTF8(msv); - if (PL_diehook) { - assert(message); - S_vdie_common(aTHX_ message, msglen, utf8, FALSE); - } - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - JMPENV_JUMP(3); - } - write_to_stderr(message, msglen); - my_failure_exit(); + invoke_exception_hook(msv, FALSE); + die_unwind(msv); } else { Perl_vwarn(aTHX_ pat, args); @@ -1484,26 +1843,11 @@ bool Perl_ckwarn(pTHX_ U32 w) { dVAR; - return - ( - isLEXWARN_on - && PL_curcop->cop_warnings != pWARN_NONE - && ( - PL_curcop->cop_warnings == pWARN_ALL - || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) - || (unpackWARN2(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) - || (unpackWARN3(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) - || (unpackWARN4(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) - ) - ) - || - ( - isLEXWARN_off && PL_dowarn & G_WARN_ON - ) - ; + /* If lexical warnings have not been set, use $^W. */ + if (isLEXWARN_off) + return PL_dowarn & G_WARN_ON; + + return ckwarn_common(w); } /* implements the ckWARN?_d macro */ @@ -1512,22 +1856,42 @@ bool Perl_ckwarn_d(pTHX_ U32 w) { dVAR; - return - isLEXWARN_off - || PL_curcop->cop_warnings == pWARN_ALL - || ( - PL_curcop->cop_warnings != pWARN_NONE - && ( - isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) - || (unpackWARN2(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) - || (unpackWARN3(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) - || (unpackWARN4(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) - ) - ) - ; + /* If lexical warnings have not been set then default classes warn. */ + if (isLEXWARN_off) + return TRUE; + + return ckwarn_common(w); +} + +static bool +S_ckwarn_common(pTHX_ U32 w) +{ + if (PL_curcop->cop_warnings == pWARN_ALL) + return TRUE; + + if (PL_curcop->cop_warnings == pWARN_NONE) + return FALSE; + + /* Check the assumption that at least the first slot is non-zero. */ + assert(unpackWARN1(w)); + + /* Check the assumption that it is valid to stop as soon as a zero slot is + seen. */ + if (!unpackWARN2(w)) { + assert(!unpackWARN3(w)); + assert(!unpackWARN4(w)); + } else if (!unpackWARN3(w)) { + assert(!unpackWARN4(w)); + } + + /* Right, dealt with all the special cases, which are implemented as non- + pointers, so there is a pointer to a real warnings mask. */ + do { + if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))) + return TRUE; + } while (w >>= WARNshift); + + return FALSE; } /* Set buffer=NULL to get a new one. */ @@ -1536,6 +1900,7 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, STRLEN size) { const MEM_SIZE len_wanted = sizeof(STRLEN) + size; PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD; buffer = (STRLEN*) (specialWARN(buffer) ? @@ -1571,9 +1936,16 @@ 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=setenv_getix(nam); /* where does it go? */ + register I32 i; + register const I32 len = strlen(nam); int nlen, vlen; + /* where does it go? */ + for (i = 0; environ[i]; i++) { + if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') + break; + } + if (environ == PL_origenviron) { /* need we copy environment? */ I32 j; I32 max; @@ -1677,28 +2049,6 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) #endif /* WIN32 || NETWARE */ -#ifndef PERL_MICRO -I32 -Perl_setenv_getix(pTHX_ const char *nam) -{ - register I32 i; - register const I32 len = strlen(nam); - PERL_UNUSED_CONTEXT; - - for (i = 0; environ[i]; i++) { - if ( -#ifdef WIN32 - strnicmp(environ[i],nam,len) == 0 -#else - strnEQ(environ[i],nam,len) -#endif - && environ[i][len] == '=') - break; /* strnEQ must come first to avoid */ - } /* potential SEGV's */ - return i; -} -#endif /* !PERL_MICRO */ - #endif /* !VMS && !EPOC*/ #ifdef UNLINK_ALL_VERSIONS @@ -1707,6 +2057,8 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ { I32 retries = 0; + PERL_ARGS_ASSERT_UNLNK; + while (PerlLIO_unlink(f) >= 0) retries++; return retries ? 0 : -1; @@ -1720,6 +2072,8 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len) { char * const retval = to; + PERL_ARGS_ASSERT_MY_BCOPY; + if (from - to >= 0) { while (len--) *to++ = *from++; @@ -1741,6 +2095,8 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len) { char * const retval = loc; + PERL_ARGS_ASSERT_MY_MEMSET; + while (len--) *loc++ = ch; return retval; @@ -1754,6 +2110,8 @@ Perl_my_bzero(register char *loc, register I32 len) { char * const retval = loc; + PERL_ARGS_ASSERT_MY_BZERO; + while (len--) *loc++ = 0; return retval; @@ -1769,6 +2127,8 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len) register const U8 *b = (const U8 *)s2; register I32 tmp; + PERL_ARGS_ASSERT_MY_MEMCMP; + while (len--) { if ((tmp = *a++ - *b++)) return tmp; @@ -1778,24 +2138,51 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len) #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ #ifndef HAS_VPRINTF +/* This vsprintf replacement should generally never get used, since + vsprintf was available in both System V and BSD 2.11. (There may + be some cross-compilation or embedded set-ups where it is needed, + however.) + + If you encounter a problem in this function, it's probably a symptom + that Configure failed to detect your system's vprintf() function. + See the section on "item vsprintf" in the INSTALL file. + + This version may compile on systems with BSD-ish , + but probably won't on others. +*/ #ifdef USE_CHAR_VSPRINTF char * #else int #endif -vsprintf(char *dest, const char *pat, char *args) +vsprintf(char *dest, const char *pat, void *args) { FILE fakebuf; +#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) + FILE_ptr(&fakebuf) = (STDCHAR *) dest; + FILE_cnt(&fakebuf) = 32767; +#else + /* These probably won't compile -- If you really need + this, you'll have to figure out some other method. */ fakebuf._ptr = dest; fakebuf._cnt = 32767; +#endif #ifndef _IOSTRG #define _IOSTRG 0 #endif fakebuf._flag = _IOWRT|_IOSTRG; _doprnt(pat, args, &fakebuf); /* what a kludge */ - (void)putc('\0', &fakebuf); +#if defined(STDIO_PTR_LVALUE) + *(FILE_ptr(&fakebuf)++) = '\0'; +#else + /* PerlIO has probably #defined away fputc, but we want it here. */ +# ifdef fputc +# undef fputc /* XXX Should really restore it later */ +# endif + (void)fputc('\0', &fakebuf); +#endif #ifdef USE_CHAR_VSPRINTF return(dest); #else @@ -1828,7 +2215,10 @@ Perl_my_htonl(pTHX_ long l) char c[sizeof(long)]; } u; -#if BYTEORDER == 0x1234 +#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 +#if BYTEORDER == 0x12345678 + u.result = 0; +#endif u.c[0] = (l >> 24) & 255; u.c[1] = (l >> 16) & 255; u.c[2] = (l >> 8) & 255; @@ -2122,6 +2512,8 @@ Perl_my_swabn(void *ptr, int n) 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; @@ -2130,9 +2522,9 @@ Perl_my_swabn(void *ptr, int n) } PerlIO * -Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) +Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) { -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) dVAR; int p[2]; register I32 This, that; @@ -2141,6 +2533,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) I32 did_pipes = 0; int pp[2]; + PERL_ARGS_ASSERT_MY_POPEN_LIST; + PERL_FLUSHALL_FOR_CHILD; This = (*mode == 'w'); that = !This; @@ -2163,6 +2557,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) } return NULL; } + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -2220,9 +2615,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) else PerlLIO_close(p[that]); /* close child's end of pipe */ - LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); - UNLOCK_FDPID_MUTEX; SvUPGRADE(sv,SVt_IV); SvIV_set(sv, pid); PL_forkprocess = pid; @@ -2258,13 +2651,17 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) PerlLIO_close(pp[0]); return PerlIO_fdopen(p[This], mode); #else +# ifdef OS2 /* Same, without fork()ing and all extra overhead... */ + return my_syspopen4(aTHX_ NULL, mode, n, args); +# else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; +# endif #endif } /* VMS' my_popen() is in VMS.c, same with OS/2. */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { @@ -2277,6 +2674,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) I32 did_pipes = 0; int pp[2]; + PERL_ARGS_ASSERT_MY_POPEN; + PERL_FLUSHALL_FOR_CHILD; #ifdef OS2 if (doexec) { @@ -2302,9 +2701,10 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) PerlLIO_close(pp[1]); } if (!doexec) - Perl_croak(aTHX_ "Can't fork"); + Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); return NULL; } + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -2347,6 +2747,14 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) PerlProc__exit(1); } #endif /* defined OS2 */ + +#ifdef PERLIO_USING_CRLF + /* Since we circumvent IO layers when we manipulate low-level + filedescriptors directly, need to manually switch to the + default, binary, low-level mode; see PerlIOBuf_open(). */ + PerlLIO_setmode((*mode == 'r'), O_BINARY); +#endif + if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) { SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), PerlProc_getpid()); @@ -2374,9 +2782,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) else PerlLIO_close(p[that]); - LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); - UNLOCK_FDPID_MUTEX; SvUPGRADE(sv,SVt_IV); SvIV_set(sv, pid); PL_forkprocess = pid; @@ -2415,8 +2821,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #if defined(atarist) || defined(EPOC) FILE *popen(); PerlIO * -Perl_my_popen(pTHX_ char *cmd, char *mode) +Perl_my_popen(pTHX_ const char *cmd, const char *mode) { + PERL_ARGS_ASSERT_MY_POPEN; PERL_FLUSHALL_FOR_CHILD; /* Call system's popen() to get a FILE *, then import it. used 0 for 2nd parameter to PerlIO_importFILE; @@ -2428,7 +2835,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #if defined(DJGPP) FILE *djgpp_popen(); PerlIO * -Perl_my_popen(pTHX_ char *cmd, char *mode) +Perl_my_popen(pTHX_ const char *cmd, const char *mode) { PERL_FLUSHALL_FOR_CHILD; /* Call system's popen() to get a FILE *, then import it. @@ -2437,6 +2844,14 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) */ return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); } +#else +#if defined(__LIBCATAMOUNT__) +PerlIO * +Perl_my_popen(pTHX_ const char *cmd, const char *mode) +{ + return NULL; +} +#endif #endif #endif @@ -2494,11 +2909,13 @@ Perl_my_fork(void) #ifdef DUMP_FDS void -Perl_dump_fds(pTHX_ char *s) +Perl_dump_fds(pTHX_ const char *const s) { int fd; Stat_t tmpstatbuf; + PERL_ARGS_ASSERT_DUMP_FDS; + PerlIO_printf(Perl_debug_log,"%s", s); for (fd = 0; fd < 32; fd++) { if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) @@ -2546,11 +2963,6 @@ dup2(int oldfd, int newfd) #ifndef PERL_MICRO #ifdef HAS_SIGACTION -#ifdef MACOS_TRADITIONAL -/* We don't want restart behavior on MacOS */ -#undef SA_RESTART -#endif - Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { @@ -2598,6 +3010,8 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) dVAR; struct sigaction act; + PERL_ARGS_ASSERT_RSIGNAL_SAVE; + #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) @@ -2699,7 +3113,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(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { @@ -2708,16 +3122,20 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) int status; SV **svp; Pid_t pid; - Pid_t pid2; + Pid_t pid2 = 0; bool close_failed; - int saved_errno = 0; -#ifdef WIN32 - int saved_win32_errno; + dSAVEDERRNO; + const int fd = PerlIO_fileno(ptr); + +#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 - LOCK_FDPID_MUTEX; - svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); - UNLOCK_FDPID_MUTEX; + svp = av_fetch(PL_fdpid,fd,TRUE); pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; SvREFCNT_dec(*svp); *svp = &PL_sv_undef; @@ -2726,12 +3144,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) return my_syspclose(ptr); } #endif - if ((close_failed = (PerlIO_close(ptr) == EOF))) { - saved_errno = errno; -#ifdef WIN32 - saved_win32_errno = GetLastError(); -#endif - } + close_failed = (PerlIO_close(ptr) == EOF); + SAVE_ERRNO; #ifdef UTS if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif @@ -2740,7 +3154,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) 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 @@ -2749,19 +3163,32 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) rsignal_restore(SIGQUIT, &qstat); #endif if (close_failed) { - SETERRNO(saved_errno, 0); + RESTORE_ERRNO; return -1; } - return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); + return( + should_wait + ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status) + : 0 + ); +} +#else +#if defined(__LIBCATAMOUNT__) +I32 +Perl_my_pclose(pTHX_ PerlIO *ptr) +{ + return -1; } +#endif #endif /* !DOSISH */ -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { dVAR; I32 result = 0; + PERL_ARGS_ASSERT_WAIT4PID; if (!pid) return -1; #ifdef PERL_USES_PL_PIDSTATUS @@ -2834,6 +3261,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) #endif if (result < 0 && errno == EINTR) { PERL_ASYNC_CHECK(); + errno = EINTR; /* reset in case a signal handler changed $! */ } return result; } @@ -2841,7 +3269,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) #ifdef PERL_USES_PL_PIDSTATUS void -Perl_pidgone(pTHX_ Pid_t pid, int status) +S_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; @@ -2885,24 +3313,36 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) } #endif +#define PERL_REPEATCPY_LINEAR 4 void -Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) -{ - register I32 todo; - register const char * const frombase = from; - PERL_UNUSED_CONTEXT; +Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count) +{ + PERL_ARGS_ASSERT_REPEATCPY; + + if (len == 1) + memset(to, *from, count); + else if (count) { + register char *p = to; + I32 items, linear, half; + + linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; + for (items = 0; items < linear; ++items) { + register const char *q = from; + I32 todo; + for (todo = len; todo > 0; todo--) + *p++ = *q++; + } - if (len == 1) { - register const char c = *from; - while (count-- > 0) - *to++ = c; - return; - } - while (count-- > 0) { - for (todo = len; todo > 0; todo--) { - *to++ = *from++; + half = count / 2; + while (items <= half) { + I32 size = items * len; + memcpy(p, to, size); + p += size; + items *= 2; } - from = frombase; + + if (count > items) + memcpy(p, to, (count - items) * len); } } @@ -2916,6 +3356,8 @@ Perl_same_dirent(pTHX_ const char *a, const char *b) Stat_t tmpstatbuf2; SV * const tmpsv = sv_newmortal(); + PERL_ARGS_ASSERT_SAME_DIRENT; + if (fa) fa++; else @@ -2927,13 +3369,13 @@ Perl_same_dirent(pTHX_ const char *a, const char *b) if (strNE(a,b)) return FALSE; if (fa == a) - sv_setpvn(tmpsv, ".", 1); + sv_setpvs(tmpsv, "."); else sv_setpvn(tmpsv, a, fa - a); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) return FALSE; if (fb == b) - sv_setpvn(tmpsv, ".", 1); + sv_setpvs(tmpsv, "."); else sv_setpvn(tmpsv, b, fb - b); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) @@ -2954,6 +3396,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, register char *s; I32 len = 0; int retval; + char *bufend; #if defined(DOSISH) && !defined(OS2) && !defined(atarist) # define SEARCH_EXTS ".bat", ".cmd", NULL # define MAX_EXT_LEN 4 @@ -2977,6 +3420,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, # define MAX_EXT_LEN 0 #endif + PERL_ARGS_ASSERT_FIND_SCRIPT; + /* * If dosearch is true and if scriptname does not contain path * delimiters, search the PATH for scriptname. @@ -3065,26 +3510,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, } #endif -#ifdef MACOS_TRADITIONAL - if (dosearch && !strchr(scriptname, ':') && - (s = PerlEnv_getenv("Commands"))) -#else if (dosearch && !strchr(scriptname, '/') #ifdef DOSISH && !strchr(scriptname, '\\') #endif && (s = PerlEnv_getenv("PATH"))) -#endif { bool seen_dot = 0; - PL_bufend = s + strlen(s); - while (s < PL_bufend) { -#ifdef MACOS_TRADITIONAL - s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, - ',', - &len); -#else + bufend = s + strlen(s); + while (s < bufend) { #if defined(atarist) || defined(DOSISH) for (len = 0; *s # ifdef atarist @@ -3097,21 +3532,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, if (len < sizeof tmpbuf) tmpbuf[len] = '\0'; #else /* ! (atarist || DOSISH) */ - s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, + s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, ':', &len); #endif /* ! (atarist || DOSISH) */ -#endif /* MACOS_TRADITIONAL */ - if (s < PL_bufend) + if (s < bufend) s++; if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) continue; /* don't search dir with too-long name */ -#ifdef MACOS_TRADITIONAL - if (len && tmpbuf[len - 1] != ':') - tmpbuf[len++] = ':'; -#else if (len -# if defined(atarist) || defined(__MINT__) || defined(DOSISH) +# if defined(atarist) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' # endif @@ -3119,7 +3549,6 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, tmpbuf[len++] = '/'; if (len == 2 && tmpbuf[0] == '.') seen_dot = 1; -#endif (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); #endif /* !VMS */ @@ -3144,7 +3573,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, continue; if (S_ISREG(PL_statbuf.st_mode) && cando(S_IRUSR,TRUE,&PL_statbuf) -#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL) +#if !defined(DOSISH) && cando(S_IXUSR,TRUE,&PL_statbuf) #endif ) @@ -3205,6 +3634,7 @@ void Perl_set_context(void *t) { dVAR; + PERL_ARGS_ASSERT_SET_CONTEXT; #if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); @@ -3269,6 +3699,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { char * const env_trans = PerlEnv_getenv(env_elem); PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_GETENV_LEN; if (env_trans) *len = strlen(env_trans); return env_trans; @@ -3430,113 +3861,76 @@ 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; - } +Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) +{ + if (ckWARN(WARN_IO)) { + const char * const name + = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL; + const char * const direction = have == '>' ? "out" : "in"; - 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 - ); - } - } + 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); } } -#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; - - if (islower(ch)) - ch = toupper(ch); + const IO *io = gv ? GvIO(gv) : NULL; + const PERL_BITFIELD16 op = PL_op->op_type; + const char *vile; + I32 warn_type; - if ((ctlp = strchr(controllablechars, ch)) == 0) { - Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); + if (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 name + = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(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"); + 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 (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 + ); } - - 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); } } -#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 @@ -3566,11 +3960,13 @@ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ #ifdef HAS_TM_TM_ZONE Time_t now; const struct tm* my_tm; + PERL_ARGS_ASSERT_INIT_TM; (void)time(&now); my_tm = localtime(&now); if (my_tm) Copy(my_tm, ptm, 1, struct tm); #else + PERL_ARGS_ASSERT_INIT_TM; PERL_UNUSED_ARG(ptm); #endif } @@ -3588,6 +3984,8 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) int odd_cent, odd_year; PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_MINI_MKTIME; + #define DAYS_PER_YEAR 365 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) @@ -3654,7 +4052,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 @@ -3782,6 +4180,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in struct tm mytm; int len; + PERL_ARGS_ASSERT_MY_STRFTIME; + init_tm(&mytm); /* XXX workaround - see init_tm() above */ mytm.tm_sec = sec; mytm.tm_min = min; @@ -3829,9 +4229,9 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in else { /* Possibly buf overflowed - try again with a bigger buf */ const int fmtlen = strlen(fmt); - const int bufsize = fmtlen + buflen; + int bufsize = fmtlen + buflen; - Newx(buf, bufsize, char); + Renew(buf, bufsize, char); while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); if (buflen > 0 && buflen < bufsize) @@ -3842,7 +4242,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in buf = NULL; break; } - Renew(buf, bufsize*2, char); + bufsize *= 2; + Renew(buf, bufsize, char); } return buf; } @@ -3888,6 +4289,8 @@ Perl_getcwd_sv(pTHX_ register SV *sv) SvTAINTED_on(sv); #endif + PERL_ARGS_ASSERT_GETCWD_SV; + #ifdef HAS_GETCWD { char buf[MAXPATHLEN]; @@ -3925,6 +4328,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) for (;;) { DIR *dir; + int namelen; odev = cdev; oino = cino; @@ -3947,9 +4351,9 @@ Perl_getcwd_sv(pTHX_ register SV *sv) while ((dp = PerlDir_read(dir)) != NULL) { #ifdef DIRNAMLEN - const int namelen = dp->d_namlen; + namelen = dp->d_namlen; #else - const int namelen = strlen(dp->d_name); + namelen = strlen(dp->d_name); #endif /* skip . and .. */ if (SV_CWD_ISDOT(dp)) { @@ -4025,89 +4429,282 @@ Perl_getcwd_sv(pTHX_ register SV *sv) #endif } -/* -=for apidoc scan_version - -Returns a pointer to the next character after the parsed -version string, as well as upgrading the passed in SV to -an RV. - -Function must be called with an already existing SV like +#define VERSION_MAX 0x7FFFFFFF - sv = newSV(0); - s = scan_version(s,SV *sv, bool qv); +/* +=for apidoc prescan_version -Performs some preprocessing to the string to ensure that -it has the correct characteristics of a version. Flags the -object if it contains an underscore (which denotes this -is a alpha version). The boolean qv denotes that the version -should be interpreted as if it had multiple decimals, even if -it doesn't. +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_scan_version(pTHX_ const char *s, SV *rv, bool qv) -{ - const char *start; - const char *pos; - const char *last; - int saw_period = 0; - int alpha = 0; +Perl_prescan_version(pTHX_ const char *s, bool strict, + const char **errstr, + bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) { + bool qv = (sqv ? *sqv : FALSE); int width = 3; - AV * const av = newAV(); - SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ - (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ + int saw_decimal = 0; + bool alpha = FALSE; + const char *d = s; -#ifndef NODEFAULT_SHAREKEYS - HvSHAREKEYS_on(hv); /* key-sharing on by default */ -#endif + PERL_ARGS_ASSERT_PRESCAN_VERSION; - while (isSPACE(*s)) /* leading whitespace is OK */ - s++; + if (qv && isDIGIT(*d)) + goto dotted_decimal_version; - if (*s == 'v') { - s++; /* get past 'v' */ - qv = 1; /* force quoted version processing */ - } + if (*d == 'v') { /* explicit v-string */ + d++; + if (isDIGIT(*d)) { + qv = TRUE; + } + else { /* degenerate v-string */ + /* requires v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } - start = last = pos = s; +dotted_decimal_version: + if (strict && d[0] == '0' && isDIGIT(d[1])) { + /* no leading zeros allowed */ + BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); + } - /* pre-scan the input string to check for decimals/underbars */ - while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) - { - if ( *pos == '.' ) + while (isDIGIT(*d)) /* integer part */ + d++; + + if (*d == '.') { - if ( alpha ) - Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); - saw_period++ ; - last = pos; + saw_decimal++; + d++; /* decimal point */ } - else if ( *pos == '_' ) + else { - if ( alpha ) - Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); - alpha = 1; - width = pos - last - 1; /* natural width of sub-version */ + if (strict) { + /* require v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + else { + goto version_prescan_finish; + } } - pos++; - } - - if ( alpha && !saw_period ) - Perl_croak(aTHX_ "Invalid version format (alpha without decimal)"); - if ( saw_period > 1 ) - qv = 1; /* force quoted version processing */ + { + int i = 0; + int j = 0; + while (isDIGIT(*d)) { /* just keep reading */ + i++; + while (isDIGIT(*d)) { + d++; j++; + /* maximum 3 digits between decimal */ + if (strict && j > 3) { + BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)"); + } + } + if (*d == '_') { + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + if ( alpha ) { + BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); + } + d++; + alpha = TRUE; + } + else if (*d == '.') { + if (alpha) { + BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); + } + saw_decimal++; + d++; + } + else if (!isDIGIT(*d)) { + break; + } + j = 0; + } + + if (strict && i < 2) { + /* requires v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + } + } /* end if dotted-decimal */ + else + { /* decimal versions */ + /* special strict case for leading '.' or '0' */ + if (strict) { + if (*d == '.') { + BADVERSION(s,errstr,"Invalid version format (0 before decimal required)"); + } + if (*d == '0' && isDIGIT(d[1])) { + BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); + } + } + + /* consume all of the integer part */ + while (isDIGIT(*d)) + d++; + + /* look for a fractional part */ + if (*d == '.') { + /* we found it, so consume it */ + saw_decimal++; + d++; + } + else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') { + if ( d == s ) { + /* found nothing */ + BADVERSION(s,errstr,"Invalid version format (version required)"); + } + /* found just an integer */ + goto version_prescan_finish; + } + else if ( d == s ) { + /* didn't find either integer or period */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + else if (*d == '_') { + /* underscore can't come after integer part */ + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + else if (isDIGIT(d[1])) { + BADVERSION(s,errstr,"Invalid version format (alpha without decimal)"); + } + else { + BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); + } + } + else { + /* anything else after integer part is just invalid data */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + + /* scan the fractional part after the decimal point*/ + + if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) { + /* strict or lax-but-not-the-end */ + BADVERSION(s,errstr,"Invalid version format (fractional part required)"); + } + + while (isDIGIT(*d)) { + d++; + if (*d == '.' && isDIGIT(d[-1])) { + if (alpha) { + BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); + } + if (strict) { + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); + } + d = (char *)s; /* start all over again */ + qv = TRUE; + goto dotted_decimal_version; + } + if (*d == '_') { + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + if ( alpha ) { + BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); + } + if ( ! isDIGIT(d[1]) ) { + BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); + } + d++; + alpha = TRUE; + } + } + } + +version_prescan_finish: + while (isSPACE(*d)) + d++; + + if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) { + /* trailing non-numeric data */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + + if (sqv) + *sqv = qv; + if (swidth) + *swidth = width; + if (ssaw_decimal) + *ssaw_decimal = saw_decimal; + if (salpha) + *salpha = alpha; + return d; +} + +/* +=for apidoc scan_version + +Returns a pointer to the next character after the parsed +version string, as well as upgrading the passed in SV to +an RV. + +Function must be called with an already existing SV like + + sv = newSV(0); + s = scan_version(s, SV *sv, bool qv); + +Performs some preprocessing to the string to ensure that +it has the correct characteristics of a version. Flags the +object if it contains an underscore (which denotes this +is an alpha version). The boolean qv denotes that the version +should be interpreted as if it had multiple decimals, even if +it doesn't. + +=cut +*/ + +const char * +Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) +{ + const char *start; + const char *pos; + const char *last; + const char *errstr = NULL; + int saw_decimal = 0; + int width = 3; + bool alpha = FALSE; + bool vinf = FALSE; + AV * const av = newAV(); + SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ + + PERL_ARGS_ASSERT_SCAN_VERSION; + + (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ + +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif + + while (isSPACE(*s)) /* leading whitespace is OK */ + s++; + last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha); + if (errstr) { + /* "undef" is a special case and not an error */ + if ( ! ( *s == 'u' && strEQ(s,"undef")) ) { + Perl_croak(aTHX_ "%s", errstr); + } + } + + start = s; + if (*s == 'v') + s++; pos = s; if ( qv ) - hv_store((HV *)hv, "qv", 2, newSViv(qv), 0); + (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv)); if ( alpha ) - hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0); + (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha)); if ( !qv && width < 3 ) - hv_store((HV *)hv, "width", 5, newSViv(width), 0); + (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); while (isDIGIT(*pos)) pos++; @@ -4120,20 +4717,26 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) /* this is atoi() that delimits on underscores */ const char *end = pos; I32 mult = 1; - I32 orev; + I32 orev; /* the following if() will only be true after the decimal * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ - if ( !qv && s > start && saw_period == 1 ) { + if ( !qv && s > start && saw_decimal == 1 ) { mult *= 100; while ( s < end ) { - orev = rev; + orev = rev; rev += (*s - '0') * mult; mult /= 10; - if ( PERL_ABS(orev) > PERL_ABS(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); + if ( (PERL_ABS(orev) > PERL_ABS(rev)) + || (PERL_ABS(rev) > VERSION_MAX )) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version %d",VERSION_MAX); + s = end - 1; + rev = VERSION_MAX; + vinf = 1; + } s++; if ( *s == '_' ) s++; @@ -4141,21 +4744,33 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } else { while (--end >= s) { - orev = rev; + orev = rev; rev += (*end - '0') * mult; mult *= 10; - if ( PERL_ABS(orev) > PERL_ABS(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); + if ( (PERL_ABS(orev) > PERL_ABS(rev)) + || (PERL_ABS(rev) > VERSION_MAX )) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version"); + end = s - 1; + rev = VERSION_MAX; + vinf = 1; + } } } } /* Append revision */ av_push(av, newSViv(rev)); - if ( *pos == '.' ) + if ( vinf ) { + s = last; + break; + } + else if ( *pos == '.' ) s = ++pos; else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; + else if ( *pos == ',' && isDIGIT(pos[1]) ) + s = ++pos; else if ( isDIGIT(*pos) ) s = pos; else { @@ -4183,23 +4798,40 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) Compiler in question is: gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) for ( len = 2 - len; len > 0; len-- ) - av_push((AV *)sv, newSViv(0)); + av_push(MUTABLE_AV(sv), newSViv(0)); */ len = 2 - len; while (len-- > 0) av_push(av, newSViv(0)); } - if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */ + /* need to save off the current version string for later */ + if ( vinf ) { + SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); + (void)hv_stores(MUTABLE_HV(hv), "original", orig); + (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1)); + } + else if ( s > start ) { + SV * orig = newSVpvn(start,s-start); + if ( qv && saw_decimal == 1 && *start != 'v' ) { + /* need to insert a v to be consistent */ + sv_insert(orig, 0, 0, "v", 1); + } + (void)hv_stores(MUTABLE_HV(hv), "original", orig); + } + else { + (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0")); av_push(av, newSViv(0)); + } + + /* And finally, store the AV in the hash */ + (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); /* fix RT#19517 - special case 'undef' as string */ if ( *s == 'u' && strEQ(s,"undef") ) { s += 5; } - /* And finally, store the AV in the hash */ - hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); return s; } @@ -4221,6 +4853,7 @@ 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 */ { I32 key; @@ -4237,19 +4870,25 @@ Perl_new_version(pTHX_ SV *ver) ver = SvRV(ver); /* Begin copying all of the elements */ - if ( hv_exists((HV *)ver, "qv", 2) ) - hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); + if ( hv_exists(MUTABLE_HV(ver), "qv", 2) ) + (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1)); - if ( hv_exists((HV *)ver, "alpha", 5) ) - hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) ) + (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1)); - if ( hv_exists((HV*)ver, "width", 5 ) ) + if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) ) { - const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE)); - hv_store((HV *)hv, "width", 5, newSViv(width), 0); + const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE)); + (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); } - sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE)); + if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) ) + { + SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE); + (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv)); + } + + sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE))); /* This will get reblessed later if a derived class*/ for ( key = 0; key <= av_len(sav); key++ ) { @@ -4257,7 +4896,7 @@ Perl_new_version(pTHX_ SV *ver) av_push(av, newSViv(rev)); } - hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); + (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); return rv; } #ifdef SvVOK @@ -4267,6 +4906,9 @@ Perl_new_version(pTHX_ SV *ver) const STRLEN len = mg->mg_len; char * const version = savepvn( (const char*)mg->mg_ptr, len); sv_setpvn(rv,version,len); + /* this is for consistency with the pure Perl class */ + if ( isDIGIT(*version) ) + sv_insert(rv, 0, 0, "v", 1); Safefree(version); } else { @@ -4276,7 +4918,7 @@ Perl_new_version(pTHX_ SV *ver) } } #endif - return upg_version(rv); + return upg_version(rv, FALSE); } /* @@ -4284,24 +4926,27 @@ Perl_new_version(pTHX_ SV *ver) In-place upgrade of the supplied SV to a version object. - SV *sv = upg_version(SV *sv); + SV *sv = upg_version(SV *sv, bool qv); -Returns a pointer to the upgraded SV. +Returns a pointer to the upgraded SV. Set the boolean qv if you want +to force this SV to be interpreted as an "extended" version. =cut */ SV * -Perl_upg_version(pTHX_ SV *ver) +Perl_upg_version(pTHX_ SV *ver, bool qv) { const char *version, *s; - bool qv = 0; #ifdef SvVOK const MAGIC *mg; #endif - if ( SvNOK(ver) ) /* may get too much accuracy */ + PERL_ARGS_ASSERT_UPG_VERSION; + + if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) ) { + /* may get too much accuracy */ char tbuf[64]; #ifdef USE_LOCALE_NUMERIC char *loc = setlocale(LC_NUMERIC, "C"); @@ -4311,25 +4956,62 @@ Perl_upg_version(pTHX_ SV *ver) setlocale(LC_NUMERIC, loc); #endif while (tbuf[len-1] == '0' && len > 0) len--; + if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */ version = savepvn(tbuf, len); } #ifdef SvVOK else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); - qv = 1; + qv = TRUE; } #endif else /* must be a string or something like a string */ { - version = savepv(SvPV_nolen(ver)); + STRLEN len; + version = savepv(SvPV(ver,len)); +#ifndef SvVOK +# if PERL_VERSION > 5 + /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ + if ( len >= 3 && !instr(version,".") && !instr(version,"_")) { + /* may be a v-string */ + 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; + } + break; + } + } + } +# endif +#endif } s = scan_version(version, ver, qv); if ( *s != '\0' ) - if(ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Version string '%s' contains invalid data; " - "ignoring: '%s'", version, s); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Version string '%s' contains invalid data; " + "ignoring: '%s'", version, s); Safefree(version); return ver; } @@ -4337,41 +5019,47 @@ Perl_upg_version(pTHX_ SV *ver) /* =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; + + PERL_ARGS_ASSERT_VVERIFY; + if ( SvROK(vs) ) vs = SvRV(vs); /* see if the appropriate elements exist */ if ( SvTYPE(vs) == SVt_PVHV - && hv_exists((HV*)vs, "version", 7) - && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE))) + && hv_exists(MUTABLE_HV(vs), "version", 7) + && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) && SvTYPE(sv) == SVt_PVAV ) - return TRUE; + return vs; else - return FALSE; + return NULL; } /* @@ -4385,6 +5073,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 */ @@ -4394,38 +5084,38 @@ Perl_vnumify(pTHX_ SV *vs) I32 i, len, digit; int width; bool alpha = FALSE; - SV * const sv = newSV(0); + SV *sv; AV *av; - if ( SvROK(vs) ) - vs = SvRV(vs); - if ( !vverify(vs) ) + PERL_ARGS_ASSERT_VNUMIFY; + + /* extract the HV from the object */ + vs = vverify(vs); + if ( ! vs ) Perl_croak(aTHX_ "Invalid version object"); /* see if various flags exist */ - if ( hv_exists((HV*)vs, "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) alpha = TRUE; - if ( hv_exists((HV*)vs, "width", 5 ) ) - width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE)); + if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) ) + width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE)); else width = 3; /* attempt to retrieve the version array */ - if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) { - sv_catpvs(sv,"0"); - return sv; + if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { + return newSVpvs("0"); } len = av_len(av); if ( len == -1 ) { - sv_catpvs(sv,"0"); - return sv; + return newSVpvs("0"); } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit)); + sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); @@ -4464,6 +5154,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 */ @@ -4472,26 +5164,27 @@ Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; bool alpha = FALSE; - SV * const sv = newSV(0); + SV *sv; AV *av; - if ( SvROK(vs) ) - vs = SvRV(vs); - if ( !vverify(vs) ) + PERL_ARGS_ASSERT_VNORMAL; + + /* extract the HV from the object */ + vs = vverify(vs); + if ( ! vs ) Perl_croak(aTHX_ "Invalid version object"); - if ( hv_exists((HV*)vs, "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) alpha = TRUE; - av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)); + av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); len = av_len(av); if ( len == -1 ) { - sv_catpvs(sv,""); - return sv; + return newSVpvs(""); } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit); + sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); @@ -4520,7 +5213,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 */ @@ -4528,16 +5223,27 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { - if ( SvROK(vs) ) - vs = SvRV(vs); - - if ( !vverify(vs) ) + PERL_ARGS_ASSERT_VSTRINGIFY; + + /* extract the HV from the object */ + vs = vverify(vs); + if ( ! vs ) Perl_croak(aTHX_ "Invalid version object"); - if ( hv_exists((HV *)vs, "qv", 2) ) - return vnormal(vs); - else - return vnumify(vs); + if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) { + SV *pv; + pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE); + if ( SvPOK(pv) ) + return newSVsv(pv); + else + return &PL_sv_undef; + } + else { + if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) + return vnormal(vs); + else + return vnumify(vs); + } } /* @@ -4558,25 +5264,23 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) I32 left = 0; I32 right = 0; AV *lav, *rav; - if ( SvROK(lhv) ) - lhv = SvRV(lhv); - if ( SvROK(rhv) ) - rhv = SvRV(rhv); - if ( !vverify(lhv) ) - Perl_croak(aTHX_ "Invalid version object"); + PERL_ARGS_ASSERT_VCMP; - 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 */ - lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE)); - if ( hv_exists((HV*)lhv, "alpha", 5 ) ) + lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); + if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) ) lalpha = TRUE; /* and the right hand term */ - rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE)); - if ( hv_exists((HV*)rhv, "alpha", 5 ) ) + rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); + if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) ) ralpha = TRUE; l = av_len(lav); @@ -4766,12 +5470,12 @@ S_socketpair_udp (int fd[2]) { errno = ECONNABORTED; tidy_up_and_fail: { - const int save_errno = errno; + dSAVE_ERRNO; if (sockets[0] != -1) PerlLIO_close(sockets[0]); if (sockets[1] != -1) PerlLIO_close(sockets[1]); - errno = save_errno; + RESTORE_ERRNO; return -1; } } @@ -4870,14 +5574,14 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { #endif tidy_up_and_fail: { - const int save_errno = errno; + dSAVE_ERRNO; if (listener != -1) PerlLIO_close(listener); if (connector != -1) PerlLIO_close(connector); if (acceptor != -1) PerlLIO_close(acceptor); - errno = save_errno; + RESTORE_ERRNO; return -1; } } @@ -4913,19 +5617,44 @@ Perl_sv_nosharing(pTHX_ SV *sv) PERL_UNUSED_ARG(sv); } +/* + +=for apidoc sv_destroyable + +Dummy routine which reports that object can be destroyed when there is no +sharing module present. It ignores its single SV argument, and returns +'true'. Exists to avoid test for a NULL function pointer and because it +could potentially warn under some level of strict-ness. + +=cut +*/ + +bool +Perl_sv_destroyable(pTHX_ SV *sv) +{ + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(sv); + return TRUE; +} + U32 Perl_parse_unicode_opts(pTHX_ const char **popt) { const char *p = *popt; U32 opt = 0; + PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS; + if (*p) { if (isDIGIT(*p)) { opt = (U32) atoi(p); while (isDIGIT(*p)) p++; - 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++) { @@ -4951,9 +5680,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); + } } } } @@ -4961,6 +5693,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)); @@ -5078,7 +5812,7 @@ Perl_get_hash_seed(pTHX) * help. Sum in another random number that will * fill in the low bits. */ myseed += - (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1)); + (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1)); #endif /* RANDBITS < (UVSIZE * 8) */ if (myseed == 0) { /* Superparanoia. */ myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */ @@ -5098,6 +5832,7 @@ 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; @@ -5111,13 +5846,14 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) #ifdef PERL_GLOBAL_STRUCT +#define PERL_GLOBAL_STRUCT_INIT +#include "opcode.h" /* the ppaddr and check */ + struct perl_vars * Perl_init_global_struct(pTHX) { struct perl_vars *plvarsp = NULL; -#ifdef PERL_GLOBAL_STRUCT -# define PERL_GLOBAL_STRUCT_INIT -# include "opcode.h" /* the ppaddr and check */ +# ifdef PERL_GLOBAL_STRUCT const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t); const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t); # ifdef PERL_GLOBAL_STRUCT_PRIVATE @@ -5145,10 +5881,14 @@ Perl_init_global_struct(pTHX) # undef PERLVARIC # undef PERLVARISC # ifdef PERL_GLOBAL_STRUCT - plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); + plvarsp->Gppaddr = + (Perl_ppaddr_t*) + PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); if (!plvarsp->Gppaddr) exit(1); - plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t)); + plvarsp->Gcheck = + (Perl_check_t*) + PerlMem_malloc(ncheck * sizeof(Perl_check_t)); if (!plvarsp->Gcheck) exit(1); Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); @@ -5157,8 +5897,8 @@ Perl_init_global_struct(pTHX) # ifdef PERL_SET_VARS PERL_SET_VARS(plvarsp); # endif -# undef PERL_GLOBAL_STRUCT_INIT -#endif +# undef PERL_GLOBAL_STRUCT_INIT +# endif return plvarsp; } @@ -5169,188 +5909,211 @@ Perl_init_global_struct(pTHX) void Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) { -#ifdef PERL_GLOBAL_STRUCT + PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; +# ifdef PERL_GLOBAL_STRUCT # ifdef PERL_UNSET_VARS PERL_UNSET_VARS(plvarsp); # endif free(plvarsp->Gppaddr); free(plvarsp->Gcheck); -# ifdef PERL_GLOBAL_STRUCT_PRIVATE +# ifdef PERL_GLOBAL_STRUCT_PRIVATE free(plvarsp); -# endif -#endif +# endif +# endif } #endif /* PERL_GLOBAL_STRUCT */ #ifdef PERL_MEM_LOG -/* - * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled. +/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the + * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also + * given, and you supply your own implementation. * - * PERL_MEM_LOG_ENV: if defined, during run time the environment - * variable PERL_MEM_LOG will be consulted, and if the integer value - * of that is true, the logging will happen. (The default is to - * always log if the PERL_MEM_LOG define was in effect.) + * The default implementation reads a single env var, PERL_MEM_LOG, + * expecting one or more of the following: + * + * \d+ - fd fd to write to : must be 1st (atoi) + * 'm' - memlog was PERL_MEM_LOG=1 + * 's' - svlog was PERL_SV_LOG=1 + * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 + * + * This makes the logger controllable enough that it can reasonably be + * added to the system perl. */ -/* - * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer +/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer * the Perl_mem_log_...() will use (either via sprintf or snprintf). */ #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 -/* - * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will - * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD, - * in which case the environment variable PERL_MEM_LOG_FD will be - * consulted for the file descriptor number to use. +/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...() + * writes to. In the default logger, this is settable at runtime. */ #ifndef PERL_MEM_LOG_FD # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ #endif -Malloc_t -Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) -{ -#ifdef PERL_MEM_LOG_STDERR -# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; -# endif -# ifdef PERL_MEM_LOG_ENV - s = getenv("PERL_MEM_LOG"); - if (s ? atoi(s) : 0) +#ifndef PERL_MEM_LOG_NOIMPL + +# ifdef DEBUG_LEAKING_SCALARS +# define SV_LOG_SERIAL_FMT " [%lu]" +# define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial +# else +# define SV_LOG_SERIAL_FMT +# define _SV_LOG_SERIAL_ARG(sv) # endif + +static void +S_mem_log_common(enum mem_log_type mlt, const UV n, + const UV typesize, const char *type_name, const SV *sv, + Malloc_t oldalloc, Malloc_t newalloc, + const char *filename, const int linenumber, + const char *funcname) +{ + const char *pmlenv; + + PERL_ARGS_ASSERT_MEM_LOG_COMMON; + + pmlenv = PerlEnv_getenv("PERL_MEM_LOG"); + if (!pmlenv) + return; + if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s')) { /* We can't use SVs or PerlIO for obvious reasons, * so we'll use stdio and low-level IO instead. */ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; -# ifdef PERL_MEM_LOG_TIMESTAMP - struct timeval tv; + # ifdef HAS_GETTIMEOFDAY +# define MEM_LOG_TIME_FMT "%10d.%06d: " +# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec + struct timeval tv; gettimeofday(&tv, 0); +# else +# define MEM_LOG_TIME_FMT "%10d: " +# define MEM_LOG_TIME_ARG (int)when + Time_t when; + (void)time(&when); # endif /* If there are other OS specific ways of hires time than - * gettimeofday() (see ext/Time/HiRes), the easiest way is + * gettimeofday() (see ext/Time-HiRes), the easiest way is * probably that they would be used to fill in the struct * timeval. */ -# endif { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " -# endif - "alloc: %s:%d:%s: %"IVdf" %"UVuf - " %s = %"IVdf": %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, -# endif - filename, linenumber, funcname, n, typesize, - typename, n * typesize, PTR2UV(newalloc)); -# ifdef PERL_MEM_LOG_ENV_FD - s = PerlEnv_getenv("PERL_MEM_LOG_FD"); - PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); -# else - PerlLIO_write(PERL_MEM_LOG_FD, buf, len); -#endif + STRLEN len; + int fd = atoi(pmlenv); + if (!fd) + fd = PERL_MEM_LOG_FD; + + if (strchr(pmlenv, 't')) { + len = my_snprintf(buf, sizeof(buf), + MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); + PerlLIO_write(fd, buf, len); + } + switch (mlt) { + case MLT_ALLOC: + len = my_snprintf(buf, sizeof(buf), + "alloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + type_name, n * typesize, PTR2UV(newalloc)); + break; + case MLT_REALLOC: + len = my_snprintf(buf, sizeof(buf), + "realloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + type_name, n * typesize, PTR2UV(oldalloc), + PTR2UV(newalloc)); + break; + case MLT_FREE: + len = my_snprintf(buf, sizeof(buf), + "free: %s:%d:%s: %"UVxf"\n", + filename, linenumber, funcname, + PTR2UV(oldalloc)); + break; + case MLT_NEW_SV: + case MLT_DEL_SV: + len = my_snprintf(buf, sizeof(buf), + "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n", + mlt == MLT_NEW_SV ? "new" : "del", + filename, linenumber, funcname, + PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); + break; + default: + len = 0; + } + PerlLIO_write(fd, buf, len); } } +} +#endif /* !PERL_MEM_LOG_NOIMPL */ + +#ifndef PERL_MEM_LOG_NOIMPL +# define \ + mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \ + mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) +#else +/* this is suboptimal, but bug compatible. User is providing their + own 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) \ + /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */ #endif + +Malloc_t +Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, + Malloc_t newalloc, + const char *filename, const int linenumber, + const char *funcname) +{ + mem_log_common_if(MLT_ALLOC, n, typesize, type_name, + NULL, NULL, newalloc, + filename, linenumber, funcname); return newalloc; } Malloc_t -Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) -{ -#ifdef PERL_MEM_LOG_STDERR -# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; -# endif -# ifdef PERL_MEM_LOG_ENV - s = PerlEnv_getenv("PERL_MEM_LOG"); - if (s ? atoi(s) : 0) -# endif - { - /* We can't use SVs or PerlIO for obvious reasons, - * so we'll use stdio and low-level IO instead. */ - char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; -# ifdef PERL_MEM_LOG_TIMESTAMP - struct timeval tv; - gettimeofday(&tv, 0); -# endif - { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " -# endif - "realloc: %s:%d:%s: %"IVdf" %"UVuf - " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, -# endif - filename, linenumber, funcname, n, typesize, - typename, n * typesize, PTR2UV(oldalloc), - PTR2UV(newalloc)); -# ifdef PERL_MEM_LOG_ENV_FD - s = PerlEnv_getenv("PERL_MEM_LOG_FD"); - PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); -# else - PerlLIO_write(PERL_MEM_LOG_FD, buf, len); -# endif - } - } -#endif +Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, + Malloc_t oldalloc, Malloc_t newalloc, + const char *filename, const int linenumber, + const char *funcname) +{ + mem_log_common_if(MLT_REALLOC, n, typesize, type_name, + NULL, oldalloc, newalloc, + filename, linenumber, funcname); return newalloc; } Malloc_t -Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) +Perl_mem_log_free(Malloc_t oldalloc, + const char *filename, const int linenumber, + const char *funcname) { -#ifdef PERL_MEM_LOG_STDERR -# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; -# endif -# ifdef PERL_MEM_LOG_ENV - s = PerlEnv_getenv("PERL_MEM_LOG"); - if (s ? atoi(s) : 0) -# endif - { - /* We can't use SVs or PerlIO for obvious reasons, - * so we'll use stdio and low-level IO instead. */ - char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; -# ifdef PERL_MEM_LOG_TIMESTAMP - struct timeval tv; - gettimeofday(&tv, 0); -# endif - { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " -# endif - "free: %s:%d:%s: %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, -# endif - filename, linenumber, funcname, - PTR2UV(oldalloc)); -# ifdef PERL_MEM_LOG_ENV_FD - s = PerlEnv_getenv("PERL_MEM_LOG_FD"); - PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); -# else - PerlLIO_write(PERL_MEM_LOG_FD, buf, len); -# endif - } - } -#endif + mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, + filename, linenumber, funcname); return oldalloc; } +void +Perl_mem_log_new_sv(const SV *sv, + const char *filename, const int linenumber, + const char *funcname) +{ + mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, + filename, linenumber, funcname); +} + +void +Perl_mem_log_del_sv(const SV *sv, + const char *filename, const int linenumber, + const char *funcname) +{ + mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, + filename, linenumber, funcname); +} + #endif /* PERL_MEM_LOG */ /* @@ -5367,6 +6130,7 @@ int Perl_my_sprintf(char *buffer, const char* pat, ...) { va_list args; + PERL_ARGS_ASSERT_MY_SPRINTF; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); @@ -5392,6 +6156,7 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) dTHX; int retval; va_list ap; + PERL_ARGS_ASSERT_MY_SNPRINTF; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); @@ -5399,8 +6164,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; } @@ -5423,6 +6194,9 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap int retval; #ifdef NEED_VA_COPY va_list apc; + + PERL_ARGS_ASSERT_MY_VSNPRINTF; + Perl_va_copy(ap, apc); # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, apc); @@ -5436,8 +6210,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; } @@ -5475,13 +6255,14 @@ Perl_my_clearenv(pTHX) char *buf = (char*)safesysmalloc(bufsiz); while (*environ != NULL) { char *e = strchr(*environ, '='); - int l = e ? e - *environ : strlen(*environ); + int l = e ? e - *environ : (int)strlen(*environ); if (bsiz < l + 1) { (void)safesysfree(buf); bsiz = l + 1; /* + 1 for the \0. */ buf = (char*)safesysmalloc(bufsiz); } - my_strlcpy(buf, *environ, l + 1); + memcpy(buf, *environ, l); + buf[l] = '\0'; (void)unsetenv(buf); } (void)safesysfree(buf); @@ -5498,23 +6279,29 @@ Perl_my_clearenv(pTHX) #ifdef PERL_IMPLICIT_CONTEXT -/* implements the MY_CXT_INIT macro. The first time a module is loaded, +/* Implements the MY_CXT_INIT macro. The first time a module is loaded, the global PL_my_cxt_index is incremented, and that value is assigned to that module's static my_cxt_index (who's address is passed as an arg). Then, for each interpreter this function is called for, it makes sure a void* slot is available to hang the static data off, by allocating or extending the interpreter's PL_my_cxt_list array */ +#ifndef PERL_GLOBAL_STRUCT_PRIVATE void * Perl_my_cxt_init(pTHX_ int *index, size_t size) { dVAR; void *p; + PERL_ARGS_ASSERT_MY_CXT_INIT; if (*index == -1) { /* this module hasn't been allocated an index yet */ +#if defined(USE_ITHREADS) MUTEX_LOCK(&PL_my_ctx_mutex); +#endif *index = PL_my_cxt_index++; +#if defined(USE_ITHREADS) MUTEX_UNLOCK(&PL_my_ctx_mutex); +#endif } /* make sure the array is big enough */ @@ -5535,7 +6322,156 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size) Zero(p, size, char); return p; } + +#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ + +int +Perl_my_cxt_index(pTHX_ const char *my_cxt_key) +{ + dVAR; + int index; + + PERL_ARGS_ASSERT_MY_CXT_INDEX; + + for (index = 0; index < PL_my_cxt_index; index++) { + const char *key = PL_my_cxt_keys[index]; + /* try direct pointer compare first - there are chances to success, + * and it's much faster. + */ + if ((key == my_cxt_key) || strEQ(key, my_cxt_key)) + return index; + } + return -1; +} + +void * +Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) +{ + dVAR; + void *p; + int index; + + PERL_ARGS_ASSERT_MY_CXT_INIT; + + index = Perl_my_cxt_index(aTHX_ my_cxt_key); + if (index == -1) { + /* this module hasn't been allocated an index yet */ +#if defined(USE_ITHREADS) + MUTEX_LOCK(&PL_my_ctx_mutex); #endif + index = PL_my_cxt_index++; +#if defined(USE_ITHREADS) + MUTEX_UNLOCK(&PL_my_ctx_mutex); +#endif + } + + /* make sure the array is big enough */ + if (PL_my_cxt_size <= index) { + int old_size = PL_my_cxt_size; + int i; + if (PL_my_cxt_size) { + while (PL_my_cxt_size <= index) + PL_my_cxt_size *= 2; + Renew(PL_my_cxt_list, PL_my_cxt_size, void *); + Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *); + } + else { + PL_my_cxt_size = 16; + Newx(PL_my_cxt_list, PL_my_cxt_size, void *); + Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); + } + for (i = old_size; i < PL_my_cxt_size; i++) { + PL_my_cxt_keys[i] = 0; + PL_my_cxt_list[i] = 0; + } + } + PL_my_cxt_keys[index] = my_cxt_key; + /* newSV() allocates one more than needed */ + p = (void*)SvPVX(newSV(size-1)); + PL_my_cxt_list[index] = p; + Zero(p, size, char); + return p; +} +#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ +#endif /* PERL_IMPLICIT_CONTEXT */ + +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_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 @@ -5570,6 +6506,91 @@ Perl_my_strlcpy(char *dst, const char *src, Size_t size) } #endif +#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500) +/* VC7 or 7.1, building with pre-VC7 runtime libraries. */ +long _ftol( double ); /* Defined by VC6 C libs. */ +long _ftol2( double dblSource ) { return _ftol( dblSource ); } +#endif + +void +Perl_get_db_sub(pTHX_ SV **svp, CV *cv) +{ + dVAR; + SV * const dbsv = GvSVn(PL_DBsub); + const bool save_taint = PL_tainted; + + /* We do not care about using sv 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 *gv = CvGV(cv); + + if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + || strEQ(GvNAME(gv), "END") + || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ + !( (SvTYPE(*svp) == SVt_PVGV) + && (GvCV((const GV *)*svp) == cv) + && (gv = (GV *)*svp) + ) + ) + )) { + /* Use GV from the stack as a fallback. */ + /* GV is potentially non-unique, or contain different CV. */ + SV * const tmp = newRV(MUTABLE_SV(cv)); + sv_setsv(dbsv, tmp); + SvREFCNT_dec(tmp); + } + else { + gv_efullname3(dbsv, gv, NULL); + } + } + else { + const int type = SvTYPE(dbsv); + if (type < SVt_PVIV && type != SVt_IV) + sv_upgrade(dbsv, SVt_PVIV); + (void)SvIOK_on(dbsv); + SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ + } + TAINT_IF(save_taint); +} + +int +Perl_my_dirfd(pTHX_ DIR * dir) { + + /* Most dirfd implementations have problems when passed NULL. */ + if(!dir) + return -1; +#ifdef HAS_DIRFD + return dirfd(dir); +#elif defined(HAS_DIR_DD_FD) + return dir->dd_fd; +#else + Perl_die(aTHX_ PL_no_func, "dirfd"); + /* NOT REACHED */ + return 0; +#endif +} + +REGEXP * +Perl_get_re_arg(pTHX_ SV *sv) { + + if (sv) { + if (SvMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv)) + sv = MUTABLE_SV(SvRV(sv)); + if (SvTYPE(sv) == SVt_REGEXP) + return (REGEXP*) sv; + } + + return NULL; +} + /* * Local variables: * c-indentation-style: bsd