Exemple #1
0
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;
}
Exemple #2
0
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;
}
Exemple #3
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;
}
Exemple #4
0
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;
}
Exemple #5
0
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
}
Exemple #7
0
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);
  }
Exemple #8
0
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;
}
Exemple #9
0
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;
}
Exemple #10
0
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; }
}
Exemple #12
0
void destroy_typesafedata(TypeSafeData* self) {
	destroy_listable((Listable*)self);	
	Safefree(self->datatype);
}
Exemple #13
0
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;
}