Adding upstream version 2.2.40.upstream/2.2.40

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 1470 insertions, 0 deletions

diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c
new file mode 100644
index 0000000..dde5b52
--- /dev/null
+++ b/tests/gpgscm/ffi.c
@@ -0,0 +1,1470 @@
+/* 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"
+
+#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;
+}