X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=f670bb8baa3d14a0bfa049ebdbe9572e28689157;hb=3f2908ecc3b758f2588e5612843e5a1177751c9c;hp=f67b3ba6a8ec65dffa055932c69ade4019c100d3;hpb=17dd9954ac1485d9f7bfd39f371dd627e20503a9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index f67b3ba..f670bb8 100644 --- a/util.c +++ b/util.c @@ -258,11 +258,23 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { dTHX; 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(PL_memory_wrap); +#ifdef PERL_TRACK_MEMPOOL + if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) + total_size += sTHX; + else + Perl_croak_nocontext(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 +282,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,7 +311,7 @@ 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); } @@ -410,13 +430,13 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const 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; @@ -504,7 +524,6 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET); s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */ memset((void*)table, mlen, 256); - BmFLAGS(sv) = (U8)flags; i = 0; sb = s - mlen + 1; /* first char (maybe) */ while (s >= sb) { @@ -524,6 +543,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) frequency = PL_freq[s[i]]; } } + BmFLAGS(sv) = (U8)flags; BmRARE(sv) = s[rarest]; BmPREVIOUS(sv) = rarest; BmUSEFUL(sv) = 100; /* Initial value */ @@ -769,7 +789,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { cant_find: if ( BmRARE(littlestr) == '\n' - && BmPREVIOUS(littlestr) == (U8)SvCUR(littlestr) - 1) { + && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { little = (const unsigned char *)(SvPVX_const(littlestr)); littleend = little + SvCUR(littlestr); first = *little++; @@ -953,6 +973,27 @@ 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); + assert(pv); + 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 @@ -1133,7 +1174,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, @@ -1271,7 +1315,7 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die/croak: message = %s\ndiehook = %p\n", - thr, message, PL_diehook)); + (void*)thr, message, (void*)PL_diehook)); if (PL_diehook) { S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE); } @@ -1289,7 +1333,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die: curstack = %p, mainstack = %p\n", - thr, PL_curstack, PL_mainstack)); + (void*)thr, (void*)PL_curstack, (void*)PL_mainstack)); message = vdie_croak_common(pat, args, &msglen, &utf8); @@ -1297,7 +1341,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) 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)); + (void*)thr, (void*)PL_restartop, was_in_eval, (void*)PL_top_env)); if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) JMPENV_JUMP(3); return PL_restartop; @@ -4058,12 +4102,12 @@ an RV. Function must be called with an already existing SV like sv = newSV(0); - s = scan_version(s,SV *sv, bool qv); + 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 a alpha version). The boolean qv denotes that the version +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. @@ -4120,6 +4164,9 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( alpha && !saw_period ) Perl_croak(aTHX_ "Invalid version format (alpha without decimal)"); + if ( alpha && saw_period && width == 0 ) + Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)"); + if ( saw_period > 1 ) qv = 1; /* force quoted version processing */ @@ -4299,7 +4346,7 @@ Perl_new_version(pTHX_ SV *ver) } } #endif - return upg_version(rv); + return upg_version(rv, FALSE); } /* @@ -4307,24 +4354,25 @@ 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 */ + 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"); @@ -4344,7 +4392,35 @@ Perl_upg_version(pTHX_ SV *ver) #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 */ + SV * const nsv = sv_newmortal(); + const char *nver; + const char *pos; + int saw_period = 0; + sv_setpvf(nsv,"%vd",ver); + pos = nver = savepv(SvPV_nolen(nsv)); + + /* scan the resulting formatted string */ + while ( *pos == '.' || isDIGIT(*pos) ) { + if ( *pos == '.' ) + saw_period++ ; + pos++; + } + + /* is definitely a v-string */ + if ( saw_period == 2 ) { + Safefree(version); + version = nver; + } + } +# endif +#endif } s = scan_version(version, ver, qv); @@ -5134,13 +5210,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 @@ -5168,10 +5245,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); @@ -5180,8 +5261,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; } @@ -5192,16 +5273,16 @@ Perl_init_global_struct(pTHX) void Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) { -#ifdef PERL_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 */