* '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.
int putenv(char *);
#endif
-#ifdef I_SYS_WAIT
-# include <sys/wait.h>
-#endif
-
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
STRLEN len;
STRLEN rarest = 0;
U32 frequency = 256;
+ MAGIC *mg;
PERL_ARGS_ASSERT_FBM_COMPILE;
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) {
/* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
the BM table. */
- const unsigned char *sb;
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++) {
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 */
{
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) {
#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:
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
}
}
+ /* 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++;
}
#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
# 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*)
https://perl5.git.perl.org / perl5.git / blobdiff