X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2e0cfa16dea85dd33fe3cbf38f3324f4a8418181..bd8cb5529605f33aa9cf95d6c471386b3a0e015d:/util.c diff --git a/util.c b/util.c index 4b4bfe1..82d7590 100644 --- a/util.c +++ b/util.c @@ -12,7 +12,7 @@ * 'Very useful, no doubt, that was to Saruman; yet it seems that he was * not content.' --Gandalf to Pippin * - * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] + * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* This file contains assorted utility routines. @@ -25,7 +25,9 @@ #define PERL_IN_UTIL_C #include "perl.h" +#ifdef USE_PERLIO #include "perliol.h" /* For PerlIOUnix_refcnt */ +#endif #ifndef PERL_MICRO #include @@ -39,10 +41,6 @@ int putenv(char *); #endif -#ifdef I_SYS_WAIT -# include -#endif - #ifdef HAS_SELECT # ifdef I_SYS_SELECT # include @@ -292,11 +290,16 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) dTHX; #endif Malloc_t ptr; +#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING) MEM_SIZE total_size = 0; +#endif /* Even though calloc() for zero bytes is strange, be robust. */ - if (size && (count <= MEM_SIZE_MAX / size)) + if (size && (count <= MEM_SIZE_MAX / size)) { +#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING) total_size = size * count; +#endif + } else Perl_croak_nocontext("%s", PL_memory_wrap); #ifdef PERL_TRACK_MEMPOOL @@ -538,13 +541,24 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { dVAR; register const U8 *s; - register U32 i; + STRLEN i; STRLEN len; - U32 rarest = 0; + STRLEN rarest = 0; U32 frequency = 256; + MAGIC *mg; PERL_ARGS_ASSERT_FBM_COMPILE; + /* Refuse to fbm_compile a studied scalar, as this gives more flexibility in + SV flag usage. No real-world code would ever end up using a studied + scalar as a compile-time second argument to index, so this isn't a real + pessimisation. */ + if (SvSCREAM(sv)) + return; + + if (SvVALID(sv)) + return; + if (flags & FBMcf_TAIL) { MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ @@ -554,31 +568,49 @@ 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_PVGV); + SvUPGRADE(sv, SVt_PVMG); SvIOK_off(sv); SvNOK_off(sv); SvVALID_on(sv); + + /* "deep magic", the comment used to add. The use of MAGIC itself isn't + really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2) + to call SvVALID_off() if the scalar was assigned to. + + The comment itself (and "deeper magic" below) date back to + 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on + str->str_pok |= 2; + where the magic (presumably) was that the scalar had a BM table hidden + inside itself. + + As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store + the table instead of the previous (somewhat hacky) approach of co-opting + the string buffer and storing it after the string. */ + + assert(!mg_find(sv, PERL_MAGIC_bm)); + mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0); + assert(mg); + if (len > 2) { - const unsigned char *sb; + /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use + the BM table. */ const U8 mlen = (len>255) ? 255 : (U8)len; + const unsigned char *const sb = s + len - mlen; /* first char (maybe) */ register U8 *table; - 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 */ + Newx(table, 256, U8); memset((void*)table, mlen, 256); + mg->mg_ptr = (char *)table; + mg->mg_len = 256; + + s += len - 1; /* last char */ i = 0; - sb = s - mlen + 1; /* first char (maybe) */ while (s >= sb) { if (table[*s] == mlen) 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 */ s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ for (i = 0; i < len; i++) { @@ -587,14 +619,13 @@ 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 */ if (flags & FBMcf_TAIL) SvTAIL_on(sv); - DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n", - BmRARE(sv),(unsigned long)BmPREVIOUS(sv))); + DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n", + BmRARE(sv), BmPREVIOUS(sv))); } /* If SvTAIL(littlestr), it has a fake '\n' at end. */ @@ -634,9 +665,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit return NULL; } - if (littlelen <= 2) { /* Special-cased */ - - if (littlelen == 1) { + switch (littlelen) { /* Special cases for 0, 1 and 2 */ + case 0: + return (char*)big; /* Cannot be SvTAIL! */ + case 1: if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ /* Know that bigend != big. */ if (bigend[-1] == '\n') @@ -652,11 +684,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit if (SvTAIL(littlestr)) return (char *) bigend; return NULL; - } - if (!littlelen) - return (char*)big; /* Cannot be SvTAIL! */ - - /* littlelen is 2 */ + case 2: if (SvTAIL(littlestr) && !multiline) { if (bigend[-1] == '\n' && bigend[-2] == *little) return (char*)bigend - 2; @@ -716,7 +744,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit if (SvTAIL(littlestr) && (*bigend == *little)) return (char *)bigend; /* bigend is already decremented. */ return NULL; + default: + break; /* Only lengths 0 1 and 2 have special-case code. */ } + if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ s = bigend - littlelen; if (s >= big && bigend[-1] == '\n' && *s == *little @@ -754,8 +785,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit return NULL; { - register const unsigned char * const table - = little + littlelen + PERL_FBM_TABLE_OFFSET; + const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm); + const unsigned char * const table = (const unsigned char *) mg->mg_ptr; register const unsigned char *oldlittle; --littlelen; /* Last char found by table lookup */ @@ -791,7 +822,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } check_end: if ( s == bigend - && (BmFLAGS(littlestr) & FBMcf_TAIL) + && SvTAIL(littlestr) && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; @@ -819,22 +850,56 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift { dVAR; register const unsigned char *big; - register I32 pos; + U32 pos = 0; /* hush a gcc warning */ register I32 previous; register I32 first; register const unsigned char *little; register I32 stop_pos; register const unsigned char *littleend; - I32 found = 0; + bool found = FALSE; + const MAGIC * mg; + const void *screamnext_raw = NULL; /* hush a gcc warning */ + bool cant_find = FALSE; /* hush a gcc warning */ PERL_ARGS_ASSERT_SCREAMINSTR; - assert(SvTYPE(littlestr) == SVt_PVGV); + assert(SvMAGICAL(bigstr)); + mg = mg_find(bigstr, PERL_MAGIC_study); + assert(mg); + assert(SvTYPE(littlestr) == SVt_PVMG); assert(SvVALID(littlestr)); - if (*old_posp == -1 - ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 - : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { + if (mg->mg_private == 1) { + const U8 *const screamfirst = (U8 *)mg->mg_ptr; + const U8 *const screamnext = screamfirst + 256; + + screamnext_raw = (const void *)screamnext; + + pos = *old_posp == -1 + ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp]; + cant_find = pos == (U8)~0; + } else if (mg->mg_private == 2) { + const U16 *const screamfirst = (U16 *)mg->mg_ptr; + const U16 *const screamnext = screamfirst + 256; + + screamnext_raw = (const void *)screamnext; + + pos = *old_posp == -1 + ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp]; + cant_find = pos == (U16)~0; + } else if (mg->mg_private == 4) { + const U32 *const screamfirst = (U32 *)mg->mg_ptr; + const U32 *const screamnext = screamfirst + 256; + + screamnext_raw = (const void *)screamnext; + + pos = *old_posp == -1 + ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp]; + cant_find = pos == (U32)~0; + } else + Perl_croak(aTHX_ "panic: unknown study size %u", mg->mg_private); + + if (cant_find) { cant_find: if ( BmRARE(littlestr) == '\n' && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { @@ -865,28 +930,59 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift #endif return NULL; } - while (pos < previous + start_shift) { - if (!(pos += PL_screamnext[pos])) - goto cant_find; + if (mg->mg_private == 1) { + const U8 *const screamnext = (const U8 *const) screamnext_raw; + while ((I32)pos < previous + start_shift) { + pos = screamnext[pos]; + if (pos == (U8)~0) + goto cant_find; + } + } else if (mg->mg_private == 2) { + const U16 *const screamnext = (const U16 *const) screamnext_raw; + while ((I32)pos < previous + start_shift) { + pos = screamnext[pos]; + if (pos == (U16)~0) + goto cant_find; + } + } else if (mg->mg_private == 4) { + const U32 *const screamnext = (const U32 *const) screamnext_raw; + while ((I32)pos < previous + start_shift) { + pos = screamnext[pos]; + if (pos == (U32)~0) + goto cant_find; + } } big -= previous; - do { - register const unsigned char *s, *x; - if (pos >= stop_pos) break; - if (big[pos] != first) - continue; - for (x=big+pos+1,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; - break; + while (1) { + if ((I32)pos >= stop_pos) break; + if (big[pos] == first) { + const unsigned char *s = little; + const unsigned char *x = big + pos + 1; + while (s < littleend) { + if (*s != *x++) + break; + ++s; + } + if (s == littleend) { + *old_posp = (I32)pos; + if (!last) return (char *)(big+pos); + found = TRUE; } } - if (s == littleend) { - *old_posp = pos; - if (!last) return (char *)(big+pos); - found = 1; + if (mg->mg_private == 1) { + pos = ((const U8 *const)screamnext_raw)[pos]; + if (pos == (U8)~0) + break; + } else if (mg->mg_private == 2) { + pos = ((const U16 *const)screamnext_raw)[pos]; + if (pos == (U16)~0) + break; + } else if (mg->mg_private == 4) { + pos = ((const U32 *const)screamnext_raw)[pos]; + if (pos == (U32)~0) + break; } - } while ( pos += PL_screamnext[pos] ); + }; if (last && found) return (char *)(big+(*old_posp)); check_tail: @@ -2706,7 +2802,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) sleep(5); } if (pid == 0) { - GV* tmpgv; #undef THIS #undef THAT @@ -2752,12 +2847,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) 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()); - SvREADONLY_on(GvSV(tmpgv)); - } #ifdef THREADS_HAVE_PIDS PL_ppid = (IV)getppid(); #endif @@ -3125,9 +3214,13 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) dSAVEDERRNO; const int fd = PerlIO_fileno(ptr); +#ifdef USE_PERLIO /* Find out whether the refcount is low enough for us to wait for the child proc without blocking. */ const bool should_wait = PerlIOUnix_refcnt(fd) == 1; +#else + const bool should_wait = 1; +#endif svp = av_fetch(PL_fdpid,fd,TRUE); pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; @@ -3704,104 +3797,10 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) { - const MGVTBL* result; PERL_UNUSED_CONTEXT; - switch(vtbl_id) { - case want_vtbl_sv: - result = &PL_vtbl_sv; - break; - case want_vtbl_env: - result = &PL_vtbl_env; - break; - case want_vtbl_envelem: - result = &PL_vtbl_envelem; - break; - case want_vtbl_sig: - result = &PL_vtbl_sig; - break; - case want_vtbl_sigelem: - result = &PL_vtbl_sigelem; - break; - case want_vtbl_pack: - result = &PL_vtbl_pack; - break; - case want_vtbl_packelem: - result = &PL_vtbl_packelem; - break; - case want_vtbl_dbline: - result = &PL_vtbl_dbline; - break; - case want_vtbl_isa: - result = &PL_vtbl_isa; - break; - case want_vtbl_isaelem: - result = &PL_vtbl_isaelem; - break; - case want_vtbl_arylen: - result = &PL_vtbl_arylen; - break; - case want_vtbl_mglob: - result = &PL_vtbl_mglob; - break; - case want_vtbl_nkeys: - result = &PL_vtbl_nkeys; - break; - case want_vtbl_taint: - result = &PL_vtbl_taint; - break; - case want_vtbl_substr: - result = &PL_vtbl_substr; - break; - case want_vtbl_vec: - result = &PL_vtbl_vec; - break; - case want_vtbl_pos: - result = &PL_vtbl_pos; - break; - case want_vtbl_bm: - result = &PL_vtbl_bm; - break; - case want_vtbl_fm: - result = &PL_vtbl_fm; - break; - case want_vtbl_uvar: - result = &PL_vtbl_uvar; - break; - case want_vtbl_defelem: - result = &PL_vtbl_defelem; - break; - case want_vtbl_regexp: - result = &PL_vtbl_regexp; - break; - case want_vtbl_regdata: - result = &PL_vtbl_regdata; - break; - case want_vtbl_regdatum: - result = &PL_vtbl_regdatum; - break; -#ifdef USE_LOCALE_COLLATE - case want_vtbl_collxfrm: - result = &PL_vtbl_collxfrm; - break; -#endif - case want_vtbl_amagic: - result = &PL_vtbl_amagic; - break; - case want_vtbl_amagicelem: - result = &PL_vtbl_amagicelem; - break; - case want_vtbl_backref: - result = &PL_vtbl_backref; - break; - case want_vtbl_utf8: - result = &PL_vtbl_utf8; - break; - default: - result = NULL; - break; - } - return (MGVTBL*)result; + return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) + ? NULL : PL_magic_vtables + vtbl_id; } I32 @@ -4538,6 +4537,11 @@ dotted_decimal_version: } } + /* and we never support negative versions */ + if ( *d == '-') { + BADVERSION(s,errstr,"Invalid version format (negative version number)"); + } + /* consume all of the integer part */ while (isDIGIT(*d)) d++; @@ -5581,7 +5585,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { } #else /* In any case have a stub so that there's code corresponding - * to the my_socketpair in global.sym. */ + * to the my_socketpair in embed.fnc. */ int Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { #ifdef HAS_SOCKETPAIR @@ -5862,18 +5866,15 @@ Perl_init_global_struct(pTHX) # undef PERLVARA # undef PERLVARI # undef PERLVARIC -# undef PERLVARISC -# define PERLVAR(var,type) /**/ -# define PERLVARA(var,n,type) /**/ -# define PERLVARI(var,type,init) plvarsp->var = init; -# define PERLVARIC(var,type,init) plvarsp->var = init; -# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char); +# define PERLVAR(prefix,var,type) /**/ +# define PERLVARA(prefix,var,n,type) /**/ +# define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init; +# define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init; # include "perlvars.h" # undef PERLVAR # undef PERLVARA # undef PERLVARI # undef PERLVARIC -# undef PERLVARISC # ifdef PERL_GLOBAL_STRUCT plvarsp->Gppaddr = (Perl_ppaddr_t*)