X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=69595228e5a353b86bd8a0a6512b36aabd9439c5;hb=c02d4329fd236df2f6781ece55e9312b6f67bc10;hp=7a89c5cb32fd9e240ca6173392afa94d4f8e6382;hpb=10edeb5d2457364a70a6848a864cfa6b89dfc882;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 7a89c5c..6959522 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. @@ -454,8 +454,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,7 +478,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,19 +488,23 @@ 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; + BmFLAGS(sv) = (U8)flags; i = 0; sb = s - mlen + 1; /* first char (maybe) */ while (s >= sb) { @@ -510,9 +512,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++) { @@ -522,12 +525,12 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 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. */ @@ -663,7 +666,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 +683,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 +724,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 +761,9 @@ 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_PVGV); + assert(SvVALID(littlestr)); + if (*old_posp == -1 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { @@ -1261,7 +1271,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); } @@ -1279,7 +1289,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); @@ -1287,7 +1297,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; @@ -1571,46 +1581,46 @@ 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=setenv_getix(nam); /* where does it go? */ int nlen, vlen; - if (environ == PL_origenviron) { /* need we copy environment? */ - I32 j; - I32 max; - char **tmpenv; - - max = i; - while (environ[max]) - max++; - tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); - for (j=0; j 0) len--; version = savepvn(tbuf, len); } @@ -5469,7 +5498,7 @@ 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. */ @@ -5492,13 +5521,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) { @@ -5529,7 +5559,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 @@ -5564,6 +5657,48 @@ 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); + /* We do not care about using sv to call CV; + * it's for informational purposes only. + */ + + save_item(dbsv); + if (!PERLDB_SUB_NN) { + GV * const 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((GV*)*svp) == cv) )))) { + /* Use GV from the stack as a fallback. */ + /* GV is potentially non-unique, or contain different CV. */ + SV * const tmp = newRV((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 */ + } +} + /* * Local variables: * c-indentation-style: bsd