X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8e7615cb2f19df1393c4e187d2c3ef6cb73e2b1a..255b632a2a78b37a9400b7f7509a23f0e040de5c:/util.c diff --git a/util.c b/util.c index d57676e..165d13a 100644 --- a/util.c +++ b/util.c @@ -132,6 +132,7 @@ Perl_safesysmalloc(MEM_SIZE size) dTHX; #endif Malloc_t ptr; + dSAVEDERRNO; #ifdef USE_MDH if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) @@ -143,6 +144,7 @@ Perl_safesysmalloc(MEM_SIZE size) Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size); #endif if (!size) size = 1; /* malloc(0) is NASTY on our system */ + SAVE_ERRNO; #ifdef PERL_DEBUG_READONLY_COW if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { @@ -182,6 +184,11 @@ Perl_safesysmalloc(MEM_SIZE size) ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); + /* malloc() can modify errno() even on success, but since someone + writing perl code doesn't have any control over when perl calls + malloc() we need to hide that. + */ + RESTORE_ERRNO; } else { #ifdef USE_MDH @@ -223,6 +230,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) ptr = safesysmalloc(size); } else { + dSAVE_ERRNO; #ifdef USE_MDH where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) @@ -296,6 +304,12 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) maybe_protect_ro(header->prev); #endif ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); + + /* realloc() can modify errno() even on success, but since someone + writing perl code doesn't have any control over when perl calls + realloc() we need to hide that. + */ + RESTORE_ERRNO; } /* In particular, must do that fixup above before logging anything via @@ -577,7 +591,7 @@ Perl_delimcpy_no_escape(char *to, const char *toend, const char *from, /* =head1 Miscellaneous Functions -=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end +=for apidoc ninstr Find the first (leftmost) occurrence of a sequence of bytes within another sequence. This is the Perl version of C, extended to handle @@ -638,7 +652,7 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char /* =head1 Miscellaneous Functions -=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end +=for apidoc rninstr Like C>, but instead finds the final (rightmost) occurrence of a sequence of bytes within another sequence, returning C if there is no @@ -1273,7 +1287,7 @@ Perl_vform(pTHX_ const char *pat, va_list *args) } /* -=for apidoc Am|SV *|mess|const char *pat|... +=for apidoc mess 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, @@ -1354,7 +1368,7 @@ Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, } /* -=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume +=for apidoc mess_sv 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 @@ -1458,7 +1472,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) } /* -=for apidoc Am|SV *|vmess|const char *pat|va_list *args +=for apidoc vmess C and C are a sprintf-style format pattern and encapsulated argument list, respectively. These are used to generate a string message. If @@ -1570,7 +1584,7 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn) } /* -=for apidoc Am|OP *|die_sv|SV *baseex +=for apidoc die_sv Behaves the same as L, except for the return type. It should be used only where the C return type is required. @@ -1579,13 +1593,8 @@ The function never actually returns. =cut */ -#ifdef _MSC_VER -# pragma warning( push ) -# pragma warning( disable : 4646 ) /* warning C4646: function declared with - __declspec(noreturn) has non-void return type */ -# pragma warning( disable : 4645 ) /* warning C4645: function declared with -__declspec(noreturn) has a return statement */ -#endif +/* silence __declspec(noreturn) warnings */ +MSVC_DIAG_IGNORE(4646 4645) OP * Perl_die_sv(pTHX_ SV *baseex) { @@ -1594,12 +1603,10 @@ Perl_die_sv(pTHX_ SV *baseex) /* NOTREACHED */ NORETURN_FUNCTION_END; } -#ifdef _MSC_VER -# pragma warning( pop ) -#endif +MSVC_DIAG_RESTORE /* -=for apidoc Am|OP *|die|const char *pat|... +=for apidoc die Behaves the same as L, except for the return type. It should be used only where the C return type is required. @@ -1609,13 +1616,9 @@ The function never actually returns. */ #if defined(PERL_IMPLICIT_CONTEXT) -#ifdef _MSC_VER -# pragma warning( push ) -# pragma warning( disable : 4646 ) /* warning C4646: function declared with - __declspec(noreturn) has non-void return type */ -# pragma warning( disable : 4645 ) /* warning C4645: function declared with -__declspec(noreturn) has a return statement */ -#endif + +/* silence __declspec(noreturn) warnings */ +MSVC_DIAG_IGNORE(4646 4645) OP * Perl_die_nocontext(const char* pat, ...) { @@ -1627,18 +1630,12 @@ Perl_die_nocontext(const char* pat, ...) va_end(args); NORETURN_FUNCTION_END; } -#ifdef _MSC_VER -# pragma warning( pop ) -#endif +MSVC_DIAG_RESTORE + #endif /* PERL_IMPLICIT_CONTEXT */ -#ifdef _MSC_VER -# pragma warning( push ) -# pragma warning( disable : 4646 ) /* warning C4646: function declared with - __declspec(noreturn) has non-void return type */ -# pragma warning( disable : 4645 ) /* warning C4645: function declared with -__declspec(noreturn) has a return statement */ -#endif +/* silence __declspec(noreturn) warnings */ +MSVC_DIAG_IGNORE(4646 4645) OP * Perl_die(pTHX_ const char* pat, ...) { @@ -1649,12 +1646,10 @@ Perl_die(pTHX_ const char* pat, ...) va_end(args); NORETURN_FUNCTION_END; } -#ifdef _MSC_VER -# pragma warning( pop ) -#endif +MSVC_DIAG_RESTORE /* -=for apidoc Am|void|croak_sv|SV *baseex +=for apidoc croak_sv This is an XS interface to Perl's C function. @@ -1684,7 +1679,7 @@ Perl_croak_sv(pTHX_ SV *baseex) } /* -=for apidoc Am|void|vcroak|const char *pat|va_list *args +=for apidoc vcroak This is an XS interface to Perl's C function. @@ -1717,7 +1712,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) } /* -=for apidoc Am|void|croak|const char *pat|... +=for apidoc croak This is an XS interface to Perl's C function. @@ -1764,7 +1759,7 @@ Perl_croak(pTHX_ const char *pat, ...) } /* -=for apidoc Am|void|croak_no_modify +=for apidoc croak_no_modify Exactly equivalent to C, but generates terser object code than using C. Less code used on exception code @@ -1807,7 +1802,7 @@ Perl_croak_popstack(void) } /* -=for apidoc Am|void|warn_sv|SV *baseex +=for apidoc warn_sv This is an XS interface to Perl's C function. @@ -1835,7 +1830,7 @@ Perl_warn_sv(pTHX_ SV *baseex) } /* -=for apidoc Am|void|vwarn|const char *pat|va_list *args +=for apidoc vwarn This is an XS interface to Perl's C function. @@ -1863,7 +1858,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) } /* -=for apidoc Am|void|warn|const char *pat|... +=for apidoc warn This is an XS interface to Perl's C function. @@ -5204,62 +5199,12 @@ Perl_my_clearenv(pTHX) #ifdef PERL_IMPLICIT_CONTEXT -/* 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 *indexp, size_t size) -{ - dVAR; - void *p; - int index; - - PERL_ARGS_ASSERT_MY_CXT_INIT; - - index = *indexp; - /* do initial check without locking. - * -1: not allocated or another thread currently allocating - * other: already allocated by another thread - */ - if (index == -1) { - MUTEX_LOCK(&PL_my_ctx_mutex); - /*now a stricter check with locking */ - index = *indexp; - if (index == -1) - /* this module hasn't been allocated an index yet */ - *indexp = PL_my_cxt_index++; - index = *indexp; - MUTEX_UNLOCK(&PL_my_ctx_mutex); - } - /* make sure the array is big enough */ - if (PL_my_cxt_size <= index) { - if (PL_my_cxt_size) { - IV new_size = PL_my_cxt_size; - while (new_size <= index) - new_size *= 2; - Renew(PL_my_cxt_list, new_size, void *); - PL_my_cxt_size = new_size; - } - else { - PL_my_cxt_size = 16; - Newx(PL_my_cxt_list, PL_my_cxt_size, void *); - } - } - /* newSV() allocates one more than needed */ - p = (void*)SvPVX(newSV(size-1)); - PL_my_cxt_list[index] = p; - Zero(p, size, char); - return p; -} - -#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ +# ifdef PERL_GLOBAL_STRUCT_PRIVATE +/* rather than each module having a static var holding its index, + * use a global array of name to index mappings + */ int Perl_my_cxt_index(pTHX_ const char *my_cxt_key) { @@ -5278,9 +5223,22 @@ Perl_my_cxt_index(pTHX_ const char *my_cxt_key) } return -1; } +# endif + + +/* 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 */ void * +# ifdef PERL_GLOBAL_STRUCT_PRIVATE Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) +# else +Perl_my_cxt_init(pTHX_ int *indexp, size_t size) +# endif { dVAR; void *p; @@ -5288,7 +5246,11 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) PERL_ARGS_ASSERT_MY_CXT_INIT; +# ifdef PERL_GLOBAL_STRUCT_PRIVATE index = Perl_my_cxt_index(aTHX_ my_cxt_key); +# else + index = *indexp; +# endif /* do initial check without locking. * -1: not allocated or another thread currently allocating * other: already allocated by another thread @@ -5296,9 +5258,14 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) if (index == -1) { MUTEX_LOCK(&PL_my_ctx_mutex); /*now a stricter check with locking */ +# ifdef PERL_GLOBAL_STRUCT_PRIVATE index = Perl_my_cxt_index(aTHX_ my_cxt_key); +# else + index = *indexp; +# endif if (index == -1) /* this module hasn't been allocated an index yet */ +# ifdef PERL_GLOBAL_STRUCT_PRIVATE index = PL_my_cxt_index++; /* Store the index in a global MY_CXT_KEY string to index mapping @@ -5326,14 +5293,15 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) } } PL_my_cxt_keys[index] = my_cxt_key; - +# else + *indexp = PL_my_cxt_index++; + index = *indexp; +# endif MUTEX_UNLOCK(&PL_my_ctx_mutex); } /* 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) { IV new_size = PL_my_cxt_size; while (new_size <= index) @@ -5345,9 +5313,6 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) PL_my_cxt_size = 16; Newx(PL_my_cxt_list, PL_my_cxt_size, void *); } - for (i = old_size; i < PL_my_cxt_size; i++) { - PL_my_cxt_list[i] = 0; - } } /* newSV() allocates one more than needed */ p = (void*)SvPVX(newSV(size-1)); @@ -5355,7 +5320,7 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) Zero(p, size, char); return p; } -#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ + #endif /* PERL_IMPLICIT_CONTEXT */ @@ -5747,6 +5712,11 @@ S_my_mkostemp(char *templte, int flags) { STRLEN len = strlen(templte); int fd; int attempts = 0; +#ifdef VMS + int delete_on_close = flags & O_VMS_DELETEONCLOSE; + + flags &= ~O_VMS_DELETEONCLOSE; +#endif if (len < 6 || templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' || @@ -5760,7 +5730,15 @@ S_my_mkostemp(char *templte, int flags) { for (i = 1; i <= 6; ++i) { templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)]; } - fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600); +#ifdef VMS + if (delete_on_close) { + fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt"); + } + else +#endif + { + fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600); + } } while (fd == -1 && errno == EEXIST && ++attempts <= 100); return fd;