X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/148f39b7de6eae9ddd59e0b0aff691d6abea7aca..f227048406ab4605a8a3459c4b08d8c1aad78d86:/util.c diff --git a/util.c b/util.c index f5573e1..28be5ca 100644 --- a/util.c +++ b/util.c @@ -128,7 +128,12 @@ Perl_safesysmalloc(MEM_SIZE size) dTHX; #endif Malloc_t ptr; + +#ifdef USE_MDH + if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) + goto out_of_memory; size += PERL_MEMORY_DEBUG_HEADER_SIZE; +#endif #ifdef DEBUGGING if ((SSize_t)size < 0) Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size); @@ -170,21 +175,25 @@ Perl_safesysmalloc(MEM_SIZE size) #ifdef MDH_HAS_SIZE header->size = size; #endif - ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_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)); - return ptr; -} + + } else { +#ifdef USE_MDH + out_of_memory: +#endif + { #ifndef ALWAYS_NEED_THX - dTHX; + dTHX; #endif - if (PL_nomemok) - return NULL; - else { - croak_no_mem(); - } + if (PL_nomemok) + ptr = NULL; + else + croak_no_mem(); + } } - /*NOTREACHED*/ + return ptr; } /* paranoid version of system's realloc() */ @@ -207,105 +216,109 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (!size) { safesysfree(where); - return NULL; + ptr = NULL; } - - if (!where) - return safesysmalloc(size); + else if (!where) { + ptr = safesysmalloc(size); + } + else { #ifdef USE_MDH - where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); - size += PERL_MEMORY_DEBUG_HEADER_SIZE; - { - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)where; + where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); + if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) + goto out_of_memory; + size += PERL_MEMORY_DEBUG_HEADER_SIZE; + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)where; # ifdef PERL_TRACK_MEMPOOL - if (header->interpreter != aTHX) { - Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p", - header->interpreter, aTHX); - } - assert(header->next->prev == header); - assert(header->prev->next == header); + if (header->interpreter != aTHX) { + Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p", + header->interpreter, aTHX); + } + assert(header->next->prev == header); + assert(header->prev->next == header); # ifdef PERL_POISON - if (header->size > size) { - const MEM_SIZE freed_up = header->size - size; - char *start_of_freed = ((char *)where) + size; - PoisonFree(start_of_freed, freed_up, char); - } + if (header->size > size) { + const MEM_SIZE freed_up = header->size - size; + char *start_of_freed = ((char *)where) + size; + PoisonFree(start_of_freed, freed_up, char); + } # endif # endif # ifdef MDH_HAS_SIZE - header->size = size; + header->size = size; # endif - } + } #endif #ifdef DEBUGGING - if ((SSize_t)size < 0) - Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size); + if ((SSize_t)size < 0) + Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size); #endif #ifdef PERL_DEBUG_READONLY_COW - if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, - MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { - perror("mmap failed"); - abort(); - } - Copy(where,ptr,oldsize < size ? oldsize : size,char); - if (munmap(where, oldsize)) { - perror("munmap failed"); - abort(); - } + if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, + MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { + perror("mmap failed"); + abort(); + } + Copy(where,ptr,oldsize < size ? oldsize : size,char); + if (munmap(where, oldsize)) { + perror("munmap failed"); + abort(); + } #else - ptr = (Malloc_t)PerlMem_realloc(where,size); + ptr = (Malloc_t)PerlMem_realloc(where,size); #endif - PERL_ALLOC_CHECK(ptr); + PERL_ALLOC_CHECK(ptr); /* 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. */ - if (ptr != NULL) { + if (ptr != NULL) { #ifdef PERL_TRACK_MEMPOOL - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)ptr; + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; # ifdef PERL_POISON - if (header->size < size) { - const MEM_SIZE fresh = size - header->size; - char *start_of_fresh = ((char *)ptr) + size; - PoisonNew(start_of_fresh, fresh, char); - } + if (header->size < size) { + const MEM_SIZE fresh = size - header->size; + char *start_of_fresh = ((char *)ptr) + size; + PoisonNew(start_of_fresh, fresh, char); + } # endif - maybe_protect_rw(header->next); - header->next->prev = header; - maybe_protect_ro(header->next); - maybe_protect_rw(header->prev); - header->prev->next = header; - maybe_protect_ro(header->prev); + maybe_protect_rw(header->next); + header->next->prev = header; + maybe_protect_ro(header->next); + maybe_protect_rw(header->prev); + header->prev->next = header; + maybe_protect_ro(header->prev); #endif - ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); - } + ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); + } /* 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)); + 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 (ptr == NULL) { +#ifdef USE_MDH + out_of_memory: +#endif + { #ifndef ALWAYS_NEED_THX - dTHX; + dTHX; #endif - if (PL_nomemok) - return NULL; - else { - croak_no_mem(); + if (PL_nomemok) + ptr = NULL; + else + croak_no_mem(); + } } } - /*NOTREACHED*/ + return ptr; } /* safe version of system's free() */ @@ -315,16 +328,14 @@ Perl_safesysfree(Malloc_t where) { #ifdef ALWAYS_NEED_THX dTHX; -#else - dVAR; #endif DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { #ifdef USE_MDH - where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); + Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); { struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)where; + = (struct perl_memory_debug_header *)where_intrn; # ifdef MDH_HAS_SIZE const MEM_SIZE size = header->size; @@ -354,21 +365,23 @@ Perl_safesysfree(Malloc_t where) maybe_protect_ro(header->prev); maybe_protect_rw(header); # ifdef PERL_POISON - PoisonNew(where, size, char); + PoisonNew(where_intrn, size, char); # endif /* Trigger the duplicate free warning. */ header->next = NULL; # endif # ifdef PERL_DEBUG_READONLY_COW - if (munmap(where, size)) { + if (munmap(where_intrn, size)) { perror("munmap failed"); abort(); } # endif } -#endif +#else + Malloc_t where_intrn = where; +#endif /* USE_MDH */ #ifndef PERL_DEBUG_READONLY_COW - PerlMem_free(where); + PerlMem_free(where_intrn); #endif } } @@ -473,25 +486,33 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) Malloc_t Perl_malloc (MEM_SIZE nbytes) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif return (Malloc_t)PerlMem_malloc(nbytes); } Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif return (Malloc_t)PerlMem_calloc(elements, size); } Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif return (Malloc_t)PerlMem_realloc(where, nbytes); } Free_t Perl_mfree (Malloc_t where) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif PerlMem_free(where); } @@ -535,10 +556,6 @@ Perl_instr(const char *big, const char *little) PERL_ARGS_ASSERT_INSTR; - /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL - * 'little' */ - if (!little) - return (char*)big; return strstr((char*)big, (char*)little); } @@ -622,7 +639,6 @@ Analyses the string in order to make fast searches on it using fbm_instr() void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { - dVAR; const U8 *s; STRLEN i; STRLEN len; @@ -910,24 +926,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } } -char * -Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) -{ - dVAR; - PERL_ARGS_ASSERT_SCREAMINSTR; - PERL_UNUSED_ARG(bigstr); - PERL_UNUSED_ARG(littlestr); - PERL_UNUSED_ARG(start_shift); - PERL_UNUSED_ARG(end_shift); - PERL_UNUSED_ARG(old_posp); - PERL_UNUSED_ARG(last); - - /* This function must only ever be called on a scalar with study magic, - but those do not happen any more. */ - Perl_croak(aTHX_ "panic: screaminstr"); - NORETURN_FUNCTION_END; -} - /* =for apidoc foldEQ @@ -1184,7 +1182,6 @@ Perl_savesharedsvpv(pTHX_ SV *sv) STATIC SV * S_mess_alloc(pTHX) { - dVAR; SV *sv; XPVMG *any; @@ -1307,7 +1304,6 @@ const COP* Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, bool opnext) { - dVAR; /* Look for curop starting from o. cop is the last COP we've seen. */ /* opnext means that curop is actually the ->op_next of the op we are seeking. */ @@ -1321,7 +1317,7 @@ Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, if (o->op_flags & OPf_KIDS) { const OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { const COP *new_cop; /* If the OP_NEXTSTATE has been optimised away we can still use it @@ -1370,17 +1366,18 @@ required) to modify and return C instead of allocating a new SV. SV * Perl_mess_sv(pTHX_ SV *basemsg, bool consume) { - dVAR; SV *sv; #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR) { char *ws; - int wi; + UV wi; /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */ - if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) && - (wi = atoi(ws)) > 0) { - Perl_dump_c_backtrace(aTHX_ Perl_debug_log, wi, 1); + if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) + && grok_atoUV(ws, &wi, NULL) + && wi <= PERL_INT_MAX + ) { + Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1); } } #endif @@ -1415,7 +1412,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) */ const COP *cop = - closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE); + closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE); if (!cop) cop = PL_curcop; @@ -1462,7 +1459,6 @@ this function. SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { - dVAR; SV * const sv = mess_alloc(); PERL_ARGS_ASSERT_VMESS; @@ -1474,7 +1470,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) void Perl_write_to_stderr(pTHX_ SV* msv) { - dVAR; IO *io; MAGIC *mg; @@ -1514,7 +1509,6 @@ S_with_queued_errors(pTHX_ SV *ex) STATIC bool S_invoke_exception_hook(pTHX_ SV *ex, bool warn) { - dVAR; HV *stash; GV *gv; CV *cv; @@ -1535,7 +1529,6 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn) SV *exarg; ENTER; - save_re_context(); if (warn) { SAVESPTR(*hook); *hook = NULL; @@ -1566,15 +1559,24 @@ 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 OP * Perl_die_sv(pTHX_ SV *baseex) { PERL_ARGS_ASSERT_DIE_SV; croak_sv(baseex); /* NOTREACHED */ - assert(0); NORETURN_FUNCTION_END; } +#ifdef _MSC_VER +# pragma warning( pop ) +#endif /* =for apidoc Am|OP *|die|const char *pat|... @@ -1587,6 +1589,13 @@ 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 OP * Perl_die_nocontext(const char* pat, ...) { @@ -1594,24 +1603,35 @@ Perl_die_nocontext(const char* pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ - assert(0); + NOT_REACHED; /* NOTREACHED */ va_end(args); NORETURN_FUNCTION_END; } +#ifdef _MSC_VER +# pragma warning( pop ) +#endif #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 OP * Perl_die(pTHX_ const char* pat, ...) { va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ - assert(0); + NOT_REACHED; /* NOTREACHED */ va_end(args); NORETURN_FUNCTION_END; } +#ifdef _MSC_VER +# pragma warning( pop ) +#endif /* =for apidoc Am|void|croak_sv|SV *baseex @@ -1708,8 +1728,7 @@ Perl_croak_nocontext(const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ - assert(0); + NOT_REACHED; /* NOTREACHED */ va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ @@ -1720,8 +1739,7 @@ Perl_croak(pTHX_ const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ - assert(0); + NOT_REACHED; /* NOTREACHED */ va_end(args); } @@ -1922,8 +1940,13 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { SV * const msv = vmess(pat, args); - invoke_exception_hook(msv, FALSE); - die_unwind(msv); + if (PL_parser && PL_parser->error_count) { + qerror(msv); + } + else { + invoke_exception_hook(msv, FALSE); + die_unwind(msv); + } } else { Perl_vwarn(aTHX_ pat, args); @@ -1935,7 +1958,6 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) bool Perl_ckwarn(pTHX_ U32 w) { - dVAR; /* If lexical warnings have not been set, use $^W. */ if (isLEXWARN_off) return PL_dowarn & G_WARN_ON; @@ -1948,7 +1970,6 @@ Perl_ckwarn(pTHX_ U32 w) bool Perl_ckwarn_d(pTHX_ U32 w) { - dVAR; /* If lexical warnings have not been set then default classes warn. */ if (isLEXWARN_off) return TRUE; @@ -2081,7 +2102,11 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) my_setenv_format(environ[i], nam, nlen, val, vlen); } else { # endif -# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) + /* This next branch should only be called #if defined(HAS_SETENV), but + Configure doesn't test for that yet. For Solaris, setenv() and unsetenv() + were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient. + */ +# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) # if defined(HAS_UNSETENV) if (val == NULL) { (void)unsetenv(nam); @@ -2301,7 +2326,6 @@ PerlIO * Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) { #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) - dVAR; int p[2]; I32 This, that; Pid_t pid; @@ -2428,8 +2452,10 @@ Perl_my_popen_list(pTHX_ const 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... */ +# if defined(OS2) /* Same, without fork()ing and all extra overhead... */ return my_syspopen4(aTHX_ NULL, mode, n, args); +# elif defined(WIN32) + return win32_popenlist(mode, n, args); # else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; @@ -2442,7 +2468,6 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { - dVAR; int p[2]; I32 This, that; Pid_t pid; @@ -2614,8 +2639,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) void Perl_atfork_lock(void) { - dVAR; #if defined(USE_ITHREADS) + dVAR; /* locks must be held in locking order (if any) */ # ifdef USE_PERLIO MUTEX_LOCK(&PL_perlio_mutex); @@ -2631,8 +2656,8 @@ Perl_atfork_lock(void) void Perl_atfork_unlock(void) { - dVAR; #if defined(USE_ITHREADS) + dVAR; /* locks must be released in same order as in atfork_lock() */ # ifdef USE_PERLIO MUTEX_UNLOCK(&PL_perlio_mutex); @@ -2706,10 +2731,10 @@ dup2(int oldfd, int newfd) Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { - dVAR; struct sigaction act, oact; #ifdef USE_ITHREADS + dVAR; /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return (Sighandler_t) SIG_ERR; @@ -2747,7 +2772,9 @@ Perl_rsignal_state(pTHX_ int signo) int Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) { +#ifdef USE_ITHREADS dVAR; +#endif struct sigaction act; PERL_ARGS_ASSERT_RSIGNAL_SAVE; @@ -2775,7 +2802,10 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) int Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) { +#ifdef USE_ITHREADS dVAR; +#endif + PERL_UNUSED_CONTEXT; #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) @@ -2857,7 +2887,6 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { - dVAR; int status; SV **svp; Pid_t pid; @@ -2914,7 +2943,6 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { - dVAR; I32 result = 0; PERL_ARGS_ASSERT_WAIT4PID; #ifdef PERL_USES_PL_PIDSTATUS @@ -2953,7 +2981,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) *statusp = SvIVX(sv); /* The hash iterator is currently on this entry, so simply calling hv_delete would trigger the lazy delete, which on - aggregate does more work, beacuse next call to hv_iterinit() + aggregate does more work, because next call to hv_iterinit() would spot the flag, and have to call the delete routine, while in the meantime any new entries can't re-use that memory. */ @@ -3129,7 +3157,6 @@ char* Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char *const *const search_ext, I32 flags) { - dVAR; const char *xfound = NULL; char *xfailed = NULL; char tmpbuf[MAXPATHLEN]; @@ -3349,8 +3376,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, void * Perl_get_context(void) { - dVAR; #if defined(USE_ITHREADS) + dVAR; # ifdef OLD_PTHREADS_API pthread_addr_t t; int error = pthread_getspecific(PL_thr_key, &t) @@ -3372,7 +3399,9 @@ Perl_get_context(void) void Perl_set_context(void *t) { +#if defined(USE_ITHREADS) dVAR; +#endif PERL_ARGS_ASSERT_SET_CONTEXT; #if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS @@ -3395,7 +3424,8 @@ Perl_set_context(void *t) struct perl_vars * Perl_GetVars(pTHX) { - return &PL_Vars; + PERL_UNUSED_CONTEXT; + return &PL_Vars; } #endif @@ -3455,7 +3485,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) PERL_UNUSED_CONTEXT; return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) - ? NULL : PL_magic_vtables + vtbl_id; + ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id; } I32 @@ -3622,13 +3652,12 @@ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ * semantics (and overhead) of mktime(). */ void -Perl_mini_mktime(pTHX_ struct tm *ptm) +Perl_mini_mktime(struct tm *ptm) { int yearday; int secs; int month, mday, year, jday; int odd_cent, odd_year; - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_MINI_MKTIME; @@ -3811,6 +3840,9 @@ char * Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) { #ifdef HAS_STRFTIME + + /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */ + char *buf; int buflen; struct tm mytm; @@ -3919,7 +3951,7 @@ Fill the sv with current working directory /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. * rewritten again by dougm, optimized for use with xs TARG, and to prefer * getcwd(3) if available - * Comments from the orignal: + * Comments from the original: * This is a faster version of getcwd. It's also more dangerous * because you might chdir out of a directory that you can't chdir * back into. */ @@ -3928,7 +3960,6 @@ int Perl_getcwd_sv(pTHX_ SV *sv) { #ifndef PERL_MICRO - dVAR; SvTAINTED_on(sv); PERL_ARGS_ASSERT_GETCWD_SV; @@ -4386,16 +4417,21 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) if (*p) { if (isDIGIT(*p)) { - opt = (U32) atoi(p); - while (isDIGIT(*p)) - p++; - 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 { + const char* endptr; + UV uv; + if (grok_atoUV(p, &uv, &endptr) + && uv <= U32_MAX + && (p = endptr) + && *p && *p != '\n' && *p != '\r' + ) { + opt = (U32)uv; + if (isSPACE(*p)) + goto the_end_of_the_opts_parser; + else + Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); + } + } + else { for (; *p; p++) { switch (*p) { case PERL_UNICODE_STDIN: @@ -4450,7 +4486,6 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) U32 Perl_seed(pTHX) { - dVAR; /* * This is really just a quick hack which grabs various garbage * values. It really should be a real hash algorithm which @@ -4531,7 +4566,6 @@ Perl_seed(pTHX) void Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) { - dVAR; const char *env_pv; unsigned long i; @@ -4621,6 +4655,7 @@ Perl_init_global_struct(pTHX) # ifdef PERL_GLOBAL_STRUCT const IV nppaddr = C_ARRAY_LENGTH(Gppaddr); const IV ncheck = C_ARRAY_LENGTH(Gcheck); + PERL_UNUSED_CONTEXT; # ifdef PERL_GLOBAL_STRUCT_PRIVATE /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); @@ -4678,6 +4713,7 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) int veto = plvarsp->Gveto_cleanup; PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; + PERL_UNUSED_CONTEXT; # ifdef PERL_GLOBAL_STRUCT # ifdef PERL_UNSET_VARS PERL_UNSET_VARS(plvarsp); @@ -4696,14 +4732,14 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) #ifdef PERL_MEM_LOG -/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the +/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also * given, and you supply your own implementation. * * The default implementation reads a single env var, PERL_MEM_LOG, * expecting one or more of the following: * - * \d+ - fd fd to write to : must be 1st (atoi) + * \d+ - fd fd to write to : must be 1st (grok_atoUV) * 'm' - memlog was PERL_MEM_LOG=1 * 's' - svlog was PERL_SV_LOG=1 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 @@ -4771,9 +4807,16 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, * timeval. */ { STRLEN len; - int fd = atoi(pmlenv); - if (!fd) + const char* endptr; + int fd; + UV uv; + if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */ + && uv && uv <= PERL_INT_MAX + ) { + fd = (int)uv; + } else { fd = PERL_MEM_LOG_FD; + } if (strchr(pmlenv, 't')) { len = my_snprintf(buf, sizeof(buf), @@ -4909,6 +4952,112 @@ Perl_my_sprintf(char *buffer, const char* pat, ...) #endif /* +=for apidoc quadmath_format_single + +quadmath_snprintf() is very strict about its format string and will +fail, returning -1, if the format is invalid. It acccepts exactly +one format spec. + +quadmath_format_single() checks that the intended single spec looks +sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>, +and has C before it. This is not a full "printf syntax check", +just the basics. + +Returns the format if it is valid, NULL if not. + +quadmath_format_single() can and will actually patch in the missing +C, if necessary. In this case it will return the modified copy of +the format, B + +See also L. + +=cut +*/ +#ifdef USE_QUADMATH +const char* +Perl_quadmath_format_single(const char* format) +{ + STRLEN len; + + PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE; + + if (format[0] != '%' || strchr(format + 1, '%')) + return NULL; + len = strlen(format); + /* minimum length three: %Qg */ + if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL) + return NULL; + if (format[len - 2] != 'Q') { + char* fixed; + Newx(fixed, len + 1, char); + memcpy(fixed, format, len - 1); + fixed[len - 1] = 'Q'; + fixed[len ] = format[len - 1]; + fixed[len + 1] = 0; + return (const char*)fixed; + } + return format; +} +#endif + +/* +=for apidoc quadmath_format_needed + +quadmath_format_needed() returns true if the format string seems to +contain at least one non-Q-prefixed %[efgaEFGA] format specifier, +or returns false otherwise. + +The format specifier detection is not complete printf-syntax detection, +but it should catch most common cases. + +If true is returned, those arguments B in theory be processed +with quadmath_snprintf(), but in case there is more than one such +format specifier (see L), and if there is +anything else beyond that one (even just a single byte), they +B be processed because quadmath_snprintf() is very strict, +accepting only one format spec, and nothing else. +In this case, the code should probably fail. + +=cut +*/ +#ifdef USE_QUADMATH +bool +Perl_quadmath_format_needed(const char* format) +{ + const char *p = format; + const char *q; + + PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED; + + while ((q = strchr(p, '%'))) { + q++; + if (*q == '+') /* plus */ + q++; + if (*q == '#') /* alt */ + q++; + if (*q == '*') /* width */ + q++; + else { + if (isDIGIT(*q)) { + while (isDIGIT(*q)) q++; + } + } + if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */ + q++; + if (*q == '*') + q++; + else + while (isDIGIT(*q)) q++; + } + if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */ + return TRUE; + p = q + 1; + } + return FALSE; +} +#endif + +/* =for apidoc my_snprintf The C library C functionality, if available and @@ -4923,14 +5072,59 @@ getting C. int Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) { - int retval; + int retval = -1; va_list ap; PERL_ARGS_ASSERT_MY_SNPRINTF; +#ifndef HAS_VSNPRINTF + PERL_UNUSED_VAR(len); +#endif va_start(ap, format); +#ifdef USE_QUADMATH + { + const char* qfmt = quadmath_format_single(format); + bool quadmath_valid = FALSE; + if (qfmt) { + /* If the format looked promising, use it as quadmath. */ + retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV)); + if (retval == -1) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); + quadmath_valid = TRUE; + if (qfmt != format) + Safefree(qfmt); + qfmt = NULL; + } + assert(qfmt == NULL); + /* quadmath_format_single() will return false for example for + * "foo = %g", or simply "%g". We could handle the %g by + * using quadmath for the NV args. More complex cases of + * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise + * quadmath-valid but has stuff in front). + * + * Handling the "Q-less" cases right would require walking + * through the va_list and rewriting the format, calling + * quadmath for the NVs, building a new va_list, and then + * letting vsnprintf/vsprintf to take care of the other + * arguments. This may be doable. + * + * We do not attempt that now. But for paranoia, we here try + * to detect some common (but not all) cases where the + * "Q-less" %[efgaEFGA] formats are present, and die if + * detected. This doesn't fix the problem, but it stops the + * vsnprintf/vsprintf pulling doubles off the va_list when + * __float128 NVs should be pulled off instead. + * + * If quadmath_format_needed() returns false, we are reasonably + * certain that we can call vnsprintf() or vsprintf() safely. */ + if (!quadmath_valid && quadmath_format_needed(format)) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format); + + } +#endif + if (retval == -1) #ifdef HAS_VSNPRINTF - retval = vsnprintf(buffer, len, format, ap); + retval = vsnprintf(buffer, len, format, ap); #else - retval = vsprintf(buffer, format, ap); + retval = vsprintf(buffer, format, ap); #endif va_end(ap); /* vsprintf() shows failure with < 0 */ @@ -4959,12 +5153,22 @@ C instead, or getting C. int Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) { +#ifdef USE_QUADMATH + PERL_UNUSED_ARG(buffer); + PERL_UNUSED_ARG(len); + PERL_UNUSED_ARG(format); + PERL_UNUSED_ARG(ap); + Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath"); + return 0; +#else int retval; #ifdef NEED_VA_COPY va_list apc; PERL_ARGS_ASSERT_MY_VSNPRINTF; - +#ifndef HAS_VSNPRINTF + PERL_UNUSED_VAR(len); +#endif Perl_va_copy(ap, apc); # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, apc); @@ -4989,6 +5193,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap ) Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); return retval; +#endif } void @@ -5163,8 +5368,139 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ #endif /* PERL_IMPLICIT_CONTEXT */ -void -Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, + +/* Perl_xs_handshake(): + implement the various XS_*_BOOTCHECK macros, which are added to .c + files by ExtUtils::ParseXS, to check that the perl the module was built + with is binary compatible with the running perl. + + usage: + Perl_xs_handshake(U32 key, void * v_my_perl, const char * file, + [U32 items, U32 ax], [char * api_version], [char * xs_version]) + + The meaning of the varargs is determined the U32 key arg (which is not + a format string). The fields of key are assembled by using HS_KEY(). + + Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type + "PerlInterpreter *" and represents the callers context; otherwise it is + of type "CV *", and is the boot xsub's CV. + + v_my_perl will catch where a threaded future perl526.dll calling IO.dll + for example, and IO.dll was linked with threaded perl524.dll, and both + perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader + successfully can load IO.dll into the process but simultaneously it + loaded an interpreter of a different version into the process, and XS + code will naturally pass SV*s created by perl524.dll for perl526.dll to + use through perl526.dll's my_perl->Istack_base. + + v_my_perl cannot be the first arg, since then 'key' will be out of + place in a threaded vs non-threaded mixup; and analyzing the key + number's bitfields won't reveal the problem, since it will be a valid + key (unthreaded perl) on interp side, but croak will report the XS mod's + key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if + it's a threaded perl and an unthreaded XS module, threaded perl will + look at an uninit C stack or an uninit register to get 'key' + (remember that it assumes that the 1st arg is the interp cxt). + + 'file' is the source filename of the caller. +*/ + +I32 +Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) +{ + va_list args; + U32 items, ax; + void * got; + void * need; +#ifdef PERL_IMPLICIT_CONTEXT + dTHX; + tTHX xs_interp; +#else + CV* cv; + SV *** xs_spp; +#endif + PERL_ARGS_ASSERT_XS_HANDSHAKE; + va_start(args, file); + + got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH)); + need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH); + if (UNLIKELY(got != need)) + goto bad_handshake; +/* try to catch where a 2nd threaded perl interp DLL is loaded into a process + by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the + 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so + dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub + passed to the XS DLL */ +#ifdef PERL_IMPLICIT_CONTEXT + xs_interp = (tTHX)v_my_perl; + got = xs_interp; + need = my_perl; +#else +/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is + loaded into a process by a XS DLL built by an unthreaded perl522.dll perl, + but the DynaLoder/Perl that started the process and loaded the XS DLL is + unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *) + through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's + location in the unthreaded perl binary) stored in CV * to figure out if this + Perl_xs_handshake was called by the same pp_entersub */ + cv = (CV*)v_my_perl; + xs_spp = (SV***)CvHSCXT(cv); + got = xs_spp; + need = &PL_stack_sp; +#endif + if(UNLIKELY(got != need)) { + bad_handshake:/* recycle branch and string from above */ + if(got != (void *)HSf_NOCHK) + noperl_die("%s: loadable library and perl binaries are mismatched" + " (got handshake key %p, needed %p)\n", + file, got, need); + } + + if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */ + SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */ + PL_xsubfilename = file; /* so the old name must be restored for + additional XSUBs to register themselves */ + (void)gv_fetchfile(file); + } + + if(key & HSf_POPMARK) { + ax = POPMARK; + { SV **mark = PL_stack_base + ax++; + { dSP; + items = (I32)(SP - MARK); + } + } + } else { + items = va_arg(args, U32); + ax = va_arg(args, U32); + } + { + U32 apiverlen; + assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX); + if((apiverlen = HS_GETAPIVERLEN(key))) { + char * api_p = va_arg(args, char*); + if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1 + || memNE(api_p, "v" PERL_API_VERSION_STRING, + sizeof("v" PERL_API_VERSION_STRING)-1)) + Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s", + api_p, SVfARG(PL_stack_base[ax + 0]), + "v" PERL_API_VERSION_STRING); + } + } + { + U32 xsverlen; + assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX); + if((xsverlen = HS_GETXSVERLEN(key))) + S_xs_version_bootcheck(aTHX_ + items, ax, va_arg(args, char*), xsverlen); + } + va_end(args); + return ax; +} + + +STATIC void +S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len) { SV *sv; @@ -5211,37 +5547,6 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, } } -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, - SVfARG(compver_string), SVfARG(module), - SVfARG(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); -} - /* =for apidoc my_strlcat @@ -5330,7 +5635,6 @@ S_gv_has_usable_name(pTHX_ GV *gv) void Perl_get_db_sub(pTHX_ SV **svp, CV *cv) { - dVAR; SV * const dbsv = GvSVn(PL_DBsub); const bool save_taint = TAINT_get; @@ -5346,10 +5650,10 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) if (!PERLDB_SUB_NN) { GV *gv = CvGV(cv); - if (!svp) { + if (!svp && !CvLEXICAL(cv)) { gv_efullname3(dbsv, gv, NULL); } - else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv) || strEQ(GvNAME(gv), "END") || ( /* Could be imported, and old sub redefined. */ (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) @@ -5369,10 +5673,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) else { sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); sv_catpvs(dbsv, "::"); - sv_catpvn_flags( - dbsv, GvNAME(gv), GvNAMELEN(gv), - GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES - ); + sv_cathek(dbsv, GvNAME_HEK(gv)); } } else { @@ -5390,20 +5691,18 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) } int -Perl_my_dirfd(pTHX_ DIR * dir) { +Perl_my_dirfd(DIR * dir) { /* Most dirfd implementations have problems when passed NULL. */ if(!dir) return -1; #ifdef HAS_DIRFD - PERL_UNUSED_CONTEXT; return dirfd(dir); #elif defined(HAS_DIR_DD_FD) - PERL_UNUSED_CONTEXT; return dir->dd_fd; #else - Perl_die(aTHX_ PL_no_func, "dirfd"); - assert(0); /* NOT REACHED */ + Perl_croak_nocontext(PL_no_func, "dirfd"); + NOT_REACHED; /* NOTREACHED */ return 0; #endif } @@ -5547,6 +5846,9 @@ static void bfd_update(bfd_context* ctx, Dl_info* dl_info) /* BFD open and scan only if the filename changed. */ if (ctx->fname_prev == NULL || strNE(dl_info->dli_fname, ctx->fname_prev)) { + if (ctx->abfd) { + bfd_close(ctx->abfd); + } ctx->abfd = bfd_openr(dl_info->dli_fname, 0); if (ctx->abfd) { if (bfd_check_format(ctx->abfd, bfd_object)) { @@ -5698,12 +6000,12 @@ static void atos_update(atos_context* ctx, /* Given an output buffer end |p| and its |start|, matches * for the atos output, extracting the source code location - * if possible, returning NULL otherwise. */ + * and returning non-NULL if possible, returning NULL otherwise. */ static const char* atos_parse(const char* p, const char* start, STRLEN* source_name_size, STRLEN* source_line) { - /* atos() outputs is something like: + /* atos() output is something like: * perl_parse (in miniperl) (perl.c:2314)\n\n". * We cannot use Perl regular expressions, because we need to * stay low-level. Therefore here we have a rolled-out version @@ -5713,11 +6015,16 @@ static const char* atos_parse(const char* p, * The matched regular expression is roughly "\(.*:\d+\)\s*$" */ const char* source_number_start; const char* source_name_end; + const char* source_line_end; + const char* close_paren; + UV uv; + /* Skip trailing whitespace. */ while (p > start && isspace(*p)) p--; /* Now we should be at the close paren. */ if (p == start || *p != ')') return NULL; + close_paren = p; p--; /* Now we should be in the line number. */ if (p == start || !isdigit(*p)) @@ -5738,8 +6045,14 @@ static const char* atos_parse(const char* p, return NULL; p++; *source_name_size = source_name_end - p; - *source_line = atoi(source_number_start); - return p; + if (grok_atoUV(source_number_start, &uv, &source_line_end) + && source_line_end == close_paren + && uv <= MAX_STRLEN + ) { + *source_line = (STRLEN)uv; + return p; + } + return NULL; } /* Given a raw frame, read a pipe from the symbolicator (that's the @@ -6038,6 +6351,9 @@ Perl_get_c_backtrace(pTHX_ int depth, int skip) } #ifdef USE_BFD Safefree(symbol_names); + if (bfd_ctx.abfd) { + bfd_close(bfd_ctx.abfd); + } #endif Safefree(source_lines); Safefree(source_name_sizes);