X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/39efed7fb68a394db844e6c312aadb72695b0ad8..6460123ae692a9c25bc8c2253f12c8cf6f0ebdc0:/util.c diff --git a/util.c b/util.c index 1ae9459..80e283b 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 + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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. @@ -258,11 +258,18 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { dTHX; Malloc_t ptr; +#if defined(DEBUGGING) || defined(HAS_64K_LIMIT) || defined(PERL_TRACK_MEMPOOL) + const MEM_SIZE total_size = size * count +#ifdef PERL_TRACK_MEMPOOL + + sTHX +#endif + ; +#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 +277,24 @@ 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. */ + ptr = (Malloc_t)PerlMem_malloc(total_size); +#else + /* Use calloc() because it might save a memset() if the memory is fresh + and clean from the OS. */ + ptr = (Malloc_t)PerlMem_calloc(count, 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) 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 +302,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); } @@ -478,7 +489,7 @@ 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; if (flags & FBMcf_TAIL) { @@ -490,8 +501,10 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s = (U8*)SvPV_force_mutable(sv, len); if (len == 0) /* TAIL might be on a zero-length string. */ return; - SvUPGRADE(sv, SVt_PVBM); + 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; @@ -502,7 +515,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); - table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] = (U8)flags; i = 0; sb = s - mlen + 1; /* first char (maybe) */ while (s >= sb) { @@ -510,9 +522,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 +534,14 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) frequency = PL_freq[s[i]]; } } + BmFLAGS(sv) = (U8)flags; BmRARE(sv) = s[rarest]; - BmPREVIOUS_set(sv, 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. */ @@ -663,7 +677,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); @@ -722,7 +736,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } check_end: if ( s == bigend - && (table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] & FBMcf_TAIL) + && (BmFLAGS(littlestr) & FBMcf_TAIL) && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; @@ -758,7 +772,8 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift register const unsigned char *littleend; I32 found = 0; - assert(SvTYPE(littlestr) == SVt_PVBM); + assert(SvTYPE(littlestr) == SVt_PVGV); + assert(SvVALID(littlestr)); if (*old_posp == -1 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 @@ -949,6 +964,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 @@ -1129,7 +1165,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, @@ -1267,7 +1306,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); } @@ -1285,7 +1324,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); @@ -1293,7 +1332,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; @@ -2264,8 +2303,12 @@ 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_ Nullch, mode, n, args); +# else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; +# endif #endif } @@ -2353,6 +2396,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()); @@ -4042,12 +4093,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. @@ -4104,6 +4155,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 */ @@ -4283,7 +4337,7 @@ Perl_new_version(pTHX_ SV *ver) } } #endif - return upg_version(rv); + return upg_version(rv, FALSE); } /* @@ -4291,24 +4345,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"); @@ -4328,7 +4383,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); @@ -5118,13 +5201,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 @@ -5152,10 +5236,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); @@ -5164,8 +5252,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; } @@ -5176,16 +5264,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 */ @@ -5505,13 +5593,14 @@ 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) { @@ -5542,7 +5631,70 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size) Zero(p, size, char); return p; } -#endif + +#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ + +int +Perl_my_cxt_index(pTHX_ const char *my_cxt_key) +{ + dVAR; + int 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; + + index = Perl_my_cxt_index(aTHX_ my_cxt_key); + if (index == -1) { + /* this module hasn't been allocated an index yet */ + MUTEX_LOCK(&PL_my_ctx_mutex); + index = PL_my_cxt_index++; + 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) { + 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 */ #ifndef HAS_STRLCAT Size_t @@ -5577,6 +5729,12 @@ 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) {