wvpinfo *
_wavpack_parse(PerlIO *infile, char *file, HV *info, uint8_t seeking)
{
int err = 0;
int done = 0;
u_char *bptr;
wvpinfo *wvp;
Newz(0, wvp, sizeof(wvpinfo), wvpinfo);
Newz(0, wvp->buf, sizeof(Buffer), Buffer);
Newz(0, wvp->header, sizeof(WavpackHeader), WavpackHeader);
wvp->infile = infile;
wvp->file = file;
wvp->info = info;
wvp->file_offset = 0;
wvp->audio_offset = 0;
wvp->seeking = seeking ? 1 : 0;
buffer_init(wvp->buf, WAVPACK_BLOCK_SIZE);
wvp->file_size = _file_size(infile);
my_hv_store( info, "file_size", newSVuv(wvp->file_size) );
// Loop through each wvpk block until we find a good one
while (!done) {
if ( !_check_buf(infile, wvp->buf, 32, WAVPACK_BLOCK_SIZE) ) {
err = -1;
goto out;
}
bptr = buffer_ptr(wvp->buf);
// If first byte is 'R', assume old version
if ( bptr[0] == 'R' ) {
if ( !_wavpack_parse_old(wvp) ) {
err = -1;
goto out;
}
break;
}
// May need to read past some junk before wvpk header
while ( bptr[0] != 'w' || bptr[1] != 'v' || bptr[2] != 'p' || bptr[3] != 'k' ) {
buffer_consume(wvp->buf, 1);
wvp->audio_offset++;
if ( !buffer_len(wvp->buf) ) {
if ( !_check_buf(infile, wvp->buf, 32, WAVPACK_BLOCK_SIZE) ) {
PerlIO_printf(PerlIO_stderr(), "Unable to find a valid WavPack block in file: %s\n", file);
err = -1;
goto out;
}
}
bptr = buffer_ptr(wvp->buf);
}
if ( _wavpack_parse_block(wvp) ) {
done = 1;
}
}
my_hv_store( info, "audio_offset", newSVuv(wvp->audio_offset) );
my_hv_store( info, "audio_size", newSVuv(wvp->file_size - wvp->audio_offset) );
out:
buffer_free(wvp->buf);
Safefree(wvp->buf);
Safefree(wvp->header);
return wvp;
}
int
bsd_glob(const char *pattern, int flags,
int (*errfunc)(const char *, int), glob_t *pglob)
{
const U8 *patnext;
int c;
Char *bufnext, *bufend, patbuf[MAXPATHLEN];
#ifdef MACOS_TRADITIONAL
char *new_pat, *p, *np;
int err;
size_t len;
#endif
#ifndef MACOS_TRADITIONAL
patnext = (U8 *) pattern;
#endif
/* TODO: GLOB_APPEND / GLOB_DOOFFS aren't supported yet */
#if 0
if (!(flags & GLOB_APPEND)) {
pglob->gl_pathc = 0;
pglob->gl_pathv = NULL;
if (!(flags & GLOB_DOOFFS))
pglob->gl_offs = 0;
}
#else
pglob->gl_pathc = 0;
pglob->gl_pathv = NULL;
pglob->gl_offs = 0;
#endif
pglob->gl_flags = flags & ~GLOB_MAGCHAR;
pglob->gl_errfunc = errfunc;
pglob->gl_matchc = 0;
bufnext = patbuf;
bufend = bufnext + MAXPATHLEN - 1;
#ifdef DOSISH
/* Nasty hack to treat patterns like "C:*" correctly. In this
* case, the * should match any file in the current directory
* on the C: drive. However, the glob code does not treat the
* colon specially, so it looks for files beginning "C:" in
* the current directory. To fix this, change the pattern to
* add an explicit "./" at the start (just after the drive
* letter and colon - ie change to "C:./").
*/
if (isalpha(pattern[0]) && pattern[1] == ':' &&
pattern[2] != BG_SEP && pattern[2] != BG_SEP2 &&
bufend - bufnext > 4) {
*bufnext++ = pattern[0];
*bufnext++ = ':';
*bufnext++ = '.';
*bufnext++ = BG_SEP;
patnext += 2;
}
#endif
#ifdef MACOS_TRADITIONAL
/* Check if we need to match a volume name (e.g. '*HD:*') */
g_matchVol = false;
p = (char *) pattern;
if (*p != BG_SEP) {
p++;
while (*p != BG_EOS) {
if (*p == BG_SEP) {
g_matchVol = true;
break;
}
p++;
}
}
/* Transform the pattern:
* (a) Resolve updirs, e.g.
* '*:t*p::' -> '*:'
* ':a*:tmp::::' -> '::'
* ':base::t*p:::' -> '::'
* '*HD::' -> return 0 (error, quit silently)
*
* (b) Remove a single trailing ':', unless it's a "match volume only"
* pattern like '*HD:'; e.g.
* '*:tmp:' -> '*:tmp' but
* '*HD:' -> '*HD:'
* (If we don't do that, even filenames will have a trailing ':' in
* the result.)
*/
/* We operate on a copy of the pattern */
len = strlen(pattern);
Newx(new_pat, len + 1, char);
if (new_pat == NULL)
return (GLOB_NOSPACE);
p = (char *) pattern;
np = new_pat;
while (*np++ = *p++) ;
/* Resolve updirs ... */
err = resolve_updirs(new_pat);
if (err) {
Safefree(new_pat);
/* The pattern is incorrect: tried to move
up above the volume root, see above.
We quit silently. */
return 0;
}
/* remove trailing colon ... */
remove_trColon(new_pat);
patnext = (U8 *) new_pat;
#endif /* MACOS_TRADITIONAL */
if (flags & GLOB_QUOTE) {
/* Protect the quoted characters. */
while (bufnext < bufend && (c = *patnext++) != BG_EOS)
if (c == BG_QUOTE) {
#ifdef DOSISH
/* To avoid backslashitis on Win32,
* we only treat \ as a quoting character
* if it precedes one of the
* metacharacters []-{}~\
*/
if ((c = *patnext++) != '[' && c != ']' &&
c != '-' && c != '{' && c != '}' &&
c != '~' && c != '\\') {
#else
if ((c = *patnext++) == BG_EOS) {
#endif
c = BG_QUOTE;
--patnext;
}
*bufnext++ = c | M_PROTECT;
} else
*bufnext++ = c;
} else
while (bufnext < bufend && (c = *patnext++) != BG_EOS)
*bufnext++ = c;
*bufnext = BG_EOS;
#ifdef MACOS_TRADITIONAL
if (flags & GLOB_BRACE)
err = globexp1(patbuf, pglob);
else
err = glob0(patbuf, pglob);
Safefree(new_pat);
return err;
#else
if (flags & GLOB_BRACE)
return globexp1(patbuf, pglob);
else
return glob0(patbuf, pglob);
#endif
}
/*
* Expand recursively a glob {} pattern. When there is no more expansion
* invoke the standard globbing routine to glob the rest of the magic
* characters
*/
static int
globexp1(const Char *pattern, glob_t *pglob)
{
const Char* ptr = pattern;
int rv;
/* Protect a single {}, for find(1), like csh */
if (pattern[0] == BG_LBRACE && pattern[1] == BG_RBRACE && pattern[2] == BG_EOS)
return glob0(pattern, pglob);
while ((ptr = (const Char *) g_strchr((Char *) ptr, BG_LBRACE)) != NULL)
if (!globexp2(ptr, pattern, pglob, &rv))
return rv;
return glob0(pattern, pglob);
}
/*
* Recursive brace globbing helper. Tries to expand a single brace.
* If it succeeds then it invokes globexp1 with the new pattern.
* If it fails then it tries to glob the rest of the pattern and returns.
*/
static int
globexp2(const Char *ptr, const Char *pattern,
glob_t *pglob, int *rv)
{
int i;
Char *lm, *ls;
const Char *pe, *pm, *pl;
Char patbuf[MAXPATHLEN];
/* copy part up to the brace */
for (lm = patbuf, pm = pattern; pm != ptr; *lm++ = *pm++)
;
*lm = BG_EOS;
ls = lm;
/* Find the balanced brace */
for (i = 0, pe = ++ptr; *pe; pe++)
if (*pe == BG_LBRACKET) {
/* Ignore everything between [] */
for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++)
;
if (*pe == BG_EOS) {
/*
* We could not find a matching BG_RBRACKET.
* Ignore and just look for BG_RBRACE
*/
pe = pm;
}
} else if (*pe == BG_LBRACE)
i++;
else if (*pe == BG_RBRACE) {
if (i == 0)
break;
i--;
}
/* Non matching braces; just glob the pattern */
if (i != 0 || *pe == BG_EOS) {
*rv = glob0(patbuf, pglob);
return 0;
}
for (i = 0, pl = pm = ptr; pm <= pe; pm++) {
switch (*pm) {
case BG_LBRACKET:
/* Ignore everything between [] */
for (pl = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++)
;
if (*pm == BG_EOS) {
/*
* We could not find a matching BG_RBRACKET.
* Ignore and just look for BG_RBRACE
*/
pm = pl;
}
break;
case BG_LBRACE:
i++;
break;
case BG_RBRACE:
if (i) {
i--;
break;
}
/* FALLTHROUGH */
case BG_COMMA:
if (i && *pm == BG_COMMA)
break;
else {
/* Append the current string */
for (lm = ls; (pl < pm); *lm++ = *pl++)
;
/*
* Append the rest of the pattern after the
* closing brace
*/
for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS; )
;
/* Expand the current pattern */
#ifdef GLOB_DEBUG
qprintf("globexp2:", patbuf);
#endif /* GLOB_DEBUG */
*rv = globexp1(patbuf, pglob);
/* move after the comma, to the next string */
pl = pm + 1;
}
break;
default:
break;
}
}
*rv = 0;
return 0;
}
/*
* Initialize locale awareness.
*/
int
Perl_init_i18nl10n(pTHX_ int printwarn)
{
int ok = 1;
/* returns
* 1 = set ok or not applicable,
* 0 = fallback to C locale,
* -1 = fallback to C locale failed
*/
#if defined(USE_LOCALE)
dVAR;
#ifdef USE_LOCALE_CTYPE
char *curctype = NULL;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
char *curcoll = NULL;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
char *curnum = NULL;
#endif /* USE_LOCALE_NUMERIC */
#ifdef __GLIBC__
char * const language = PerlEnv_getenv("LANGUAGE");
#endif
char * const lc_all = PerlEnv_getenv("LC_ALL");
char * const lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
#ifdef LOCALE_ENVIRON_REQUIRED
/*
* Ultrix setlocale(..., "") fails if there are no environment
* variables from which to get a locale name.
*/
bool done = FALSE;
#ifdef LC_ALL
if (lang) {
if (setlocale(LC_ALL, ""))
done = TRUE;
else
setlocale_failure = TRUE;
}
if (!setlocale_failure) {
#ifdef USE_LOCALE_CTYPE
Safefree(curctype);
if (! (curctype =
setlocale(LC_CTYPE,
(!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : NULL)))
setlocale_failure = TRUE;
else
curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
Safefree(curcoll);
if (! (curcoll =
setlocale(LC_COLLATE,
(!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : NULL)))
setlocale_failure = TRUE;
else
curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
Safefree(curnum);
if (! (curnum =
setlocale(LC_NUMERIC,
(!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : NULL)))
setlocale_failure = TRUE;
else
curnum = savepv(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
#endif /* LC_ALL */
#endif /* !LOCALE_ENVIRON_REQUIRED */
#ifdef LC_ALL
if (! setlocale(LC_ALL, ""))
setlocale_failure = TRUE;
#endif /* LC_ALL */
if (!setlocale_failure) {
#ifdef USE_LOCALE_CTYPE
Safefree(curctype);
if (! (curctype = setlocale(LC_CTYPE, "")))
setlocale_failure = TRUE;
else
curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
Safefree(curcoll);
if (! (curcoll = setlocale(LC_COLLATE, "")))
setlocale_failure = TRUE;
else
curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
Safefree(curnum);
if (! (curnum = setlocale(LC_NUMERIC, "")))
setlocale_failure = TRUE;
else
curnum = savepv(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
if (setlocale_failure) {
char *p;
const bool locwarn = (printwarn > 1 ||
(printwarn &&
(!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
if (locwarn) {
#ifdef LC_ALL
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed.\n");
#else /* !LC_ALL */
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed for the categories:\n\t");
#ifdef USE_LOCALE_CTYPE
if (! curctype)
PerlIO_printf(Perl_error_log, "LC_CTYPE ");
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! curcoll)
PerlIO_printf(Perl_error_log, "LC_COLLATE ");
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! curnum)
PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
#endif /* USE_LOCALE_NUMERIC */
PerlIO_printf(Perl_error_log, "\n");
#endif /* LC_ALL */
PerlIO_printf(Perl_error_log,
"perl: warning: Please check that your locale settings:\n");
#ifdef __GLIBC__
PerlIO_printf(Perl_error_log,
"\tLANGUAGE = %c%s%c,\n",
language ? '"' : '(',
language ? language : "unset",
language ? '"' : ')');
#endif
PerlIO_printf(Perl_error_log,
"\tLC_ALL = %c%s%c,\n",
lc_all ? '"' : '(',
lc_all ? lc_all : "unset",
lc_all ? '"' : ')');
#if defined(USE_ENVIRON_ARRAY)
{
char **e;
for (e = environ; *e; e++) {
if (strnEQ(*e, "LC_", 3)
&& strnNE(*e, "LC_ALL=", 7)
&& (p = strchr(*e, '=')))
PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
(int)(p - *e), *e, p + 1);
}
}
#else
PerlIO_printf(Perl_error_log,
"\t(possibly more locale environment variables)\n");
#endif
PerlIO_printf(Perl_error_log,
"\tLANG = %c%s%c\n",
lang ? '"' : '(',
lang ? lang : "unset",
lang ? '"' : ')');
PerlIO_printf(Perl_error_log,
" are supported and installed on your system.\n");
}
#ifdef LC_ALL
if (setlocale(LC_ALL, "C")) {
if (locwarn)
PerlIO_printf(Perl_error_log,
"perl: warning: Falling back to the standard locale (\"C\").\n");
ok = 0;
}
else {
if (locwarn)
PerlIO_printf(Perl_error_log,
"perl: warning: Failed to fall back to the standard locale (\"C\").\n");
ok = -1;
}
#else /* ! LC_ALL */
if (0
#ifdef USE_LOCALE_CTYPE
|| !(curctype || setlocale(LC_CTYPE, "C"))
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
|| !(curcoll || setlocale(LC_COLLATE, "C"))
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
|| !(curnum || setlocale(LC_NUMERIC, "C"))
#endif /* USE_LOCALE_NUMERIC */
)
{
if (locwarn)
PerlIO_printf(Perl_error_log,
"perl: warning: Cannot fall back to the standard locale (\"C\").\n");
ok = -1;
}
#endif /* ! LC_ALL */
#ifdef USE_LOCALE_CTYPE
Safefree(curctype);
curctype = savepv(setlocale(LC_CTYPE, NULL));
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
Safefree(curcoll);
curcoll = savepv(setlocale(LC_COLLATE, NULL));
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
Safefree(curnum);
curnum = savepv(setlocale(LC_NUMERIC, NULL));
#endif /* USE_LOCALE_NUMERIC */
}
else {
#ifdef USE_LOCALE_CTYPE
new_ctype(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
new_collate(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
new_numeric(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
#endif /* USE_LOCALE */
#ifdef USE_PERLIO
{
/* Set PL_utf8locale to TRUE if using PerlIO _and_
any of the following are true:
- nl_langinfo(CODESET) contains /^utf-?8/i
- $ENV{LC_ALL} contains /^utf-?8/i
- $ENV{LC_CTYPE} contains /^utf-?8/i
- $ENV{LANG} contains /^utf-?8/i
The LC_ALL, LC_CTYPE, LANG obey the usual override
hierarchy of locale environment variables. (LANGUAGE
affects only LC_MESSAGES only under glibc.) (If present,
it overrides LC_MESSAGES for GNU gettext, and it also
can have more than one locale, separated by spaces,
in case you need to know.)
If PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer
on STDIN, STDOUT, STDERR, _and_ the default open discipline.
*/
bool utf8locale = FALSE;
char *codeset = NULL;
#if defined(HAS_NL_LANGINFO) && defined(CODESET)
codeset = nl_langinfo(CODESET);
#endif
if (codeset)
utf8locale = (foldEQ(codeset, STR_WITH_LEN("UTF-8"))
|| foldEQ(codeset, STR_WITH_LEN("UTF8") ));
#if defined(USE_LOCALE)
else { /* nl_langinfo(CODESET) is supposed to correctly
* interpret the locale environment variables,
* but just in case it fails, let's do this manually. */
if (lang)
utf8locale = (foldEQ(lang, STR_WITH_LEN("UTF-8"))
|| foldEQ(lang, STR_WITH_LEN("UTF8") ));
#ifdef USE_LOCALE_CTYPE
if (curctype)
utf8locale = (foldEQ(curctype, STR_WITH_LEN("UTF-8"))
|| foldEQ(curctype, STR_WITH_LEN("UTF8") ));
#endif
if (lc_all)
utf8locale = (foldEQ(lc_all, STR_WITH_LEN("UTF-8"))
|| foldEQ(lc_all, STR_WITH_LEN("UTF8") ));
}
#endif /* USE_LOCALE */
if (utf8locale)
PL_utf8locale = TRUE;
}
/* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
This is an alternative to using the -C command line switch
(the -C if present will override this). */
{
const char *p = PerlEnv_getenv("PERL_UNICODE");
PL_unicode = p ? parse_unicode_opts(&p) : 0;
if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
PL_utf8cache = -1;
}
#endif
#ifdef USE_LOCALE_CTYPE
Safefree(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
Safefree(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
Safefree(curnum);
#endif /* USE_LOCALE_NUMERIC */
return ok;
}
int is_aks_prime(mpz_t n)
{
mpz_t *px, *py;
int retval;
UV i, s, r, a;
UV starta = 1;
int _verbose = get_verbose_level();
if (mpz_cmp_ui(n, 4) < 0)
return (mpz_cmp_ui(n, 1) <= 0) ? 0 : 1;
/* Just for performance: check small divisors: 2*3*5*7*11*13*17*19*23 */
if (mpz_gcd_ui(0, n, 223092870UL) != 1 && mpz_cmp_ui(n, 23) > 0)
return 0;
if (mpz_perfect_power_p(n))
return 0;
#if AKS_VARIANT == AKS_VARIANT_V6 /* From the V6 AKS paper */
{
mpz_t sqrtn, t;
double log2n;
UV limit, startr;
PRIME_ITERATOR(iter);
mpz_init(sqrtn);
mpz_sqrt(sqrtn, n);
log2n = mpz_log2(n);
limit = (UV) floor( log2n * log2n );
if (_verbose>1) gmp_printf("# AKS checking order_r(%Zd) to %"UVuf"\n", n, (unsigned long) limit);
/* Using a native r limits us to ~2000 digits in the worst case (r ~ log^5n)
* but would typically work for 100,000+ digits (r ~ log^3n). This code is
* far too slow to matter either way. Composite r is ok here, but it will
* always end up prime, so save time and just check primes. */
retval = 0;
/* Start order search at a good spot. Idea from Nemana and Venkaiah. */
startr = (mpz_sizeinbase(n,2)-1) * (mpz_sizeinbase(n,2)-1);
startr = (startr < 1002) ? 2 : startr - 100;
for (r = 2; /* */; r = prime_iterator_next(&iter)) {
if (mpz_divisible_ui_p(n, r) ) /* r divides n. composite. */
{ retval = 0; break; }
if (mpz_cmp_ui(sqrtn, r) <= 0) /* no r <= sqrtn divides n. prime. */
{ retval = 1; break; }
if (r < startr) continue;
if (mpz_order_ui(r, n, limit) > limit)
{ retval = 2; break; }
}
prime_iterator_destroy(&iter);
mpz_clear(sqrtn);
if (retval != 2) return retval;
/* Since r is prime, phi(r) = r-1. */
s = (UV) floor( sqrt(r-1) * log2n );
}
#elif AKS_VARIANT == AKS_VARIANT_BORNEMANN /* Bernstein + Voloch */
{
UV slim;
double c2, x;
/* small t = few iters of big poly. big t = many iters of small poly */
double const t = (mpz_sizeinbase(n, 2) <= 64) ? 32 : 40;
double const t1 = (1.0/((t+1)*log(t+1)-t*log(t)));
double const dlogn = mpz_logn(n);
mpz_t tmp;
PRIME_ITERATOR(iter);
mpz_init(tmp);
prime_iterator_setprime(&iter, (UV) (t1*t1 * dlogn*dlogn) );
r = prime_iterator_next(&iter);
while (!is_primitive_root_uiprime(n,r))
r = prime_iterator_next(&iter);
prime_iterator_destroy(&iter);
slim = (UV) (2*t*(r-1));
c2 = dlogn * floor(sqrt(r));
{ /* Binary search for first s in [1,slim] where x >= 0 */
UV bi = 1;
UV bj = slim;
while (bi < bj) {
s = bi + (bj-bi)/2;
mpz_bin_uiui(tmp, r+s-1, s);
x = mpz_logn(tmp) / c2 - 1.0;
if (x < 0) bi = s+1;
else bj = s;
}
s = bi-1;
}
s = (s+3) >> 1;
/* Bornemann checks factors up to (s-1)^2, we check to max(r,s) */
/* slim = (s-1)*(s-1); */
slim = (r > s) ? r : s;
if (_verbose > 1) printf("# aks trial to %"UVuf"\n", slim);
if (_GMP_trial_factor(n, 2, slim) > 1)
{ mpz_clear(tmp); return 0; }
mpz_sqrt(tmp, n);
if (mpz_cmp_ui(tmp, slim) <= 0)
{ mpz_clear(tmp); return 1; }
mpz_clear(tmp);
}
#elif AKS_VARIANT == AKS_VARIANT_BERN21
{ /* Bernstein 2003, theorem 2.1 (simplified) */
UV q;
double slim, scmp, x;
mpz_t t, t2;
PRIME_ITERATOR(iter);
mpz_init(t); mpz_init(t2);
r = s = 0;
while (1) {
/* todo: Check r|n and r >= sqrt(n) here instead of waiting */
if (mpz_cmp_ui(n, r) <= 0) break;
r = prime_iterator_next(&iter);
q = largest_factor(r-1);
mpz_set_ui(t, r);
mpz_powm_ui(t, n, (r-1)/q, t);
if (mpz_cmp_ui(t, 1) <= 0) continue;
scmp = 2 * floor(sqrt(r)) * mpz_log2(n);
slim = 20 * (r-1);
/* Check viability */
mpz_bin_uiui(t, q+slim-1, slim); if (mpz_log2(t) < scmp) continue;
for (s = 2; s < slim; s++) {
mpz_bin_uiui(t, q+s-1, s);
if (mpz_log2(t) > scmp) break;
}
if (s < slim) break;
}
mpz_clear(t); mpz_clear(t2);
prime_iterator_destroy(&iter);
if (_GMP_trial_factor(n, 2, s) > 1)
return 0;
}
#elif AKS_VARIANT == AKS_VARIANT_BERN22
{ /* Bernstein 2003, theorem 2.2 (simplified) */
UV q;
double slim, scmp, x;
mpz_t t, t2;
PRIME_ITERATOR(iter);
mpz_init(t); mpz_init(t2);
r = s = 0;
while (1) {
/* todo: Check r|n and r >= sqrt(n) here instead of waiting */
if (mpz_cmp_ui(n, r) <= 0) break;
r = prime_iterator_next(&iter);
if (!is_primitive_root_uiprime(n,r)) continue;
q = r-1; /* Since r is prime, phi(r) = r-1 */
scmp = 2 * floor(sqrt(r-1)) * mpz_log2(n);
slim = 20 * (r-1);
/* Check viability */
mpz_bin_uiui(t, q+slim-1, slim); if (mpz_log2(t) < scmp) continue;
for (s = 2; s < slim; s++) {
mpz_bin_uiui(t, q+s-1, s);
if (mpz_log2(t) > scmp) break;
}
if (s < slim) break;
}
mpz_clear(t); mpz_clear(t2);
prime_iterator_destroy(&iter);
if (_GMP_trial_factor(n, 2, s) > 1)
return 0;
}
#elif AKS_VARIANT == AKS_VARIANT_BERN23
{ /* Bernstein 2003, theorem 2.3 (simplified) */
UV q, d, limit;
double slim, scmp, sbin, x, log2n;
mpz_t t, t2;
PRIME_ITERATOR(iter);
mpz_init(t); mpz_init(t2);
log2n = mpz_log2(n);
limit = (UV) floor( log2n * log2n );
r = 2;
s = 0;
while (1) {
/* todo: Check r|n and r >= sqrt(n) here instead of waiting */
if (mpz_cmp_ui(n, r) <= 0) break;
r++;
UV gcd = mpz_gcd_ui(NULL, n, r);
if (gcd != 1) { mpz_clear(t); mpz_clear(t2); return 0; }
UV v = mpz_order_ui(r, n, limit);
if (v >= limit) continue;
mpz_set_ui(t2, r);
totient(t, t2);
q = mpz_get_ui(t);
UV phiv = q/v;
/* printf("phi(%lu)/v = %lu/%lu = %lu\n", r, q, v, phiv); */
/* This is extremely inefficient. */
/* Choose an s value we'd be happy with */
slim = 20 * (r-1);
/* Quick check to see if it could work with s=slim, d=1 */
mpz_bin_uiui(t, q+slim-1, slim);
sbin = mpz_log2(t);
if (sbin < 2*floor(sqrt(q))*log2n)
continue;
for (s = 2; s < slim; s++) {
mpz_bin_uiui(t, q+s-1, s);
sbin = mpz_log2(t);
if (sbin < 2*floor(sqrt(q))*log2n) continue; /* d=1 */
/* Check each number dividing phi(r)/v */
for (d = 2; d < phiv; d++) {
if ((phiv % d) != 0) continue;
scmp = 2 * d * floor(sqrt(q/d)) * log2n;
if (sbin < scmp) break;
}
/* if we did not exit early, this s worked for each d. This s wins. */
if (d >= phiv) break;
}
if (s < slim) break;
}
mpz_clear(t); mpz_clear(t2);
prime_iterator_destroy(&iter);
if (_GMP_trial_factor(n, 2, s) > 1)
return 0;
}
#elif AKS_VARIANT == AKS_VARIANT_BERN41
{
double const log2n = mpz_log2(n);
/* Tuning: Initial 'r' selection */
double const r0 = 0.008 * log2n * log2n;
/* Tuning: Try a larger 'r' if 's' looks very large */
UV const rmult = 8;
UV slim;
mpz_t tmp, tmp2;
PRIME_ITERATOR(iter);
mpz_init(tmp); mpz_init(tmp2);
/* r has to be at least 3. */
prime_iterator_setprime(&iter, (r0 < 2) ? 2 : (UV) r0);
r = prime_iterator_next(&iter);
/* r must be a primitive root. For performance, skip if s looks too big. */
while ( !is_primitive_root_uiprime(n, r) ||
!bern41_acceptable(n, r, rmult*(r-1), tmp, tmp2) )
r = prime_iterator_next(&iter);
prime_iterator_destroy(&iter);
{ /* Binary search for first s in [1,lim] where conditions met */
UV bi = 1;
UV bj = rmult * (r-1);
while (bi < bj) {
s = bi + (bj-bi)/2;
if (!bern41_acceptable(n,r,s,tmp,tmp2)) bi = s+1;
else bj = s;
}
s = bj;
/* Our S goes from 2 to s+1. */
starta = 2;
s = s+1;
}
/* printf("chose r=%lu s=%lu d = %lu i = %lu j = %lu\n", r, s, d, i, j); */
/* Check divisibility to s(s-1) to cover both gcd conditions */
slim = s * (s-1);
if (_verbose > 1) printf("# aks trial to %"UVuf"\n", slim);
if (_GMP_trial_factor(n, 2, slim) > 1)
{ mpz_clear(tmp); mpz_clear(tmp2); return 0; }
/* If we checked divisibility to sqrt(n), then it is prime. */
mpz_sqrt(tmp, n);
if (mpz_cmp_ui(tmp, slim) <= 0)
{ mpz_clear(tmp); mpz_clear(tmp2); return 1; }
/* Check b^(n-1) = 1 mod n for b in [2..s] */
if (_verbose > 1) printf("# aks checking fermat to %"UVuf"\n", s);
mpz_sub_ui(tmp2, n, 1);
for (i = 2; i <= s; i++) {
mpz_set_ui(tmp, i);
mpz_powm(tmp, tmp, tmp2, n);
if (mpz_cmp_ui(tmp, 1) != 0)
{ mpz_clear(tmp); mpz_clear(tmp2); return 0; }
}
mpz_clear(tmp); mpz_clear(tmp2);
}
#endif
if (_verbose) gmp_printf("# AKS %Zd. r = %"UVuf" s = %"UVuf"\n", n, (unsigned long) r, (unsigned long) s);
/* Create the three polynomials we will use */
New(0, px, r, mpz_t);
New(0, py, r, mpz_t);
if ( !px || !py )
croak("allocation failure\n");
for (i = 0; i < r; i++) {
mpz_init(px[i]);
mpz_init(py[i]);
}
retval = 1;
for (a = starta; a <= s; a++) {
retval = test_anr(a, n, r, px, py);
if (!retval) break;
if (_verbose>1) { printf("."); fflush(stdout); }
}
if (_verbose>1) { printf("\n"); fflush(stdout); };
/* Free the polynomials */
for (i = 0; i < r; i++) {
mpz_clear(px[i]);
mpz_clear(py[i]);
}
Safefree(px);
Safefree(py);
return retval;
}
static AV*
S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* isa;
const HEK* stashhek;
struct mro_meta* meta;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
assert(HvAUX(stash));
stashhek = HvNAME_HEK(stash);
if (!stashhek)
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
HEK_KEY(stashhek));
meta = HvMROMETA(stash);
/* return cache if valid */
if((retval = meta->mro_linear_c3)) {
return retval;
}
/* not in cache, make a new one */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
if ( isa && ! SvAVOK(isa) ) {
Perl_croak(aTHX_ "@ISA is not an array but %s", Ddesc((SV*)isa));
}
/* For a better idea how the rest of this works, see the much clearer
pure perl version in Algorithm::C3 0.01:
http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
(later versions go about it differently than this code for speed reasons)
*/
if(isa && AvFILLp(isa) >= 0) {
SV** seqs_ptr;
I32 seqs_items;
HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
I32* heads;
/* This builds @seqs, which is an array of arrays.
The members of @seqs are the MROs of
the members of @ISA, followed by @ISA itself.
*/
I32 items = AvFILLp(isa) + 1;
SV** isa_ptr = AvARRAY(isa);
while(items--) {
SV* const isa_item = *isa_ptr++;
if ( ! SvPVOK(isa_item) ) {
Perl_croak(aTHX_ "@ISA element which is not an plain value");
}
{
HV* const isa_item_stash = gv_stashsv(isa_item, 0);
if(!isa_item_stash) {
/* if no stash, make a temporary fake MRO
containing just itself */
AV* const isa_lin = newAV();
av_push(isa_lin, newSVsv(isa_item));
av_push(seqs, (SV*)isa_lin);
}
else {
/* recursion */
AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
av_push(seqs, SvREFCNT_inc_NN((SV*)isa_lin));
}
}
}
av_push(seqs, SvREFCNT_inc_NN((SV*)isa));
/* This builds "heads", which as an array of integer array
indices, one per seq, which point at the virtual "head"
of the seq (initially zero) */
Newxz(heads, AvFILLp(seqs)+1, I32);
/* This builds %tails, which has one key for every class
mentioned in the tail of any sequence in @seqs (tail meaning
everything after the first class, the "head"). The value
is how many times this key appears in the tails of @seqs.
*/
seqs_ptr = AvARRAY(seqs);
seqs_items = AvFILLp(seqs) + 1;
while(seqs_items--) {
AV *const seq = MUTABLE_AV(*seqs_ptr++);
I32 seq_items = AvFILLp(seq);
if(seq_items > 0) {
SV** seq_ptr = AvARRAY(seq) + 1;
while(seq_items--) {
SV* const seqitem = *seq_ptr++;
/* LVALUE fetch will create a new undefined SV if necessary
*/
HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
if(he) {
SV* const val = HeVAL(he);
/* This will increment undef to 1, which is what we
want for a newly created entry. */
sv_inc(val);
}
}
}
}
/* Initialize retval to build the return value in */
retval = newAV();
av_push(retval, newSVhek(stashhek)); /* us first */
/* This loop won't terminate until we either finish building
the MRO, or get an exception. */
while(1) {
SV* cand = NULL;
SV* winner = NULL;
int s;
/* "foreach $seq (@seqs)" */
SV** const avptr = AvARRAY(seqs);
for(s = 0; s <= AvFILLp(seqs); s++) {
SV** svp;
AV * const seq = MUTABLE_AV(avptr[s]);
SV* seqhead;
if(!seq) continue; /* skip empty seqs */
svp = av_fetch(seq, heads[s], 0);
seqhead = *svp; /* seqhead = head of this seq */
if(!winner) {
HE* tail_entry;
SV* val;
/* if we haven't found a winner for this round yet,
and this seqhead is not in tails (or the count
for it in tails has dropped to zero), then this
seqhead is our new winner, and is added to the
final MRO immediately */
cand = seqhead;
if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
&& (val = HeVAL(tail_entry))
&& (SvIV(val) > 0))
continue;
winner = newSVsv(cand);
av_push(retval, winner);
/* note however that even when we find a winner,
we continue looping over @seqs to do housekeeping */
}
if(!sv_cmp(seqhead, winner)) {
/* Once we have a winner (including the iteration
where we first found him), inc the head ptr
for any seq which had the winner as a head,
NULL out any seq which is now empty,
and adjust tails for consistency */
const int new_head = ++heads[s];
if(new_head > AvFILLp(seq)) {
SvREFCNT_dec(avptr[s]);
avptr[s] = NULL;
}
else {
HE* tail_entry;
SV* val;
/* Because we know this new seqhead used to be
a tail, we can assume it is in tails and has
a positive value, which we need to dec */
svp = av_fetch(seq, new_head, 0);
seqhead = *svp;
tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
val = HeVAL(tail_entry);
sv_dec(val);
}
}
}
/* if we found no candidates, we are done building the MRO.
!cand means no seqs have any entries left to check */
if(!cand) {
Safefree(heads);
break;
}
/* If we had candidates, but nobody won, then the @ISA
hierarchy is not C3-incompatible */
if(!winner) {
SV *errmsg;
I32 i;
errmsg = newSVpvf(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s':\n\t"
"current merge results [\n", HEK_KEY(stashhek));
for (i = 0; i <= av_len(retval); i++) {
SV **elem = av_fetch(retval, i, 0);
sv_catpvf(aTHX_ errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
}
sv_catpvf(aTHX_ errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
/* we have to do some cleanup before we croak */
AvREFCNT_dec(retval);
Safefree(heads);
croak(aTHX_ "%"SVf, SVfARG(errmsg));
}
}
}
else { /* @ISA was undefined or empty */
/* build a retval containing only ourselves */
retval = newAV();
av_push(retval, newSVhek(stashhek));
}
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
meta->mro_linear_c3 = retval;
return retval;
}
void
PLCBA_request(
SV *self,
int cmd, int reqtype,
SV *callcb, SV *cbdata, int cbtype,
AV *params)
{
PLCBA_cmd_t cmdtype;
struct PLCBA_request_st r;
PLCBA_t *async;
libcouchbase_t instance;
PLCB_t *base;
AV *reqav;
PLCBA_cookie_t *cookie;
int nreq, i;
libcouchbase_error_t *errors;
int errcount;
int has_conversion;
SV **tmpsv;
time_t *multi_exp;
void **multi_key;
size_t *multi_nkey;
libcouchbase_error_t err;
libcouchbase_storage_t storop;
_mk_common_vars(self, instance, base, async);
Newxz(cookie, 1, PLCBA_cookie_t);
if(SvTYPE(callcb) == SVt_NULL) {
die("Must have callback for asynchronous request");
}
if(reqtype == PLCBA_REQTYPE_MULTI) {
nreq = av_len(params) + 1;
if(!nreq) {
die("No requests specified");
}
} else {
nreq = 1;
}
cookie->callcb = callcb; SvREFCNT_inc(callcb);
cookie->cbdata = cbdata; SvREFCNT_inc(cbdata);
cookie->cbtype = cbtype;
cookie->results = newHV();
cookie->parent = async;
cookie->remaining = nreq;
/*pseudo-multi system:
Most commands do not have a libcouchbase-level 'multi' implementation, but
nevertheless it's more efficient to allow a 'multi' option from Perl because
sub and xsub overhead is very expensive.
Each operation defines a macro '_do_cbop' which does the following:
1) call the libcouchbase api function appropriate for that operation
2) set the function variable 'err' to the error which ocurred.
the predefined pseudo_perform macro does the rest by doing the following:
1) check to see if the request is multiple or single
in the case of multiple requests, it:
I) fetches the current request AV
II) ensures the request is valid and defined
III) extracts the information from the request into our request_st
structure named 'r'
IV) calls the locally-defined _do_cbop (which sets the error)
V) checks the current value of 'err', if it is not a success, the
error counter is incremented
VI) when the loop has terminated, the error counter is checked again,
and if it is greater than zero, the error dispatcher is called
in the case of a single request, it:
I) treats 'params' as the request AV
II) passes the AV to av2request,
III) calls _do_cbop once, and checks for errors
IV) if there is an erorr, the dispatcher is called
*/
#define _fetch_assert(idx) \
if((tmpsv = av_fetch(params, idx, 0)) == NULL) { \
die("Null request found in request list"); \
} \
if(!SvROK(*tmpsv)) { \
die("Expected reference type in parameter list."); \
} \
av2request(async, cmd, (AV*)(SvRV(*tmpsv)), &r);
#define pseudo_multi_begin \
Newxz(errors, nreq, libcouchbase_error_t); \
errcount = 0;
#define pseudo_multi_maybe_add \
if( (errors[i] = err) != LIBCOUCHBASE_SUCCESS ) \
errcount++;
#define pseudo_multi_end \
if(errcount) \
error_pseudo_multi(async, params, errors, cookie); \
Safefree(errors);
#define pseudo_perform \
if(reqtype == PLCBA_REQTYPE_MULTI) { \
pseudo_multi_begin; \
for(i = 0; i < nreq; i++) { \
_fetch_assert(i); \
_do_cbop(); \
pseudo_multi_maybe_add; \
} \
if(errcount < nreq) { \
libcouchbase_wait(instance); \
} \
} else { \
av2request(async, cmd, params, &r); \
_do_cbop(); \
if(err != LIBCOUCHBASE_SUCCESS) { \
warn("Key %s did not return OK (%d)", r.key, err); \
error_single(async, cookie, r.key, r.nkey, err); \
} else { \
libcouchbase_wait(instance); \
} \
} \
switch(cmd) {
case PLCBA_CMD_GET:
case PLCBA_CMD_TOUCH:
#define _do_cbop(klist, szlist, explist) \
if(cmd == PLCBA_CMD_GET) { \
err = libcouchbase_mget(instance, cookie, nreq, \
(const void* const*)klist, \
(szlist), explist); \
} else { \
err = libcouchbase_mtouch(instance, cookie, nreq, \
(const void* const*)klist, \
szlist, explist); \
}
if(reqtype == PLCBA_REQTYPE_MULTI) {
Newx(multi_key, nreq, void*);
Newx(multi_nkey, nreq, size_t);
Newx(multi_exp, nreq, time_t);
for(i = 0; i < nreq; i++) {
_fetch_assert(i);
multi_key[i] = r.key;
multi_nkey[i] = r.nkey;
multi_exp[i] = r.exp;
}
_do_cbop(multi_key, multi_nkey, multi_exp);
if(err != LIBCOUCHBASE_SUCCESS) {
error_true_multi(
async, cookie, nreq, (const char**)multi_key, multi_nkey, err);
} else {
libcouchbase_wait(instance);
}
Safefree(multi_key);
Safefree(multi_nkey);
Safefree(multi_exp);
} else {
av2request(async, cmd, params, &r);
_do_cbop(&(r.key), &(r.nkey), &(r.exp));
if(err != LIBCOUCHBASE_SUCCESS) {
error_single(async, cookie, r.key, r.nkey, err);
} else {
libcouchbase_wait(instance);
}
}
break;
#undef _do_cbop
case PLCBA_CMD_SET:
case PLCBA_CMD_ADD:
case PLCBA_CMD_REPLACE:
case PLCBA_CMD_APPEND:
case PLCBA_CMD_PREPEND:
storop = async_cmd_to_storop(cmd);
//warn("Storop is %x (cmd=%x)", storop, cmd);
has_conversion = plcba_cmd_needs_conversion(cmd);
#define _do_cbop() \
err = libcouchbase_store(instance, cookie, storop, r.key, r.nkey, \
SvPVX(r.value), r.nvalue, r.store_flags, \
r.exp, r.cas); \
if(has_conversion) { \
plcb_convert_storage_free(base, r.value, r.store_flags); \
}
pseudo_perform;
break;
#undef _do_cbop
case PLCBA_CMD_ARITHMETIC:
#define _do_cbop() \
err = libcouchbase_arithmetic(instance, cookie, r.key, r.nkey, \
r.arithmetic.delta, r.exp, \
r.arithmetic.create, r.arithmetic.initial);
pseudo_perform;
break;
#undef _do_cbop
case PLCBA_CMD_REMOVE:
#define _do_cbop() \
err = libcouchbase_remove(instance, cookie, r.key, r.nkey, r.cas);
pseudo_perform;
break;
#undef _do_cbop
default:
die("Unimplemented!");
}
#undef _fetch_assert
#undef pseudo_multi_begin
#undef pseduo_multi_maybe_add
#undef pseudo_multi_end
#undef pseudo_perform
}
int
_check_buf(PerlIO *infile, Buffer *buf, int min_wanted, int max_wanted)
{
int ret = 1;
// Do we have enough data?
if ( buffer_len(buf) < min_wanted ) {
// Read more data
uint32_t read;
uint32_t actual_wanted;
unsigned char *tmp;
#ifdef _MSC_VER
uint32_t pos_check = PerlIO_tell(infile);
#endif
if (min_wanted > max_wanted) {
max_wanted = min_wanted;
}
// Adjust actual amount to read by the amount we already have in the buffer
actual_wanted = max_wanted - buffer_len(buf);
New(0, tmp, actual_wanted, unsigned char);
DEBUG_TRACE("Buffering from file @ %d (min_wanted %d, max_wanted %d, adjusted to %d)\n",
(int)PerlIO_tell(infile), min_wanted, max_wanted, actual_wanted
);
if ( (read = PerlIO_read(infile, tmp, actual_wanted)) <= 0 ) {
if ( PerlIO_error(infile) ) {
#ifdef _MSC_VER
// Show windows specific error message as Win32 PerlIO_read does not set errno
DWORD last_error = GetLastError();
LPWSTR *errmsg = NULL;
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, 0, last_error, 0, (LPWSTR)&errmsg, 0, NULL);
warn("Error reading: %d %s (read %d wanted %d)\n", last_error, errmsg, read, actual_wanted);
LocalFree(errmsg);
#else
warn("Error reading: %s (wanted %d)\n", strerror(errno), actual_wanted);
#endif
}
else {
warn("Error: Unable to read at least %d bytes from file.\n", min_wanted);
}
ret = 0;
goto out;
}
buffer_append(buf, tmp, read);
// Make sure we got enough
if ( buffer_len(buf) < min_wanted ) {
warn("Error: Unable to read at least %d bytes from file (only read %d).\n", min_wanted, read);
ret = 0;
goto out;
}
#ifdef _MSC_VER
// Bug 16095, weird off-by-one bug seen only on Win32 and only when reading a filehandle
if (PerlIO_tell(infile) != pos_check + read) {
//PerlIO_printf(PerlIO_stderr(), "Win32 bug, pos should be %d, but was %d\n", pos_check + read, PerlIO_tell(infile));
PerlIO_seek(infile, pos_check + read, SEEK_SET);
}
#endif
DEBUG_TRACE("Buffered %d bytes, new pos %d\n", read, (int)PerlIO_tell(infile));
out:
Safefree(tmp);
}
STATIC I32
S_do_trans_complex(pTHX_ SV *sv)
{
U8 *s;
U8 *send;
U8 *d;
U8 *dstart;
I32 isutf8;
I32 matches = 0;
I32 grows = PL_op->op_private & OPpTRANS_GROWS;
I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
I32 del = PL_op->op_private & OPpTRANS_DELETE;
STRLEN len, rlen = 0;
short *tbl;
I32 ch;
tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
s = (U8*)SvPV(sv, len);
isutf8 = SvUTF8(sv);
send = s + len;
if (!isutf8) {
dstart = d = s;
if (PL_op->op_private & OPpTRANS_SQUASH) {
U8* p = send;
while (s < send) {
if ((ch = tbl[*s]) >= 0) {
*d = (U8)ch;
matches++;
if (p != d - 1 || *p != *d)
p = d++;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
else {
while (s < send) {
if ((ch = tbl[*s]) >= 0) {
matches++;
*d++ = (U8)ch;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
*d = '\0';
SvCUR_set(sv, d - dstart);
}
else { /* isutf8 */
if (grows)
New(0, d, len*2+1, U8);
else
d = s;
dstart = d;
if (complement && !del)
rlen = tbl[0x100];
#ifdef MACOS_TRADITIONAL
#define comp CoMP /* "comp" is a keyword in some compilers ... */
#endif
if (PL_op->op_private & OPpTRANS_SQUASH) {
UV pch = 0xfeedface;
while (s < send) {
STRLEN len;
UV comp = utf8_to_uvchr(s, &len);
if (comp > 0xff) {
if (!complement) {
Copy(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
ch = (rlen == 0) ? comp :
(comp - 0x100 < rlen) ?
tbl[comp+1] : tbl[0x100+rlen];
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
}
}
else if ((ch = tbl[comp]) >= 0) {
matches++;
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
else if (ch == -1) { /* -1 is unmapped character */
Copy(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
pch = 0xfeedface;
}
}
else {
while (s < send) {
STRLEN len;
UV comp = utf8_to_uvchr(s, &len);
if (comp > 0xff) {
if (!complement) {
Move(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
if (comp - 0x100 < rlen)
d = uvchr_to_utf8(d, tbl[comp+1]);
else
d = uvchr_to_utf8(d, tbl[0x100+rlen]);
}
}
}
else if ((ch = tbl[comp]) >= 0) {
d = uvchr_to_utf8(d, ch);
matches++;
}
else if (ch == -1) { /* -1 is unmapped character */
Copy(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
}
}
if (grows) {
sv_setpvn(sv, (char*)dstart, d - dstart);
Safefree(dstart);
}
else {
*d = '\0';
SvCUR_set(sv, d - dstart);
}
SvUTF8_on(sv);
}
SvSETMAGIC(sv);
return matches;
}
STATIC I32
S_do_trans_simple(pTHX_ SV *sv)
{
U8 *s;
U8 *d;
U8 *send;
U8 *dstart;
I32 matches = 0;
I32 grows = PL_op->op_private & OPpTRANS_GROWS;
STRLEN len;
short *tbl;
I32 ch;
tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
s = (U8*)SvPV(sv, len);
send = s + len;
/* First, take care of non-UTF-8 input strings, because they're easy */
if (!SvUTF8(sv)) {
while (s < send) {
if ((ch = tbl[*s]) >= 0) {
matches++;
*s++ = (U8)ch;
}
else
s++;
}
SvSETMAGIC(sv);
return matches;
}
/* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
if (grows)
New(0, d, len*2+1, U8);
else
d = s;
dstart = d;
while (s < send) {
STRLEN ulen;
UV c;
/* Need to check this, otherwise 128..255 won't match */
c = utf8n_to_uvchr(s, send - s, &ulen, 0);
if (c < 0x100 && (ch = tbl[c]) >= 0) {
matches++;
d = uvchr_to_utf8(d, ch);
s += ulen;
}
else { /* No match -> copy */
Move(s, d, ulen, U8);
d += ulen;
s += ulen;
}
}
if (grows) {
sv_setpvn(sv, (char*)dstart, d - dstart);
Safefree(dstart);
}
else {
*d = '\0';
SvCUR_set(sv, d - dstart);
}
SvUTF8_on(sv);
SvSETMAGIC(sv);
return matches;
}
I32 regexp_exechook_hook (pTHX_ regexp* r, char* stringarg, char* strend,
char* strbeg, I32 minend, SV* screamer,
void* data, U32 flags)
{
if(!CONTAINS_RECOGNITION_FLAG(r)) {
return previous_exec_hook(aTHX_ r,stringarg,strend,strbeg,
minend,screamer,data,flags);
}
else {
SV* perl_callback;
I32 ret;
IV matched;
I32 delta;
dSP;
/*
fprintf(stderr,"strarg=%lu\nstrbeg=%lu\nstrend=%lu\n",stringarg,strbeg,strend);
fprintf(stderr,"minend=%ld pos=%ld\n",minend,PL_reg_ganch);
fprintf(stderr,"flags=%lu\n",flags);
*/
perl_callback = r->substrs->data[0].substr;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(newSVpv(stringarg,strend-stringarg));
mXPUSHu(flags);
mXPUSHu((unsigned long)r);
PUTBACK;
/* fprintf(stderr,"exec hook r=%lu callback SV*=%lu\n",(unsigned long)r,(unsigned long)perl_callback); */
ret = call_sv(perl_callback, G_ARRAY);
/* fprintf(stderr,"exec hook survived.\n"); */
if(ret < 1) {
fprintf(stderr,"regexp_hook_exec failed - didnt return anything\n"); exit(0);
}
SPAGAIN;
matched = POPi;
{ /* fail captures */
int i;
for(i=0;i<=r->nparens;i++) {
r->startp[i] = -1;
r->endp[i] = -1;
}
r->lastparen = r->lastcloseparen = 0;
}
if(matched) {
SV* lp;
SV* lcp;
int i;
if(ret < 3 || ret > 3 + 2 * (r->nparens+1)) {
fprintf(stderr,"regexp_hook_exec failed - paren info broken\n"); exit(0);
}
lp = POPs;
lcp = POPs;
delta = stringarg-strbeg;
for(i=0;i<=r->nparens && i+3<ret;i++) {
I32 v = POPi;
r->startp[i] = v >= 0 ? v+delta : v;
v = POPi;
r->endp[i] = v >= 0 ? v+delta : v;
}
r->lastparen = (lp == &PL_sv_undef) ? SvIV(lp) : r->nparens;
r->lastcloseparen = (lcp == &PL_sv_undef) ? SvIV(lcp) : r->nparens;
Safefree(r->subbeg);
r->sublen = strend-strbeg;
r->subbeg = savepvn(strbeg,r->sublen);
}
PUTBACK;
FREETMPS;
LEAVE;
/* fprintf(stderr,"done.\n"); */
return matched ? 1 : 0;
}
}
static void clearFactorBase(void)
{
if (factorBase) { Safefree(factorBase); factorBase = 0; }
if (primeSizes) { Safefree(primeSizes); primeSizes = 0; }
}
void destroy_typesafedata(TypeSafeData* self) {
destroy_listable((Listable*)self);
Safefree(self->datatype);
}
STATIC I32
S_do_trans_complex(pTHX_ SV * const sv)
{
STRLEN len;
U8 *s = (U8*)SvPV_nomg(sv, len);
U8 * const send = s+len;
I32 matches = 0;
const short * const tbl = (short*)cPVOP->op_pv;
PERL_ARGS_ASSERT_DO_TRANS_COMPLEX;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
if (!SvUTF8(sv)) {
U8 *d = s;
U8 * const dstart = d;
if (PL_op->op_private & OPpTRANS_SQUASH) {
const U8* p = send;
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
*d = (U8)ch;
matches++;
if (p != d - 1 || *p != *d)
p = d++;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
else {
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
matches++;
*d++ = (U8)ch;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
*d = '\0';
SvCUR_set(sv, d - dstart);
}
else { /* is utf8 */
const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
const I32 del = PL_op->op_private & OPpTRANS_DELETE;
U8 *d;
U8 *dstart;
STRLEN rlen = 0;
if (grows)
Newx(d, len*2+1, U8);
else
d = s;
dstart = d;
if (complement && !del)
rlen = tbl[0x100];
if (PL_op->op_private & OPpTRANS_SQUASH) {
UV pch = 0xfeedface;
while (s < send) {
STRLEN len;
const UV comp = utf8n_to_uvchr(s, send - s, &len,
UTF8_ALLOW_DEFAULT);
I32 ch;
if (comp > 0xff) {
if (!complement) {
Move(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
ch = (rlen == 0) ? (I32)comp :
(comp - 0x100 < rlen) ?
tbl[comp+1] : tbl[0x100+rlen];
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
}
}
else if ((ch = tbl[comp]) >= 0) {
matches++;
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
else if (ch == -1) { /* -1 is unmapped character */
Move(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
pch = 0xfeedface;
}
}
else {
while (s < send) {
STRLEN len;
const UV comp = utf8n_to_uvchr(s, send - s, &len,
UTF8_ALLOW_DEFAULT);
I32 ch;
if (comp > 0xff) {
if (!complement) {
Move(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
if (comp - 0x100 < rlen)
d = uvchr_to_utf8(d, tbl[comp+1]);
else
d = uvchr_to_utf8(d, tbl[0x100+rlen]);
}
}
}
else if ((ch = tbl[comp]) >= 0) {
d = uvchr_to_utf8(d, ch);
matches++;
}
else if (ch == -1) { /* -1 is unmapped character */
Move(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
}
}
if (grows) {
sv_setpvn(sv, (char*)dstart, d - dstart);
Safefree(dstart);
}
else {
*d = '\0';
SvCUR_set(sv, d - dstart);
}
SvUTF8_on(sv);
}
SvSETMAGIC(sv);
return matches;
}
static int sieve_segment(unsigned char* mem, UV startd, UV endd,
const unsigned char* prim_sieve, UV prim_limit)
{
const unsigned char* sieve;
UV limit, p;
UV startp = 30*startd;
UV endp = (endd >= (UV_MAX/30)) ? UV_MAX-2 : 30*endd+29;
MPUassert( (mem != 0) && (endd >= startd) && (endp >= startp),
"sieve_segment bad arguments");
/* Fill buffer with marked 7, 11, and 13 */
sieve_prefill(mem, startd, endd);
limit = (UV) sqrt((double) endp);
if (limit*limit < endp) limit++; /* ceil(sqrt(endp)) */
/* printf("segment sieve from %"UVuf" to %"UVuf" (aux sieve to %"UVuf")\n", startp, endp, limit); */
if ( (prim_sieve != 0) && (limit <= prim_limit) ) {
sieve = prim_sieve;
} else {
sieve = sieve_erat30(limit);
}
MPUassert( sieve != 0, "Could not generate base sieve" );
for (p = 17; p <= limit; p = next_prime_in_sieve(sieve,p))
{
/* p increments from 17 to at least sqrt(endp) */
UV p2 = p*p; /* TODO: overflow */
if (p2 > endp) break;
/* Find first multiple of p greater than p*p and larger than startp */
if (p2 < startp) {
p2 = (startp / p) * p;
if (p2 < startp) p2 += p;
}
/* Bump to next multiple that isn't divisible by 2, 3, or 5 */
while (masktab30[p2%30] == 0) { p2 += p; }
/* It is possible we've overflowed p2, so check for that */
if ( (p2 <= endp) && (p2 >= startp) ) {
/* Sieve from startd to endd starting at p2, stepping p */
UV d = (p2)/30;
UV m = (p2) - d*30;
UV dinc = (2*p)/30;
UV minc = (2*p) - dinc*30;
UV wdinc[8];
unsigned char wmask[8];
UV offset_endd = endd - startd;
/* Find the positions of the next composites we will mark */
FIND_COMPOSITE_POSITIONS(p);
d -= startd;
/* Mark composites (unrolled) */
while ( (d+p) <= offset_endd ) {
mem[d] |= wmask[0]; d += wdinc[0];
mem[d] |= wmask[1]; d += wdinc[1];
mem[d] |= wmask[2]; d += wdinc[2];
mem[d] |= wmask[3]; d += wdinc[3];
mem[d] |= wmask[4]; d += wdinc[4];
mem[d] |= wmask[5]; d += wdinc[5];
mem[d] |= wmask[6]; d += wdinc[6];
mem[d] |= wmask[7]; d += wdinc[7];
}
while (1) {
mem[d] |= wmask[0]; d += wdinc[0]; if (d > offset_endd) break;
mem[d] |= wmask[1]; d += wdinc[1]; if (d > offset_endd) break;
mem[d] |= wmask[2]; d += wdinc[2]; if (d > offset_endd) break;
mem[d] |= wmask[3]; d += wdinc[3]; if (d > offset_endd) break;
mem[d] |= wmask[4]; d += wdinc[4]; if (d > offset_endd) break;
mem[d] |= wmask[5]; d += wdinc[5]; if (d > offset_endd) break;
mem[d] |= wmask[6]; d += wdinc[6]; if (d > offset_endd) break;
mem[d] |= wmask[7]; d += wdinc[7]; if (d > offset_endd) break;
}
}
}
if (sieve != prim_sieve) Safefree(sieve);
return 1;
}