ffi.c
No OneTemporary
Actions

Size

34 KB

Subscribers

None

ffi.c
View Options

	/* FFI interface for TinySCHEME.
	*
	* Copyright (C) 2016 g10 code GmbH
	*
	* This file is part of GnuPG.
	*
	* GnuPG is free software; you can redistribute it and/or modify
	* it under the terms of the GNU General Public License as published by
	* the Free Software Foundation; either version 3 of the License, or
	* (at your option) any later version.
	*
	* GnuPG is distributed in the hope that it will be useful,
	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	* GNU General Public License for more details.
	*
	* You should have received a copy of the GNU General Public License
	* along with this program; if not, see <https://www.gnu.org/licenses/>.
	*/

	#include <config.h>

	#include <assert.h>
	#include <ctype.h>
	#include <dirent.h>
	#include <errno.h>
	#include <fcntl.h>
	#include <gpg-error.h>
	#include <limits.h>
	#include <stdarg.h>
	#include <stdlib.h>
	#include <stdio.h>
	#include <string.h>
	#include <sys/types.h>
	#include <sys/stat.h>
	#include <unistd.h>

	#if HAVE_LIBREADLINE
	#define GNUPG_LIBREADLINE_H_INCLUDED
	#include <readline/readline.h>
	#include <readline/history.h>
	#endif

	#include "../../common/util.h"
	#include "../../common/exechelp.h"
	#include "../../common/sysutils.h"

	#ifdef HAVE_W32_SYSTEM
	#include <windows.h>
	#endif

	#include "private.h"
	#include "ffi.h"
	#include "ffi-private.h"

	/* For use in nice error messages. */
	static const char *
	ordinal_suffix (int n)
	{
	switch (n)
	{
	case 1: return "st";
	case 2: return "nd";
	case 3: return "rd";
	default: return "th";
	}
	assert (! "reached");
	}



	int
	ffi_bool_value (scheme *sc, pointer p)
	{
	return ! (p == sc->F);
	}



	static pointer
	do_logand (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	unsigned int v, acc = ~0;
	while (args != sc->NIL)
	{
	FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
	acc &= v;
	}
	FFI_RETURN_INT (sc, acc);
	}

	static pointer
	do_logior (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	unsigned int v, acc = 0;
	while (args != sc->NIL)
	{
	FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
	acc \|= v;
	}
	FFI_RETURN_INT (sc, acc);
	}

	static pointer
	do_logxor (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	unsigned int v, acc = 0;
	while (args != sc->NIL)
	{
	FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
	acc ^= v;
	}
	FFI_RETURN_INT (sc, acc);
	}

	static pointer
	do_lognot (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	unsigned int v;
	FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	FFI_RETURN_INT (sc, ~v);
	}

	/* User interface. */

	static pointer
	do_flush_stdio (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	fflush (stdout);
	fflush (stderr);
	FFI_RETURN (sc);
	}


	int use_libreadline;

	/* Read a string, and return a pointer to it. Returns NULL on EOF. */
	char *
	rl_gets (const char *prompt)
	{
	static char *line = NULL;
	char *p;
	xfree (line);

	#if HAVE_LIBREADLINE
	{
	line = readline (prompt);
	if (line && *line)
	add_history (line);
	}
	#else
	{
	size_t max_size = 0xff;
	printf ("%s", prompt);
	fflush (stdout);
	line = xtrymalloc (max_size);
	if (line != NULL)
	fgets (line, max_size, stdin);
	}
	#endif

	/* Strip trailing whitespace. */
	if (line && strlen (line) > 0)
	for (p = &line[strlen (line) - 1]; isspace (*p); p--)
	*p = 0;

	return line;
	}

	static pointer
	do_prompt (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	const char *prompt;
	const char *line;
	FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	line = rl_gets (prompt);
	if (! line)
	FFI_RETURN_POINTER (sc, sc->EOF_OBJ);

	FFI_RETURN_STRING (sc, line);
	}

	static pointer
	do_sleep (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	unsigned int seconds;
	FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	sleep (seconds);
	FFI_RETURN (sc);
	}

	static pointer
	do_usleep (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	useconds_t microseconds;
	FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	usleep (microseconds);
	FFI_RETURN (sc);
	}

	static pointer
	do_chdir (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *name;
	FFI_ARG_OR_RETURN (sc, char *, name, path, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	if (chdir (name))
	FFI_RETURN_ERR (sc, errno);
	FFI_RETURN (sc);
	}

	static pointer
	do_strerror (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int error;
	FFI_ARG_OR_RETURN (sc, int, error, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	FFI_RETURN_STRING (sc, gpg_strerror (error));
	}

	static pointer
	do_getenv (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *name;
	char *value;
	FFI_ARG_OR_RETURN (sc, char *, name, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	value = getenv (name);
	FFI_RETURN_STRING (sc, value ? value : "");
	}

	static pointer
	do_setenv (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *name;
	char *value;
	int overwrite;
	FFI_ARG_OR_RETURN (sc, char *, name, string, args);
	FFI_ARG_OR_RETURN (sc, char *, value, string, args);
	FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	if (gnupg_setenv (name, value, overwrite))
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	FFI_RETURN (sc);
	}

	static pointer
	do_exit (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int retcode;
	FFI_ARG_OR_RETURN (sc, int, retcode, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	exit (retcode);
	}

	/* XXX: use gnupgs variant b/c mode as string */
	static pointer
	do_open (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int fd;
	char *pathname;
	int flags;
	mode_t mode = 0;
	FFI_ARG_OR_RETURN (sc, char *, pathname, path, args);
	FFI_ARG_OR_RETURN (sc, int, flags, number, args);
	if (args != sc->NIL)
	FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	fd = open (pathname, flags, mode);
	if (fd == -1)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	FFI_RETURN_INT (sc, fd);
	}

	static pointer
	do_fdopen (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	FILE *stream;
	int fd;
	char *mode;
	int kind;
	FFI_ARG_OR_RETURN (sc, int, fd, number, args);
	FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	stream = fdopen (fd, mode);
	if (stream == NULL)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());

	if (setvbuf (stream, NULL, _IONBF, 0) != 0)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());

	kind = 0;
	if (strchr (mode, 'r'))
	kind \|= port_input;
	if (strchr (mode, 'w'))
	kind \|= port_output;

	FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind));
	}

	static pointer
	do_close (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int fd;
	FFI_ARG_OR_RETURN (sc, int, fd, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ());
	}

	static pointer
	do_seek (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int fd;
	off_t offset;
	int whence;
	FFI_ARG_OR_RETURN (sc, int, fd, number, args);
	FFI_ARG_OR_RETURN (sc, off_t, offset, number, args);
	FFI_ARG_OR_RETURN (sc, int, whence, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	FFI_RETURN_ERR (sc, lseek (fd, offset, whence) == (off_t) -1
	? gpg_error_from_syserror () : 0);
	}

	static pointer
	do_get_temp_path (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	#ifdef HAVE_W32_SYSTEM
	char buffer[MAX_PATH+1];
	#endif
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	#ifdef HAVE_W32_SYSTEM
	if (GetTempPath (MAX_PATH+1, buffer) == 0)
	FFI_RETURN_STRING (sc, "/temp");
	FFI_RETURN_STRING (sc, buffer);
	#else
	FFI_RETURN_STRING (sc, "/tmp");
	#endif
	}

	static pointer
	do_mkdtemp (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *template;
	#ifdef PATH_MAX
	char buffer[PATH_MAX];
	#else
	char buffer[1024];
	#endif
	char *name;
	FFI_ARG_OR_RETURN (sc, char *, template, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	if (strlen (template) > sizeof buffer - 1)
	FFI_RETURN_ERR (sc, EINVAL);
	strncpy (buffer, template, sizeof buffer);

	name = gnupg_mkdtemp (buffer);
	if (name == NULL)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	FFI_RETURN_STRING (sc, name);
	}

	static pointer
	do_unlink (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *name;
	FFI_ARG_OR_RETURN (sc, char *, name, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	if (unlink (name) == -1)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	FFI_RETURN (sc);
	}

	static gpg_error_t
	unlink_recursively (const char *name)
	{
	gpg_error_t err = 0;
	struct stat st;

	if (stat (name, &st) == -1)
	return gpg_error_from_syserror ();

	if (S_ISDIR (st.st_mode))
	{
	DIR *dir;
	struct dirent *dent;

	dir = opendir (name);
	if (dir == NULL)
	return gpg_error_from_syserror ();

	while ((dent = readdir (dir)))
	{
	char *child;

	if (strcmp (dent->d_name, ".") == 0
	\|\| strcmp (dent->d_name, "..") == 0)
	continue;

	child = xtryasprintf ("%s/%s", name, dent->d_name);
	if (child == NULL)
	{
	err = gpg_error_from_syserror ();
	goto leave;
	}

	err = unlink_recursively (child);
	xfree (child);
	if (err == gpg_error_from_errno (ENOENT))
	err = 0;
	if (err)
	goto leave;
	}

	leave:
	closedir (dir);
	if (! err)
	rmdir (name);
	return err;
	}
	else
	if (unlink (name) == -1)
	return gpg_error_from_syserror ();
	return 0;
	}

	static pointer
	do_unlink_recursively (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *name;
	FFI_ARG_OR_RETURN (sc, char *, name, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	err = unlink_recursively (name);
	FFI_RETURN (sc);
	}

	static pointer
	do_rename (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *old;
	char *new;
	FFI_ARG_OR_RETURN (sc, char *, old, string, args);
	FFI_ARG_OR_RETURN (sc, char *, new, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	if (rename (old, new) == -1)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	FFI_RETURN (sc);
	}

	static pointer
	do_getcwd (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	pointer result;
	char *cwd;
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	cwd = gnupg_getcwd ();
	if (cwd == NULL)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	result = sc->vptr->mk_string (sc, cwd);
	xfree (cwd);
	FFI_RETURN_POINTER (sc, result);
	}

	static pointer
	do_mkdir (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *name;
	char *mode;
	FFI_ARG_OR_RETURN (sc, char *, name, string, args);
	FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	if (gnupg_mkdir (name, mode) == -1)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	FFI_RETURN (sc);
	}

	static pointer
	do_rmdir (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *name;
	FFI_ARG_OR_RETURN (sc, char *, name, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	if (rmdir (name) == -1)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	FFI_RETURN (sc);
	}

	static pointer
	do_get_isotime (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	gnupg_isotime_t timebuf;
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	gnupg_get_isotime (timebuf);
	FFI_RETURN_STRING (sc, timebuf);
	}

	static pointer
	do_get_time (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	FFI_RETURN_INT (sc, gnupg_get_time ());
	}

	static pointer
	do_getpid (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	FFI_RETURN_INT (sc, getpid ());
	}

	static pointer
	do_srandom (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int seed;
	FFI_ARG_OR_RETURN (sc, int, seed, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	srand (seed);
	FFI_RETURN (sc);
	}

	static int
	random_scaled (int scale)
	{
	int v;
	#ifdef HAVE_RAND
	v = rand ();
	#else
	v = random ();
	#endif

	#ifndef RAND_MAX /* for SunOS */
	#define RAND_MAX 32767
	#endif

	return ((int) (1 + (int) ((float) scale * v / (RAND_MAX + 1.0))) - 1);
	}

	static pointer
	do_random (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int scale;
	FFI_ARG_OR_RETURN (sc, int, scale, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	FFI_RETURN_INT (sc, random_scaled (scale));
	}

	static pointer
	do_make_random_string (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int size;
	pointer chunk;
	char *p;
	FFI_ARG_OR_RETURN (sc, int, size, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	if (size < 0)
	return ffi_sprintf (sc, "size must be positive");

	chunk = sc->vptr->mk_counted_string (sc, NULL, size);
	if (sc->no_memory)
	FFI_RETURN_ERR (sc, ENOMEM);

	for (p = sc->vptr->string_value (chunk); size; p++, size--)
	*p = (char) random_scaled (256);
	FFI_RETURN_POINTER (sc, chunk);
	}



	/* estream functions. */

	struct es_object_box
	{
	estream_t stream;
	int closed;
	};

	static void
	es_object_finalize (scheme sc, void data)
	{
	struct es_object_box *box = data;
	(void) sc;

	if (! box->closed)
	es_fclose (box->stream);
	xfree (box);
	}

	static void
	es_object_to_string (scheme sc, char out, size_t size, void *data)
	{
	struct es_object_box *box = data;
	(void) sc;

	snprintf (out, size, "#estream %p", box->stream);
	}

	static struct foreign_object_vtable es_object_vtable =
	{
	es_object_finalize,
	es_object_to_string,
	};

	static pointer
	es_wrap (scheme *sc, estream_t stream)
	{
	struct es_object_box box = xmalloc (sizeof box);
	if (box == NULL)
	return sc->NIL;

	box->stream = stream;
	box->closed = 0;
	return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box);
	}

	static struct es_object_box *
	es_unwrap (scheme *sc, pointer object)
	{
	(void) sc;

	if (! is_foreign_object (object))
	return NULL;

	if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable)
	return NULL;

	return sc->vptr->get_foreign_object_data (object);
	}

	#define CONVERSION_estream(SC, X) es_unwrap (SC, X)
	#define IS_A_estream(SC, X) es_unwrap (SC, X)

	static pointer
	do_es_fclose (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	struct es_object_box *box;
	FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	err = es_fclose (box->stream);
	if (! err)
	box->closed = 1;
	FFI_RETURN (sc);
	}

	static pointer
	do_es_read (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	struct es_object_box *box;
	size_t bytes_to_read;

	pointer result;
	void *buffer;
	size_t bytes_read;

	FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
	FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	buffer = xtrymalloc (bytes_to_read);
	if (buffer == NULL)
	FFI_RETURN_ERR (sc, ENOMEM);

	err = es_read (box->stream, buffer, bytes_to_read, &bytes_read);
	if (err)
	FFI_RETURN_ERR (sc, err);

	result = sc->vptr->mk_counted_string (sc, buffer, bytes_read);
	xfree (buffer);
	FFI_RETURN_POINTER (sc, result);
	}

	static pointer
	do_es_feof (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	struct es_object_box *box;
	FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F);
	}

	static pointer
	do_es_write (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	struct es_object_box *box;
	const char *buffer;
	size_t bytes_to_write, bytes_written;

	FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
	/* XXX how to get the length of the string buffer? scheme strings
	may contain \0. */
	FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	bytes_to_write = strlen (buffer);
	while (bytes_to_write > 0)
	{
	err = es_write (box->stream, buffer, bytes_to_write, &bytes_written);
	if (err)
	break;
	bytes_to_write -= bytes_written;
	buffer += bytes_written;
	}

	FFI_RETURN (sc);
	}



	/* Process handling. */

	static pointer
	do_spawn_process (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	pointer arguments;
	char **argv;
	size_t len;
	unsigned int flags;

	estream_t infp;
	estream_t outfp;
	estream_t errfp;
	pid_t pid;

	FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
	FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	err = ffi_list2argv (sc, arguments, &argv, &len);
	if (err == gpg_error (GPG_ERR_INV_VALUE))
	return ffi_sprintf (sc, "%luth element of first argument is "
	"neither string nor symbol",
	(unsigned long) len);
	if (err)
	FFI_RETURN_ERR (sc, err);

	if (verbose > 1)
	{
	char **p;
	fprintf (stderr, "Executing:");
	for (p = argv; *p; p++)
	fprintf (stderr, " '%s'", *p);
	fprintf (stderr, "\n");
	}

	err = gnupg_spawn_process (argv[0], (const char **) &argv[1],
	NULL,
	NULL,
	flags,
	&infp, &outfp, &errfp, &pid);
	xfree (argv);
	#define IMC(A, B) \
	_cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
	#define IMS(A, B) \
	_cons (sc, es_wrap (sc, (A)), (B), 1)
	FFI_RETURN_POINTER (sc, IMS (infp,
	IMS (outfp,
	IMS (errfp,
	IMC (pid, sc->NIL)))));
	#undef IMS
	#undef IMC
	}

	static pointer
	do_spawn_process_fd (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	pointer arguments;
	char **argv;
	size_t len;
	int infd, outfd, errfd;

	pid_t pid;

	FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
	FFI_ARG_OR_RETURN (sc, int, infd, number, args);
	FFI_ARG_OR_RETURN (sc, int, outfd, number, args);
	FFI_ARG_OR_RETURN (sc, int, errfd, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	err = ffi_list2argv (sc, arguments, &argv, &len);
	if (err == gpg_error (GPG_ERR_INV_VALUE))
	return ffi_sprintf (sc, "%luth element of first argument is "
	"neither string nor symbol",
	(unsigned long) len);
	if (err)
	FFI_RETURN_ERR (sc, err);

	if (verbose > 1)
	{
	char **p;
	fprintf (stderr, "Executing:");
	for (p = argv; *p; p++)
	fprintf (stderr, " '%s'", *p);
	fprintf (stderr, "\n");
	}

	err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1],
	infd, outfd, errfd, &pid);
	xfree (argv);
	FFI_RETURN_INT (sc, pid);
	}

	static pointer
	do_wait_process (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	const char *name;
	pid_t pid;
	int hang;

	int retcode;

	FFI_ARG_OR_RETURN (sc, const char *, name, string, args);
	FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args);
	FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	err = gnupg_wait_process (name, pid, hang, &retcode);
	if (err == GPG_ERR_GENERAL)
	err = 0; /* Let the return code speak for itself. */

	FFI_RETURN_INT (sc, retcode);
	}


	static pointer
	do_wait_processes (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	pointer list_names;
	char **names;
	pointer list_pids;
	size_t i, count;
	pid_t *pids;
	int hang;
	int *retcodes;
	pointer retcodes_list = sc->NIL;

	FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args);
	FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args);
	FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	if (sc->vptr->list_length (sc, list_names)
	!= sc->vptr->list_length (sc, list_pids))
	return
	sc->vptr->mk_string (sc, "length of first two arguments must match");

	err = ffi_list2argv (sc, list_names, &names, &count);
	if (err == gpg_error (GPG_ERR_INV_VALUE))
	return ffi_sprintf (sc, "%lu%s element of first argument is "
	"neither string nor symbol",
	(unsigned long) count,
	ordinal_suffix ((int) count));
	if (err)
	FFI_RETURN_ERR (sc, err);

	err = ffi_list2intv (sc, list_pids, (int **) &pids, &count);
	if (err == gpg_error (GPG_ERR_INV_VALUE))
	return ffi_sprintf (sc, "%lu%s element of second argument is "
	"not a number",
	(unsigned long) count,
	ordinal_suffix ((int) count));
	if (err)
	FFI_RETURN_ERR (sc, err);

	retcodes = xtrycalloc (sizeof *retcodes, count);
	if (retcodes == NULL)
	{
	xfree (names);
	xfree (pids);
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	}

	err = gnupg_wait_processes ((const char **) names, pids, count, hang,
	retcodes);
	if (err == GPG_ERR_GENERAL)
	err = 0; /* Let the return codes speak. */
	if (err == GPG_ERR_TIMEOUT)
	err = 0; /* We may have got some results. */

	for (i = 0; i < count; i++)
	retcodes_list =
	(sc->vptr->cons) (sc,
	sc->vptr->mk_integer (sc,
	(long) retcodes[count-1-i]),
	retcodes_list);

	xfree (names);
	xfree (pids);
	xfree (retcodes);
	FFI_RETURN_POINTER (sc, retcodes_list);
	}


	static pointer
	do_pipe (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int filedes[2];
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	err = gnupg_create_pipe (filedes);
	#define IMC(A, B) \
	_cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
	FFI_RETURN_POINTER (sc, IMC (filedes[0],
	IMC (filedes[1], sc->NIL)));
	#undef IMC
	}

	static pointer
	do_inbound_pipe (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int filedes[2];
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	err = gnupg_create_inbound_pipe (filedes, NULL, 0);
	#define IMC(A, B) \
	_cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
	FFI_RETURN_POINTER (sc, IMC (filedes[0],
	IMC (filedes[1], sc->NIL)));
	#undef IMC
	}

	static pointer
	do_outbound_pipe (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int filedes[2];
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	err = gnupg_create_outbound_pipe (filedes, NULL, 0);
	#define IMC(A, B) \
	_cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
	FFI_RETURN_POINTER (sc, IMC (filedes[0],
	IMC (filedes[1], sc->NIL)));
	#undef IMC
	}



	/* Test helper functions. */
	static pointer
	do_file_equal (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	pointer result = sc->F;
	char a_name, b_name;
	int binary;
	const char *mode;
	FILE a_stream = NULL, b_stream = NULL;
	struct stat a_stat, b_stat;
	#define BUFFER_SIZE 1024
	char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE];
	#undef BUFFER_SIZE
	size_t chunk;

	FFI_ARG_OR_RETURN (sc, char *, a_name, string, args);
	FFI_ARG_OR_RETURN (sc, char *, b_name, string, args);
	FFI_ARG_OR_RETURN (sc, int, binary, bool, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	mode = binary ? "rb" : "r";
	a_stream = fopen (a_name, mode);
	if (a_stream == NULL)
	goto errout;

	b_stream = fopen (b_name, mode);
	if (b_stream == NULL)
	goto errout;

	if (fstat (fileno (a_stream), &a_stat) < 0)
	goto errout;

	if (fstat (fileno (b_stream), &b_stat) < 0)
	goto errout;

	if (binary && a_stat.st_size != b_stat.st_size)
	{
	if (verbose)
	fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n",
	a_name, b_name, (unsigned long) a_stat.st_size,
	(unsigned long) b_stat.st_size);

	goto out;
	}

	while (! feof (a_stream))
	{
	chunk = sizeof a_buf;

	chunk = fread (a_buf, 1, chunk, a_stream);
	if (chunk == 0 && ferror (a_stream))
	goto errout; /* some error */

	if (fread (b_buf, 1, chunk, b_stream) < chunk)
	{
	if (feof (b_stream))
	goto out; /* short read */
	goto errout; /* some error */
	}

	if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0)
	goto out;
	}

	fread (b_buf, 1, 1, b_stream);
	if (! feof (b_stream))
	goto out; /* b is longer */

	/* They match. */
	result = sc->T;

	out:
	if (a_stream)
	fclose (a_stream);
	if (b_stream)
	fclose (b_stream);
	FFI_RETURN_POINTER (sc, result);
	errout:
	err = gpg_error_from_syserror ();
	goto out;
	}

	static pointer
	do_splice (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int source;
	char buffer[1024];
	ssize_t bytes_read;
	pointer sinks, sink;
	FFI_ARG_OR_RETURN (sc, int, source, number, args);
	sinks = args;
	if (sinks == sc->NIL)
	return ffi_sprintf (sc, "need at least one sink");
	for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink), ffi_arg_index++)
	if (! sc->vptr->is_number (pair_car (sink)))
	return ffi_sprintf (sc, "%d%s argument is not a number",
	ffi_arg_index, ordinal_suffix (ffi_arg_index));

	while (1)
	{
	bytes_read = read (source, buffer, sizeof buffer);
	if (bytes_read == 0)
	break;
	if (bytes_read < 0)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());

	for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink))
	{
	int fd = sc->vptr->ivalue (pair_car (sink));
	char *p = buffer;
	ssize_t left = bytes_read;

	while (left)
	{
	ssize_t written = write (fd, p, left);
	if (written < 0)
	FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
	assert (written <= left);
	left -= written;
	p += written;
	}
	}
	}
	FFI_RETURN (sc);
	}

	static pointer
	do_string_index (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *haystack;
	char needle;
	ssize_t offset = 0;
	char *position;
	FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
	FFI_ARG_OR_RETURN (sc, char, needle, character, args);
	if (args != sc->NIL)
	{
	FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
	if (offset < 0)
	return ffi_sprintf (sc, "offset must be positive");
	if (offset > strlen (haystack))
	return ffi_sprintf (sc, "offset exceeds haystack");
	}
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	position = strchr (haystack+offset, needle);
	if (position)
	FFI_RETURN_INT (sc, position - haystack);
	else
	FFI_RETURN_POINTER (sc, sc->F);
	}

	static pointer
	do_string_rindex (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *haystack;
	char needle;
	ssize_t offset = 0;
	char *position;
	FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
	FFI_ARG_OR_RETURN (sc, char, needle, character, args);
	if (args != sc->NIL)
	{
	FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
	if (offset < 0)
	return ffi_sprintf (sc, "offset must be positive");
	if (offset > strlen (haystack))
	return ffi_sprintf (sc, "offset exceeds haystack");
	}
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	position = strrchr (haystack+offset, needle);
	if (position)
	FFI_RETURN_INT (sc, position - haystack);
	else
	FFI_RETURN_POINTER (sc, sc->F);
	}

	static pointer
	do_string_contains (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	char *haystack;
	char *needle;
	FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
	FFI_ARG_OR_RETURN (sc, char *, needle, string, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F);
	}



	static pointer
	do_get_verbose (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	FFI_ARGS_DONE_OR_RETURN (sc, args);
	FFI_RETURN_INT (sc, verbose);
	}

	static pointer
	do_set_verbose (scheme *sc, pointer args)
	{
	FFI_PROLOG ();
	int new_verbosity, old;
	FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args);
	FFI_ARGS_DONE_OR_RETURN (sc, args);

	old = verbose;
	verbose = new_verbosity;

	FFI_RETURN_INT (sc, old);
	}


	gpg_error_t
	ffi_list2argv (scheme sc, pointer list, char *argv, size_t len)
	{
	int i;

	*len = sc->vptr->list_length (sc, list);
	argv = xtrycalloc (len + 1, sizeof **argv);
	if (*argv == NULL)
	return gpg_error_from_syserror ();

	for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
	{
	if (sc->vptr->is_string (sc->vptr->pair_car (list)))
	(*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list));
	else if (sc->vptr->is_symbol (sc->vptr->pair_car (list)))
	(*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list));
	else
	{
	xfree (*argv);
	*argv = NULL;
	*len = i;
	return gpg_error (GPG_ERR_INV_VALUE);
	}
	}
	(*argv)[i] = NULL;
	return 0;
	}

	gpg_error_t
	ffi_list2intv (scheme sc, pointer list, int intv, size_t len)
	{
	int i;

	*len = sc->vptr->list_length (sc, list);
	intv = xtrycalloc (len, sizeof **intv);
	if (*intv == NULL)
	return gpg_error_from_syserror ();

	for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
	{
	if (sc->vptr->is_number (sc->vptr->pair_car (list)))
	(*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list));
	else
	{
	xfree (*intv);
	*intv = NULL;
	*len = i;
	return gpg_error (GPG_ERR_INV_VALUE);
	}
	}

	return 0;
	}


	char *
	ffi_schemify_name (const char *s, int macro)
	{
	/* Fixme: We should use xtrystrdup and return NULL. However, this
	* requires a lot more changes. Simply returning S as done
	* originally is not an option. */
	char n = xstrdup (s), p;
	/* if (n == NULL) */
	/* return s; */

	for (p = n; *p; p++)
	{
	p = (char) tolower (p);
	/* We convert _ to - in identifiers. We allow, however, for
	function names to start with a leading _. The functions in
	this namespace are not yet finalized and might change or
	vanish without warning. Use them with care. */
	if (! macro
	&& p != n
	&& *p == '_')
	*p = '-';
	}
	return n;
	}

	pointer
	ffi_sprintf (scheme sc, const char format, ...)
	{
	pointer result;
	va_list listp;
	char *expression;
	int size, written;

	va_start (listp, format);
	size = vsnprintf (NULL, 0, format, listp);
	va_end (listp);

	expression = xtrymalloc (size + 1);
	if (expression == NULL)
	return NULL;

	va_start (listp, format);
	written = vsnprintf (expression, size + 1, format, listp);
	va_end (listp);

	assert (size == written);

	result = sc->vptr->mk_string (sc, expression);
	xfree (expression);
	return result;
	}

	void
	ffi_scheme_eval (scheme sc, const char format, ...)
	{
	va_list listp;
	char *expression;
	int size, written;

	va_start (listp, format);
	size = vsnprintf (NULL, 0, format, listp);
	va_end (listp);

	expression = xtrymalloc (size + 1);
	if (expression == NULL)
	return;

	va_start (listp, format);
	written = vsnprintf (expression, size + 1, format, listp);
	va_end (listp);

	assert (size == written);

	sc->vptr->load_string (sc, expression);
	xfree (expression);
	}

	gpg_error_t
	ffi_init (scheme sc, const char argv0, const char *scriptname,
	int argc, const char **argv)
	{
	int i;
	pointer args = sc->NIL;

	/* bitwise arithmetic */
	ffi_define_function (sc, logand);
	ffi_define_function (sc, logior);
	ffi_define_function (sc, logxor);
	ffi_define_function (sc, lognot);

	/* libc. */
	ffi_define_constant (sc, O_RDONLY);
	ffi_define_constant (sc, O_WRONLY);
	ffi_define_constant (sc, O_RDWR);
	ffi_define_constant (sc, O_CREAT);
	ffi_define_constant (sc, O_APPEND);
	#ifndef O_BINARY
	# define O_BINARY 0
	#endif
	#ifndef O_TEXT
	# define O_TEXT 0
	#endif
	ffi_define_constant (sc, O_BINARY);
	ffi_define_constant (sc, O_TEXT);
	ffi_define_constant (sc, STDIN_FILENO);
	ffi_define_constant (sc, STDOUT_FILENO);
	ffi_define_constant (sc, STDERR_FILENO);
	ffi_define_constant (sc, SEEK_SET);
	ffi_define_constant (sc, SEEK_CUR);
	ffi_define_constant (sc, SEEK_END);

	ffi_define_function (sc, sleep);
	ffi_define_function (sc, usleep);
	ffi_define_function (sc, chdir);
	ffi_define_function (sc, strerror);
	ffi_define_function (sc, getenv);
	ffi_define_function (sc, setenv);
	ffi_define_function_name (sc, "_exit", exit);
	ffi_define_function (sc, open);
	ffi_define_function (sc, fdopen);
	ffi_define_function (sc, close);
	ffi_define_function (sc, seek);
	ffi_define_function (sc, get_temp_path);
	ffi_define_function_name (sc, "_mkdtemp", mkdtemp);
	ffi_define_function (sc, unlink);
	ffi_define_function (sc, unlink_recursively);
	ffi_define_function (sc, rename);
	ffi_define_function (sc, getcwd);
	ffi_define_function (sc, mkdir);
	ffi_define_function (sc, rmdir);
	ffi_define_function (sc, get_isotime);
	ffi_define_function (sc, get_time);
	ffi_define_function (sc, getpid);

	/* Random numbers. */
	ffi_define_function (sc, srandom);
	ffi_define_function (sc, random);
	ffi_define_function (sc, make_random_string);

	/* Process management. */
	ffi_define_function (sc, spawn_process);
	ffi_define_function (sc, spawn_process_fd);
	ffi_define_function (sc, wait_process);
	ffi_define_function (sc, wait_processes);
	ffi_define_function (sc, pipe);
	ffi_define_function (sc, inbound_pipe);
	ffi_define_function (sc, outbound_pipe);

	/* estream functions. */
	ffi_define_function_name (sc, "es-fclose", es_fclose);
	ffi_define_function_name (sc, "es-read", es_read);
	ffi_define_function_name (sc, "es-feof", es_feof);
	ffi_define_function_name (sc, "es-write", es_write);

	/* Test helper functions. */
	ffi_define_function (sc, file_equal);
	ffi_define_function (sc, splice);
	ffi_define_function (sc, string_index);
	ffi_define_function (sc, string_rindex);
	ffi_define_function_name (sc, "string-contains?", string_contains);

	/* User interface. */
	ffi_define_function (sc, flush_stdio);
	ffi_define_function (sc, prompt);

	/* Configuration. */
	ffi_define_function_name (sc, "verbose", get_verbose);
	ffi_define_function_name (sc, "set-verbose!", set_verbose);

	ffi_define (sc, "argv0", sc->vptr->mk_string (sc, argv0));
	ffi_define (sc, "scriptname", sc->vptr->mk_string (sc, scriptname));
	for (i = argc - 1; i >= 0; i--)
	{
	pointer value = sc->vptr->mk_string (sc, argv[i]);
	args = (sc->vptr->cons) (sc, value, args);
	}
	ffi_define (sc, "args", args);

	#if _WIN32
	ffi_define (sc, "pathsep", sc->vptr->mk_character (sc, ';'));
	#else
	ffi_define (sc, "pathsep", sc->vptr->mk_character (sc, ':'));
	#endif

	ffi_define (sc, "win32",
	#if _WIN32
	sc->T
	#else
	sc->F
	#endif
	);

	ffi_define (sc, "maintainer-mode",
	#if MAINTAINER_MODE
	sc->T
	#else
	sc->F
	#endif
	);

	ffi_define (sc, "run-all-tests",
	#if RUN_ALL_TESTS
	sc->T
	#else
	sc->F
	#endif
	);


	ffi_define (sc, "stdin",
	sc->vptr->mk_port_from_file (sc, stdin, port_input));
	ffi_define (sc, "stdout",
	sc->vptr->mk_port_from_file (sc, stdout, port_output));
	ffi_define (sc, "stderr",
	sc->vptr->mk_port_from_file (sc, stderr, port_output));

	return 0;
	}

File Metadata

Mime Type: text/x-c
Expires: Tue, Feb 3, 11:36 PM (1 d, 5 h)
Storage Engine: local-disk
Storage Format: Raw Data
Storage Handle: 6a/5d/b6d042d749f79c9152308657b297

ffi.cNo OneTemporaryActions

ffi.cView Options

File Metadata

Event Timeline

ffi.c
No OneTemporary
Actions

ffi.c
View Options