tests/gpgscm: Add a TinySCHEME-based test driver.
authorJustus Winter <justus@g10code.com>
Wed, 6 Jan 2016 10:55:25 +0000 (11:55 +0100)
committerJustus Winter <justus@g10code.com>
Fri, 17 Jun 2016 09:57:12 +0000 (11:57 +0200)
* configure.ac: Add new component.
* tests/Makefile.am: Likewise.
* tests/gpgscm/Makefile.am: New file.
* tests/gpgscm/ffi-private.h: Likewise.
* tests/gpgscm/ffi.c: Likewise.
* tests/gpgscm/ffi.h: Likewise.
* tests/gpgscm/ffi.scm: Likewise.
* tests/gpgscm/lib.scm: Likewise.
* tests/gpgscm/main.c: Likewise.
* tests/gpgscm/private.h: Likewise.
* tests/gpgscm/repl.scm: Likewise.
* tests/gpgscm/scheme-config.h: Likewise.
* tests/gpgscm/t-child.c: Likewise.
* tests/gpgscm/t-child.scm: Likewise.
* tests/gpgscm/tests.scm: Likewise.

Signed-off-by: Justus Winter <justus@g10code.com>
15 files changed:
configure.ac
tests/Makefile.am
tests/gpgscm/Makefile.am [new file with mode: 0644]
tests/gpgscm/ffi-private.h [new file with mode: 0644]
tests/gpgscm/ffi.c [new file with mode: 0644]
tests/gpgscm/ffi.h [new file with mode: 0644]
tests/gpgscm/ffi.scm [new file with mode: 0644]
tests/gpgscm/lib.scm [new file with mode: 0644]
tests/gpgscm/main.c [new file with mode: 0644]
tests/gpgscm/private.h [new file with mode: 0644]
tests/gpgscm/repl.scm [new file with mode: 0644]
tests/gpgscm/scheme-config.h [new file with mode: 0644]
tests/gpgscm/t-child.c [new file with mode: 0644]
tests/gpgscm/t-child.scm [new file with mode: 0644]
tests/gpgscm/tests.scm [new file with mode: 0644]

index 9f3aeb3..bb925c5 100644 (file)
@@ -1903,6 +1903,7 @@ tools/gpg-zip
 tools/Makefile
 doc/Makefile
 tests/Makefile
+tests/gpgscm/Makefile
 tests/openpgp/Makefile
 tests/pkits/Makefile
 g10/gpg.w32-manifest
index 307d829..e49c283 100644 (file)
@@ -25,7 +25,7 @@ else
 openpgp =
 endif
 
-SUBDIRS = ${openpgp} . pkits
+SUBDIRS = gpgscm ${openpgp} . pkits
 
 GPGSM = ../sm/gpgsm
 
diff --git a/tests/gpgscm/Makefile.am b/tests/gpgscm/Makefile.am
new file mode 100644 (file)
index 0000000..1fb9647
--- /dev/null
@@ -0,0 +1,57 @@
+# TinyScheme-based test driver.
+#
+# 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 <http://www.gnu.org/licenses/>.
+
+EXTRA_DIST = \
+       COPYING \
+       Manual.txt \
+       ffi.scm \
+       init.scm \
+       lib.scm \
+       t-child.scm \
+       tests.scm
+
+AM_CPPFLAGS = -I$(top_srcdir)/common
+include $(top_srcdir)/am/cmacros.am
+
+AM_CFLAGS =
+
+bin_PROGRAMS = gpgscm
+noinst_PROGRAMS = t-child
+
+common_libs = ../$(libcommon)
+commonpth_libs = ../$(libcommonpth)
+
+gpgscm_CFLAGS = -imacros scheme-config.h \
+       $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS)
+gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \
+       scheme-config.h opdefines.h scheme.c scheme.h scheme-private.h
+gpgscm_LDADD = $(LDADD) $(common_libs) \
+       $(NETLIBS) $(LIBICONV) $(LIBREADLINE) \
+       $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS)
+
+t_child_SOURCES = t-child.c
+
+# Make sure that all libs are build before we use them.  This is
+# important for things like make -j2.
+$(PROGRAMS): $(common_libs)
+
+.PHONY: check
+check: gpgscm$(EXEEXT) t-child$(EXEEXT)
+       EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \
+               ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm
diff --git a/tests/gpgscm/ffi-private.h b/tests/gpgscm/ffi-private.h
new file mode 100644 (file)
index 0000000..5467dac
--- /dev/null
@@ -0,0 +1,132 @@
+/* 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 <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef GPGSCM_FFI_PRIVATE_H
+#define GPGSCM_FFI_PRIVATE_H
+
+#include <gpg-error.h>
+#include "scheme.h"
+#include "scheme-private.h"
+
+#define FFI_PROLOG()                                           \
+  unsigned int ffi_arg_index GPGRT_ATTR_UNUSED = 1;            \
+  int err GPGRT_ATTR_UNUSED = 0                                        \
+
+int ffi_bool_value (scheme *sc, pointer p);
+
+#define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X)
+#define CONVERSION_string(SC, X) (SC)->vptr->string_value (X)
+#define CONVERSION_list(SC, X) (X)
+#define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X))
+#define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X)       \
+                                 ? (SC)->vptr->string_value      \
+                                 : (SC)->vptr->symname) (X))
+
+#define IS_A_number(SC, X)     (SC)->vptr->is_number (X)
+#define IS_A_string(SC, X)     (SC)->vptr->is_string (X)
+#define IS_A_list(SC, X)       (SC)->vptr->is_list ((SC), X)
+#define IS_A_bool(SC, X)       ((X) == (SC)->F || (X) == (SC)->T)
+#define IS_A_path(SC, X)       ((SC)->vptr->is_string (X)      \
+                                || (SC)->vptr->is_symbol (X))
+
+#define FFI_ARG_OR_RETURN(SC, CTYPE, TARGET, WANT, ARGS)               \
+  do {                                                                 \
+  if ((ARGS) == (SC)->NIL)                                             \
+    return (SC)->vptr->mk_string ((SC),                                        \
+                                 "too few arguments: want "            \
+                                 #TARGET "("#WANT"/"#CTYPE")\n");      \
+  if (! IS_A_##WANT ((SC), pair_car (ARGS))) {                         \
+    char ffi_error_message[256];                                       \
+    snprintf (ffi_error_message, sizeof ffi_error_message,             \
+             "argument %d must be: " #WANT "\n", ffi_arg_index);       \
+    return  (SC)->vptr->mk_string ((SC), ffi_error_message);           \
+  }                                                                    \
+  TARGET = CONVERSION_##WANT (SC, pair_car (ARGS));                    \
+  ARGS = pair_cdr (ARGS);                                              \
+  ffi_arg_index += 1;                                                  \
+  } while (0)
+
+#define FFI_ARGS_DONE_OR_RETURN(SC, ARGS)                               \
+  do {                                                                 \
+  if ((ARGS) != (SC)->NIL)                                             \
+    return (SC)->vptr->mk_string ((SC), "too many arguments");         \
+  } while (0)
+
+#define FFI_RETURN_ERR(SC, ERR)                                        \
+  return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1)
+
+#define FFI_RETURN(SC) FFI_RETURN_ERR (SC, err)
+
+#define FFI_RETURN_POINTER(SC, X)                                      \
+  return _cons ((SC), mk_integer ((SC), err),                          \
+               _cons ((SC), (X), (SC)->NIL, 1), 1)
+#define FFI_RETURN_INT(SC, X)                                          \
+  FFI_RETURN_POINTER ((SC), mk_integer ((SC), (X)))
+#define FFI_RETURN_STRING(SC, X)                       \
+  FFI_RETURN_POINTER ((SC), mk_string ((SC), (X)))
+
+const char *ffi_schemify_name (const char *s, int macro);
+
+void ffi_scheme_eval (scheme *sc, const char *format, ...)
+  GPGRT_ATTR_PRINTF (2, 3);
+pointer ffi_sprintf (scheme *sc, const char *format, ...)
+  GPGRT_ATTR_PRINTF (2, 3);
+
+#define ffi_define_function_name(SC, NAME, F)                          \
+  do {                                                                 \
+    scheme_define ((SC),                                               \
+                  (SC)->global_env,                                    \
+                  mk_symbol ((SC), ffi_schemify_name ("_" #F, 0)),     \
+                  mk_foreign_func ((SC), (do_##F)));                   \
+    ffi_scheme_eval ((SC),                                             \
+                    "(define (%s . a) (ffi-apply \"%s\" %s a))",       \
+                    (NAME), (NAME), ffi_schemify_name ("_" #F, 0));    \
+  } while (0)
+
+#define ffi_define_function(SC, F)                             \
+  ffi_define_function_name ((SC), ffi_schemify_name (#F, 0), F)
+
+#define ffi_define_constant(SC, C)                                     \
+  scheme_define ((SC),                                                 \
+                (SC)->global_env,                                      \
+                mk_symbol ((SC), ffi_schemify_name (#C, 1)),           \
+                mk_integer ((SC), (C)))
+
+#define ffi_define(SC, SYM, EXP)                                       \
+  scheme_define ((SC), (SC)->global_env, mk_symbol ((SC), (SYM)), EXP)
+
+#define ffi_define_variable_pointer(SC, C, P)                          \
+  scheme_define ((SC),                                                 \
+                (SC)->global_env,                                      \
+                mk_symbol ((SC), ffi_schemify_name (#C, 0)),           \
+                (P))
+
+#define ffi_define_variable_integer(SC, C)                             \
+  ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_integer ((SC), C))
+
+#define ffi_define_variable_string(SC, C)                              \
+  ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_string ((SC), C ?: ""))
+
+gpg_error_t ffi_list2argv (scheme *sc, pointer list,
+                          char ***argv, size_t *len);
+gpg_error_t ffi_list2intv (scheme *sc, pointer list,
+                          int **intv, size_t *len);
+
+#endif /* GPGSCM_FFI_PRIVATE_H */
diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c
new file mode 100644 (file)
index 0000000..babf1e1
--- /dev/null
@@ -0,0 +1,1167 @@
+/* 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 <http://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 <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
+#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"
+
+\f
+
+int
+ffi_bool_value (scheme *sc, pointer p)
+{
+  return ! (p == sc->F);
+}
+
+
+\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);
+}
+\f
+/* 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);
+}
+\f
+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;
+  FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+  FFI_ARGS_DONE_OR_RETURN (sc, args);
+  FFI_RETURN_STRING (sc, getenv (name) ?: "");
+}
+
+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);
+  FFI_RETURN_ERR (sc, gnupg_setenv (name, value, overwrite));
+}
+
+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_mkdtemp (scheme *sc, pointer args)
+{
+  FFI_PROLOG ();
+  char *template;
+  char buffer[128];
+  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);
+
+  FFI_RETURN_STRING (sc, gnupg_mkdtemp (buffer));
+}
+
+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);
+}
+
+\f
+
+/* 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);
+}
+
+\f
+
+/* 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],
+                             GPG_ERR_SOURCE_DEFAULT,
+                             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, "%luth element of first argument is "
+                        "neither string nor symbol",
+                        (unsigned long) 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, "%luth element of second argument is "
+                        "neither string nor symbol",
+                        (unsigned long) 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.  */
+
+  for (i = 0; i < count; i++)
+    retcodes_list =
+      (sc->vptr->cons) (sc,
+                        sc->vptr->mk_integer (sc,
+                                              (long) retcodes[count-1-i]),
+                        retcodes_list);
+
+  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
+}
+
+\f
+
+/* 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;
+  int sink;
+  ssize_t len = -1;
+  char buffer[1024];
+  ssize_t bytes_read;
+  FFI_ARG_OR_RETURN (sc, int, source, number, args);
+  FFI_ARG_OR_RETURN (sc, int, sink, number, args);
+  if (args != sc->NIL)
+    FFI_ARG_OR_RETURN (sc, ssize_t, len, number, args);
+  FFI_ARGS_DONE_OR_RETURN (sc, args);
+  while (len == -1 || len > 0)
+    {
+      size_t want = sizeof buffer;
+      if (len > 0 && (ssize_t) want > len)
+        want = (size_t) len;
+
+      bytes_read = read (source, buffer, want);
+      if (bytes_read == 0)
+        break;
+      if (bytes_read < 0)
+        FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+      if (write (sink, buffer, bytes_read) != bytes_read)
+        FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+      if (len != -1)
+        len -= bytes_read;
+    }
+  FFI_RETURN (sc);
+}
+
+\f
+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;
+}
+
+\f
+const char *
+ffi_schemify_name (const char *s, int macro)
+{
+  char *n = strdup (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, 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_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 (sc, exit);
+  ffi_define_function (sc, open);
+  ffi_define_function (sc, fdopen);
+  ffi_define_function (sc, close);
+  ffi_define_function (sc, 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);
+
+  /* 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);
+
+  /* User interface.  */
+  ffi_define_function (sc, flush_stdio);
+  ffi_define_function (sc, prompt);
+
+  /* Configuration.  */
+  ffi_define (sc, "*verbose*", sc->vptr->mk_integer (sc, verbose));
+
+  ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0));
+  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, "*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;
+}
diff --git a/tests/gpgscm/ffi.h b/tests/gpgscm/ffi.h
new file mode 100644 (file)
index 0000000..02dd99d
--- /dev/null
@@ -0,0 +1,30 @@
+/* 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 <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef GPGSCM_FFI_H
+#define GPGSCM_FFI_H
+
+#include <gpg-error.h>
+#include "scheme.h"
+
+gpg_error_t ffi_init (scheme *sc, const char *argv0,
+                     int argc, const char **argv);
+
+#endif /* GPGSCM_FFI_H */
diff --git a/tests/gpgscm/ffi.scm b/tests/gpgscm/ffi.scm
new file mode 100644 (file)
index 0000000..d0b8a99
--- /dev/null
@@ -0,0 +1,40 @@
+;; 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 <http://www.gnu.org/licenses/>.
+
+;; Foreign function wrapper.  Expects F to return a list with the
+;; first element being the `error_t' value returned by the foreign
+;; function.  The error is thrown, or the cdr of the result is
+;; returned.
+(define (ffi-apply name f args)
+  (let ((result (apply f args)))
+    (cond
+     ((string? result)
+      (ffi-fail name args result))
+     ((not (= (car result) 0))
+      (ffi-fail name args (strerror (car result))))
+     ((and (= (car result) 0) (pair? (cdr result))) (cadr result))
+     ((= (car result) 0) '())
+     (else
+      (throw (list "Result violates FFI calling convention: " result))))))
+
+(define (ffi-fail name args message)
+  (let ((args' (open-output-string)))
+    (write (cons (string->symbol name) args) args')
+    (throw (string-append
+           (get-output-string args') ": " message))))
diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm
new file mode 100644 (file)
index 0000000..871cc8f
--- /dev/null
@@ -0,0 +1,163 @@
+;; Additional library functions 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 <http://www.gnu.org/licenses/>.
+
+(macro (assert form)
+  `(if (not ,(cadr form))
+       (begin
+        (display (list "Assertion failed:" (quote ,(cadr form))))
+        (newline)
+        (exit 1))))
+(assert #t)
+
+(define (filter pred lst)
+  (cond ((null? lst) '())
+        ((pred (car lst))
+         (cons (car lst) (filter pred (cdr lst))))
+        (else (filter pred (cdr lst)))))
+
+(define (any p l)
+  (cond ((null? l) #f)
+        ((p (car l)) #t)
+        (else (any p (cdr l)))))
+
+(define (all p l)
+  (cond ((null? l) #t)
+        ((not (p (car l))) #f)
+        (else (all p (cdr l)))))
+
+;; Is PREFIX a prefix of S?
+(define (string-prefix? s prefix)
+  (and (>= (string-length s) (string-length prefix))
+       (string=? prefix (substring s 0 (string-length prefix)))))
+(assert (string-prefix? "Scheme" "Sch"))
+
+;; Is SUFFIX a suffix of S?
+(define (string-suffix? s suffix)
+  (and (>= (string-length s) (string-length suffix))
+       (string=? suffix (substring s (- (string-length s)
+                                       (string-length suffix))
+                                  (string-length s)))))
+(assert (string-suffix? "Scheme" "eme"))
+
+;; Locate the first occurrence of needle in haystack.
+(define (string-index haystack needle)
+  (define (index i haystack needle)
+    (if (= (length haystack) 0)
+        #f
+        (if (char=? (car haystack) needle)
+            i
+            (index (+ i 1) (cdr haystack) needle))))
+  (index 0 (string->list haystack) needle))
+
+;; Locate the last occurrence of needle in haystack.
+(define (string-rindex haystack needle)
+  (let ((rindex (string-index (list->string (reverse (string->list haystack)))
+                             needle)))
+    (if rindex (- (string-length haystack) rindex 1) #f)))
+
+;; Split haystack at delimiter at most n times.
+(define (string-splitn haystack delimiter n)
+  (define (split acc haystack delimiter n)
+    (if (= (string-length haystack) 0)
+        (reverse acc)
+        (let ((i (string-index haystack delimiter)))
+          (if (not (or (eq? i #f) (= 0 n)))
+              (split (cons (substring haystack 0 i) acc)
+                     (substring haystack (+ i 1) (string-length haystack))
+                     delimiter (- n 1))
+              (split (cons haystack acc) "" delimiter 0)
+              ))))
+  (split '() haystack delimiter n))
+
+;; Split haystack at delimiter.
+(define (string-split haystack delimiter)
+  (string-splitn haystack delimiter -1))
+
+;; Trim the prefix of S containing only characters that make PREDICATE
+;; true.  For example (string-ltrim char-whitespace? "  foo") =>
+;; "foo".
+(define (string-ltrim predicate s)
+  (let loop ((s' (string->list s)))
+    (if (predicate (car s'))
+       (loop (cdr s'))
+       (list->string s'))))
+
+;; Trim the suffix of S containing only characters that make PREDICATE
+;; true.
+(define (string-rtrim predicate s)
+  (let loop ((s' (reverse (string->list s))))
+    (if (predicate (car s'))
+       (loop (cdr s'))
+       (list->string (reverse s')))))
+
+;; Trim both the prefix and suffix of S containing only characters
+;; that make PREDICATE true.
+(define (string-trim predicate s)
+  (string-ltrim predicate (string-rtrim predicate s)))
+
+(define (string-contains? s contained)
+  (let loop ((offset 0))
+    (if (<= (+ offset (string-length contained)) (string-length s))
+       (if (string=? (substring s offset (+ offset (string-length contained)))
+                     contained)
+           #t
+           (loop (+ 1 offset)))
+       #f)))
+
+(define (echo . msg)
+  (for-each (lambda (x) (display x) (display " ")) msg)
+  (newline))
+
+;; Read a word from port P.
+(define (read-word . p)
+  (list->string
+   (let f ()
+     (let ((c (apply peek-char p)))
+       (cond
+       ((eof-object? c) '())
+       ((char-alphabetic? c)
+        (apply read-char p)
+        (cons c (f)))
+       (else
+        (apply read-char p)
+        '()))))))
+
+;; Read a line from port P.
+(define (read-line . p)
+  (list->string
+   (let f ()
+     (let ((c (apply peek-char p)))
+       (cond
+       ((eof-object? c) '())
+       ((char=? c #\newline)
+        (apply read-char p)
+        '())
+       (else
+        (apply read-char p)
+        (cons c (f))))))))
+
+;; Read everything from port P.
+(define (read-all . p)
+  (list->string
+   (let f ()
+     (let ((c (apply peek-char p)))
+       (cond
+       ((eof-object? c) '())
+       (else (apply read-char p)
+        (cons c (f))))))))
diff --git a/tests/gpgscm/main.c b/tests/gpgscm/main.c
new file mode 100644 (file)
index 0000000..3414e3d
--- /dev/null
@@ -0,0 +1,286 @@
+/* TinyScheme-based test driver.
+ *
+ * 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 <http://www.gnu.org/licenses/>.
+ */
+
+#include <config.h>
+
+#include <assert.h>
+#include <ctype.h>
+#include <errno.h>
+#include <gcrypt.h>
+#include <gpg-error.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <unistd.h>
+
+#include "private.h"
+#include "scheme.h"
+#include "ffi.h"
+#include "i18n.h"
+#include "../../common/argparse.h"
+#include "../../common/init.h"
+#include "../../common/logging.h"
+#include "../../common/strlist.h"
+#include "../../common/sysutils.h"
+
+/* The TinyScheme banner.  Unfortunately, it isn't in the header
+   file.  */
+#define ts_banner "TinyScheme 1.41"
+
+int verbose;
+
+\f
+
+/* Constants to identify the commands and options. */
+enum cmd_and_opt_values
+  {
+    aNull      = 0,
+    oVerbose   = 'v',
+  };
+
+/* The list of commands and options. */
+static ARGPARSE_OPTS opts[] =
+  {
+    ARGPARSE_s_n (oVerbose, "verbose", N_("verbose")),
+    ARGPARSE_end (),
+  };
+
+char *scmpath = "";
+size_t scmpath_len = 0;
+
+/* Command line parsing.  */
+static void
+parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts)
+{
+  int no_more_options = 0;
+
+  while (!no_more_options && optfile_parse (NULL, NULL, NULL, pargs, popts))
+    {
+      switch (pargs->r_opt)
+        {
+        case oVerbose:
+          verbose++;
+          break;
+
+        default:
+         pargs->err = 2;
+         break;
+       }
+    }
+}
+
+/* Print usage information and and provide strings for help. */
+static const char *
+my_strusage( int level )
+{
+  const char *p;
+
+  switch (level)
+    {
+    case 11: p = "gpgscm (@GNUPG@)";
+      break;
+    case 13: p = VERSION; break;
+    case 17: p = PRINTABLE_OS_NAME; break;
+    case 19: p = _("Please report bugs to <@EMAIL@>.\n"); break;
+
+    case 1:
+    case 40:
+      p = _("Usage: gpgscm [options] [file] (-h for help)");
+      break;
+    case 41:
+      p = _("Syntax: gpgscm [options] [file]\n"
+            "Execute the given Scheme program, or spawn interactive shell.\n");
+      break;
+
+    default: p = NULL; break;
+    }
+  return p;
+}
+
+\f
+/* Load the Scheme program from FILE_NAME.  If FILE_NAME is not an
+   absolute path, and LOOKUP_IN_PATH is given, then it is qualified
+   with the values in scmpath until the file is found.  */
+static gpg_error_t
+load (scheme *sc, char *file_name,
+      int lookup_in_cwd, int lookup_in_path)
+{
+  gpg_error_t err = 0;
+  size_t n;
+  const char *directory;
+  char *qualified_name = file_name;
+  int use_path;
+  FILE *h = NULL;
+
+  use_path =
+    lookup_in_path && ! (file_name[0] == '/' || scmpath_len == 0);
+
+  if (file_name[0] == '/' || lookup_in_cwd || scmpath_len == 0)
+    {
+      h = fopen (file_name, "r");
+      if (! h)
+        err = gpg_error_from_syserror ();
+    }
+
+  if (h == NULL && use_path)
+    for (directory = scmpath, n = scmpath_len; n;
+         directory += strlen (directory) + 1, n--)
+      {
+        if (asprintf (&qualified_name, "%s/%s", directory, file_name) < 0)
+          return gpg_error_from_syserror ();
+
+        h = fopen (qualified_name, "r");
+        if (h)
+          break;
+
+        if (n > 1)
+          {
+            free (qualified_name);
+            continue;  /* Try again!  */
+          }
+
+        err = gpg_error_from_syserror ();
+      }
+
+  if (h == NULL)
+    {
+      /* Failed and no more elements in scmpath to try.  */
+      fprintf (stderr, "Could not read %s: %s.\n",
+               qualified_name, gpg_strerror (err));
+      if (lookup_in_path)
+        fprintf (stderr,
+                 "Consider using GPGSCM_PATH to specify the location "
+                 "of the Scheme library.\n");
+      return err;
+    }
+  if (verbose > 1)
+    fprintf (stderr, "Loading %s...\n", qualified_name);
+  scheme_load_named_file (sc, h, qualified_name);
+  fclose (h);
+
+  if (file_name != qualified_name)
+    free (qualified_name);
+  return 0;
+}
+
+\f
+
+int
+main (int argc, char **argv)
+{
+  gpg_error_t err;
+  char *argv0;
+  ARGPARSE_ARGS pargs;
+  scheme *sc;
+  char *p;
+#if _WIN32
+  char pathsep = ';';
+#else
+  char pathsep = ':';
+#endif
+  char *script = NULL;
+
+  /* Save argv[0] so that we can re-exec.  */
+  argv0 = argv[0];
+
+  /* Parse path.  */
+  if (getenv ("GPGSCM_PATH"))
+    scmpath = getenv ("GPGSCM_PATH");
+
+  p = scmpath = strdup (scmpath);
+  if (p == NULL)
+    return 2;
+
+  if (*p)
+    scmpath_len++;
+  for (; *p; p++)
+    if (*p == pathsep)
+      *p = 0, scmpath_len++;
+
+  set_strusage (my_strusage);
+  log_set_prefix ("gpgscm", 1);
+
+  /* Make sure that our subsystems are ready.  */
+  i18n_init ();
+  init_common_subsystems (&argc, &argv);
+
+  if (!gcry_check_version (GCRYPT_VERSION))
+    {
+      fputs ("libgcrypt version mismatch\n", stderr);
+      exit (2);
+    }
+
+  /* Parse the command line. */
+  pargs.argc  = &argc;
+  pargs.argv  = &argv;
+  pargs.flags = 0;
+  parse_arguments (&pargs, opts);
+
+  if (log_get_errorcount (0))
+    exit (2);
+
+  sc = scheme_init_new ();
+  if (! sc) {
+    fprintf (stderr, "Could not initialize TinyScheme!\n");
+    return 2;
+  }
+  scheme_set_input_port_file (sc, stdin);
+  scheme_set_output_port_file (sc, stderr);
+
+  if (argc)
+    {
+      script = argv[0];
+      argc--, argv++;
+    }
+
+  err = load (sc, "init.scm", 0, 1);
+  if (! err)
+    err = load (sc, "ffi.scm", 0, 1);
+  if (! err)
+    err = ffi_init (sc, argv0, argc, (const char **) argv);
+  if (! err)
+    err = load (sc, "lib.scm", 0, 1);
+  if (! err)
+    err = load (sc, "repl.scm", 0, 1);
+  if (! err)
+    err = load (sc, "tests.scm", 0, 1);
+  if (err)
+    {
+      fprintf (stderr, "Error initializing gpgscm: %s.\n",
+               gpg_strerror (err));
+      exit (2);
+    }
+
+  if (script == NULL)
+    {
+      /* Interactive shell.  */
+      fprintf (stderr, "gpgscm/"ts_banner".\n");
+      scheme_load_string (sc, "(interactive-repl)");
+    }
+  else
+    {
+      err = load (sc, script, 1, 1);
+      if (err)
+        log_fatal ("%s: %s", script, gpg_strerror (err));
+    }
+
+  scheme_deinit (sc);
+  return EXIT_SUCCESS;
+}
diff --git a/tests/gpgscm/private.h b/tests/gpgscm/private.h
new file mode 100644 (file)
index 0000000..efa0cb0
--- /dev/null
@@ -0,0 +1,26 @@
+/* TinyScheme-based test driver.
+ *
+ * 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 <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef __GPGSCM_PRIVATE_H__
+#define __GPGSCM_PRIVATE_H__
+
+extern int verbose;
+
+#endif /* __GPGSCM_PRIVATE_H__ */
diff --git a/tests/gpgscm/repl.scm b/tests/gpgscm/repl.scm
new file mode 100644 (file)
index 0000000..896554f
--- /dev/null
@@ -0,0 +1,50 @@
+;; A read-evaluate-print-loop for gpgscm.
+;;
+;; 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 <http://www.gnu.org/licenses/>.
+
+;; Interactive repl using 'prompt' function.  P must be a function
+;; that given the current entered prefix returns the prompt to
+;; display.
+(define (repl p)
+  (let ((repl-environment (make-environment)))
+    (call/cc
+     (lambda (exit)
+       (let loop ((prefix ""))
+        (let ((line (prompt (p prefix))))
+          (if (and (not (eof-object? line)) (= 0 (string-length line)))
+              (exit (loop prefix)))
+          (if (not (eof-object? line))
+              (let* ((next (string-append prefix line))
+                     (c (catch (begin (echo "Parse error:" *error*)
+                                      (loop prefix))
+                               (read (open-input-string next)))))
+                (if (not (eof-object? c))
+                    (begin
+                      (catch (echo "Error:" *error*)
+                             (echo "    ===>" (eval c repl-environment)))
+                      (exit (loop ""))))
+                (exit (loop next))))))))))
+
+(define (prompt-append-prefix prompt prefix)
+  (string-append prompt (if (> (string-length prefix) 0)
+                           (string-append prefix "...")
+                           "> ")))
+
+;; Default repl run by main.c.
+(define (interactive-repl)
+  (repl (lambda (p) (prompt-append-prefix "gpgscm " p))))
diff --git a/tests/gpgscm/scheme-config.h b/tests/gpgscm/scheme-config.h
new file mode 100644 (file)
index 0000000..fe3d746
--- /dev/null
@@ -0,0 +1,36 @@
+/* TinyScheme configuration.
+ *
+ * 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 <http://www.gnu.org/licenses/>.
+ */
+
+#define STANDALONE             0
+#define USE_MATH               0
+#define USE_CHAR_CLASSIFIERS   1
+#define USE_ASCII_NAMES                1
+#define USE_STRING_PORTS       1
+#define USE_ERROR_HOOK         1
+#define USE_TRACING            1
+#define USE_COLON_HOOK         1
+#define USE_DL                 0
+#define USE_PLIST              0
+#define USE_INTERFACE          1
+#define SHOW_ERROR_LINE                1
+
+#if __MINGW32__
+# define USE_STRLWR 0
+#endif /* __MINGW32__ */
diff --git a/tests/gpgscm/t-child.c b/tests/gpgscm/t-child.c
new file mode 100644 (file)
index 0000000..fe2e7b4
--- /dev/null
@@ -0,0 +1,66 @@
+/* Sanity check for the process and IPC primitives.
+ *
+ * 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 <http://www.gnu.org/licenses/>.
+ */
+
+#include <errno.h>
+#include <stdio.h>
+#include <string.h>
+
+#ifdef _WIN32
+# include <fcntl.h>
+# include <io.h>
+#endif
+
+int
+main (int argc, char **argv)
+{
+#if _WIN32
+  if (! setmode (stdin, O_BINARY))
+    return 23;
+  if (! setmode (stdout, O_BINARY))
+    return 23;
+#endif
+
+  if (argc == 1)
+    return 2;
+  else if (strcmp (argv[1], "return0") == 0)
+    return 0;
+  else if (strcmp (argv[1], "return1") == 0)
+    return 1;
+  else if (strcmp (argv[1], "return77") == 0)
+    return 77;
+  else if (strcmp (argv[1], "hello_stdout") == 0)
+    fprintf (stdout, "hello");
+  else if (strcmp (argv[1], "hello_stderr") == 0)
+    fprintf (stderr, "hello");
+  else if (strcmp (argv[1], "cat") == 0)
+    while (! feof (stdin))
+      {
+        char buffer[4096];
+        size_t bytes_read;
+        bytes_read = fread (buffer, 1, sizeof buffer, stdin);
+        fwrite (buffer, 1, bytes_read, stdout);
+      }
+  else
+    {
+      fprintf (stderr, "unknown command %s\n", argv[1]);
+      return 2;
+    }
+  return 0;
+}
diff --git a/tests/gpgscm/t-child.scm b/tests/gpgscm/t-child.scm
new file mode 100644 (file)
index 0000000..27928f6
--- /dev/null
@@ -0,0 +1,93 @@
+;; Tests for the low-level process and IPC primitives.
+;;
+;; 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 <http://www.gnu.org/licenses/>.
+
+(echo "Testing process and IPC primitives...")
+
+(define (qualify executable)
+  (string-append executable (getenv "EXEEXT")))
+
+(assert (= 0 (call `(,(qualify "t-child") "return0"))))
+(assert (= 1 (call `(,(qualify "t-child") "return1"))))
+(assert (= 77 (call `(,(qualify "t-child") "return77"))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "return0") "")))
+  (assert (= 0 (:retcode r)))
+  (assert (string=? "" (:stdout r)))
+  (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "return1") "")))
+  (assert (= 1 (:retcode r)))
+  (assert (string=? "" (:stdout r)))
+  (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "return77") "")))
+  (assert (= 77 (:retcode r)))
+  (assert (string=? "" (:stdout r)))
+  (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "hello_stdout") "")))
+  (assert (= 0 (:retcode r)))
+  (assert (string=? "hello" (:stdout r)))
+  (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "hello_stderr") "")))
+  (assert (= 0 (:retcode r)))
+  (assert (string=? "" (:stdout r)))
+  (assert (string=? "hello" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "cat") "hellohello")))
+  (assert (= 0 (:retcode r)))
+  (assert (string=? "hellohello" (:stdout r)))
+  (assert (string=? "" (:stderr r))))
+
+(define (spawn what)
+  (spawn-process-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO))
+
+(let ((pid0 (spawn `(,(qualify "t-child") "return0")))
+      (pid1 (spawn `(,(qualify "t-child") "return0"))))
+  (assert (equal? '(0 0)
+                 (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+
+(let ((pid0 (spawn `(,(qualify "t-child") "return1")))
+      (pid1 (spawn `(,(qualify "t-child") "return0"))))
+  (assert (equal? '(1 0)
+                 (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+
+(let ((pid0 (spawn `(,(qualify "t-child") "return0")))
+      (pid1 (spawn `(,(qualify "t-child") "return77")))
+      (pid2 (spawn `(,(qualify "t-child") "return1"))))
+  (assert (equal? '(0 77 1)
+                 (wait-processes '("child0" "child1" "child2")
+                                 (list pid0 pid1 pid2) #t))))
+
+(let* ((p (pipe))
+       (pid0 (spawn-process-fd
+              `(,(qualify "t-child") "hello_stdout")
+              CLOSED_FD (:write-end p) STDERR_FILENO))
+       (_ (close (:write-end p)))
+       (pid1 (spawn-process-fd
+              `(,(qualify "t-child") "cat")
+              (:read-end p) STDOUT_FILENO STDERR_FILENO)))
+  (close (:read-end p))
+  (assert
+   (equal? '(0 0)
+          (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+(echo " world.")
+
+(echo "All good.")
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
new file mode 100644 (file)
index 0000000..7e20c34
--- /dev/null
@@ -0,0 +1,402 @@
+;; Common definitions for writing tests.
+;;
+;; 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 <http://www.gnu.org/licenses/>.
+
+;; Trace displays and returns the given value.  A debugging aid.
+(define (trace x)
+  (display x)
+  (newline)
+  x)
+
+;; Stringification.
+(define (stringify expression)
+  (let ((p (open-output-string)))
+    (write expression p)
+    (get-output-string p)))
+
+;; Reporting.
+(define (info msg)
+  (display msg)
+  (newline)
+  (flush-stdio))
+
+(define (error msg)
+  (info msg)
+  (exit 1))
+
+(define (skip msg)
+  (info msg)
+  (exit 77))
+
+(define (make-counter)
+  (let ((c 0))
+    (lambda ()
+      (let ((r c))
+       (set! c (+ 1 c))
+       r))))
+
+(define *progress-nesting* 0)
+
+(define (call-with-progress msg what)
+  (set! *progress-nesting* (+ 1 *progress-nesting*))
+  (if (= 1 *progress-nesting*)
+      (begin
+       (info msg)
+       (display "    > ")
+       (flush-stdio)
+       (what (lambda (item)
+             (display item)
+             (display " ")
+             (flush-stdio)))
+       (info "< "))
+      (begin
+       (what (lambda (item) (display ".") (flush-stdio)))
+       (display " ")
+       (flush-stdio)))
+  (set! *progress-nesting* (- *progress-nesting* 1)))
+
+(define (for-each-p msg proc lst)
+  (for-each-p' msg proc (lambda (x) x) lst))
+
+(define (for-each-p' msg proc fmt lst)
+  (call-with-progress
+   msg
+   (lambda (progress)
+     (for-each (lambda (a)
+                (progress (fmt a))
+                (proc a))
+              lst))))
+
+;; Process management.
+(define CLOSED_FD -1)
+(define (call-with-fds what infd outfd errfd)
+  (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
+(define (call what)
+  (call-with-fds what
+                CLOSED_FD
+                (if (< *verbose* 0) STDOUT_FILENO CLOSED_FD)
+                (if (< *verbose* 0) STDERR_FILENO CLOSED_FD)))
+(define (call-check what)
+  (if (not (= 0 (call what)))
+      (throw (list what "failed"))))
+
+;; Accessor functions for the results of 'spawn-process'.
+(define :stdin car)
+(define :stdout cadr)
+(define :stderr caddr)
+(define :pid cadddr)
+
+(define (call-with-io what in)
+  (let ((h (spawn-process what 0)))
+    (es-write (:stdin h) in)
+    (es-fclose (:stdin h))
+    (let* ((out (es-read-all (:stdout h)))
+          (err (es-read-all (:stderr h)))
+          (result (wait-process (car what) (:pid h) #t)))
+      (es-fclose (:stdout h))
+      (es-fclose (:stderr h))
+      (list result out err))))
+
+;; Accessor function for the results of 'call-with-io'.  ':stdout' and
+;; ':stderr' can also be used.
+(define :retcode car)
+
+(define (call-popen command input-string)
+  (let ((result (call-with-io command input-string)))
+    (if (= 0 (:retcode result))
+       (:stdout result)
+       (throw (:stderr result)))))
+
+;;
+;; estream helpers.
+;;
+
+(define (es-read-all stream)
+  (let loop
+      ((acc ""))
+    (if (es-feof stream)
+       acc
+       (loop (string-append acc (es-read stream 4096))))))
+
+;;
+;; File management.
+;;
+(define (file=? a b)
+  (file-equal a b #t))
+
+(define (text-file=? a b)
+  (file-equal a b #f))
+
+(define (file-copy from to)
+  (catch '() (unlink to))
+  (letfd ((source (open from (logior O_RDONLY O_BINARY)))
+         (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
+    (splice source sink)))
+
+(define (text-file-copy from to)
+  (catch '() (unlink to))
+  (letfd ((source (open from O_RDONLY))
+         (sink (open to (logior O_WRONLY O_CREAT) #o600)))
+    (splice source sink)))
+
+(define (canonical-path path)
+  (if (char=? #\/ (string-ref path 0))
+      path
+      (string-append (getcwd) "/" path)))
+
+(define (in-srcdir what)
+  (canonical-path (string-append (getenv "srcdir") "/" what)))
+
+(define (with-path name)
+  (let loop ((path (string-split (getenv "GPGSCM_PATH") #\:)))
+    (if (null? path)
+       name
+       (let* ((qualified-name (string-append (car path) "/" name))
+              (file-exists (call-with-input-file qualified-name
+                             (lambda (x) #t))))
+         (if file-exists
+             qualified-name
+             (loop (cdr path)))))))
+
+(define (basename path)
+  (let ((i (string-index path #\/)))
+    (if (equal? i #f)
+       path
+       (basename (substring path (+ 1 i) (string-length path))))))
+
+;; Helper for (pipe).
+(define :read-end car)
+(define :write-end cadr)
+
+;; let-like macro that manages file descriptors.
+;;
+;; (letfd <bindings> <body>)
+;;
+;; Bind all variables given in <bindings> and initialize each of them
+;; to the given initial value, and close them after evaluting <body>.
+(macro (letfd form)
+  (let ((result-sym (gensym)))
+    `((lambda (,(caaadr form))
+       (let ((,result-sym
+              ,(if (= 1 (length (cadr form)))
+                   `(begin ,@(cddr form))
+                   `(letfd ,(cdadr form) ,@(cddr form)))))
+         (close ,(caaadr form))
+         ,result-sym)) ,@(cdaadr form))))
+
+(macro (with-working-directory form)
+  (let ((result-sym (gensym)) (cwd-sym (gensym)))
+    `(let* ((,cwd-sym (getcwd))
+           (_ (if ,(cadr form) (chdir ,(cadr form))))
+           (,result-sym (begin ,@(cddr form))))
+       (chdir ,cwd-sym)
+       ,result-sym)))
+
+(macro (with-temporary-working-directory form)
+  (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym)))
+    `(let* ((,cwd-sym (getcwd))
+           (,tmp-sym (mkdtemp "gpgscm-XXXXXX"))
+           (_ (chdir ,tmp-sym))
+           (,result-sym (begin ,@(cdr form))))
+       (chdir ,cwd-sym)
+       (unlink-recursively ,tmp-sym)
+       ,result-sym)))
+
+(define (make-temporary-file . args)
+  (canonical-path (string-append (mkdtemp "gpgscm-XXXXXX")
+                                "/"
+                                (if (null? args) "a" (car args)))))
+
+(define (remove-temporary-file filename)
+  (catch '()
+    (unlink filename))
+  (let ((dirname (substring filename 0 (string-rindex filename #\/))))
+    (catch (echo "removing temporary directory" dirname "failed")
+      (rmdir dirname))))
+
+;; let-like macro that manages temporary files.
+;;
+;; (lettmp <bindings> <body>)
+;;
+;; Bind all variables given in <bindings>, initialize each of them to
+;; a string representing an unique path in the filesystem, and delete
+;; them after evaluting <body>.
+(macro (lettmp form)
+  (let ((result-sym (gensym)))
+    `((lambda (,(caadr form))
+       (let ((,result-sym
+              ,(if (= 1 (length (cadr form)))
+                   `(begin ,@(cddr form))
+                   `(lettmp ,(cdadr form) ,@(cddr form)))))
+         (remove-temporary-file ,(caadr form))
+         ,result-sym)) (make-temporary-file ,(symbol->string (caadr form))))))
+
+(define (check-execution source transformer)
+  (lettmp (sink)
+         (transformer source sink)))
+
+(define (check-identity source transformer)
+  (lettmp (sink)
+         (transformer source sink)
+         (if (not (file=? source sink))
+             (error "mismatch"))))
+
+;;
+;; Monadic pipe support.
+;;
+
+(define pipeM
+  (package
+   (define (new procs source sink producer)
+     (package
+      (define (dump)
+       (write (list procs source sink producer))
+       (newline))
+      (define (add-proc command pid)
+       (new (cons (list command pid) procs) source sink producer))
+      (define (commands)
+       (map car procs))
+      (define (pids)
+       (map cadr procs))
+      (define (set-source source')
+       (new procs source' sink producer))
+      (define (set-sink sink')
+       (new procs source sink' producer))
+      (define (set-producer producer')
+       (if producer
+           (throw "producer already set"))
+       (new procs source sink producer'))))))
+
+
+(define (pipe:do . commands)
+  (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
+    (if (null? cmds)
+       (begin
+         (if M::producer (M::producer))
+         (if (not (null? M::procs))
+             (let* ((retcodes (wait-processes (map stringify (M::commands))
+                                              (M::pids) #t))
+                    (results (map (lambda (p r) (append p (list r)))
+                                  M::procs retcodes))
+                    (failed (filter (lambda (x) (not (= 0 (caddr x))))
+                                    results)))
+               (if (not (null? failed))
+                   (throw failed))))) ; xxx nicer reporting
+       (if (and (= 2 (length cmds)) (number? (cadr cmds)))
+           ;; hack: if it's an fd, use it as sink
+           (let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
+             (if (> M::source 2) (close M::source))
+             (if (> (cadr cmds) 2) (close (cadr cmds)))
+             (loop M' '()))
+           (let ((M' ((car cmds) M)))
+             (if (> M::source 2) (close M::source))
+             (loop M' (cdr cmds)))))))
+
+(define (pipe:open pathname flags)
+  (lambda (M)
+    (M::set-source (open pathname flags))))
+
+(define (pipe:defer producer)
+  (lambda (M)
+    (let* ((p (outbound-pipe))
+          (M' (M::set-source (:read-end p))))
+      (M'::set-producer (lambda ()
+                         (producer (:write-end p))
+                         (close (:write-end p)))))))
+(define (pipe:echo data)
+ (pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
+
+(define (pipe:spawn command)
+  (lambda (M)
+    (define (do-spawn M new-source)
+      (let ((pid (spawn-process-fd command M::source M::sink
+                                  (if (> *verbose* 0)
+                                      STDERR_FILENO CLOSED_FD)))
+           (M' (M::set-source new-source)))
+       (M'::add-proc command pid)))
+    (if (= CLOSED_FD M::sink)
+       (let* ((p (pipe))
+              (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
+         (close (:write-end p))
+         (M'::set-sink CLOSED_FD))
+       (do-spawn M CLOSED_FD))))
+
+(define (pipe:splice sink)
+  (lambda (M)
+    (splice M::source sink)
+    (M::set-source CLOSED_FD)))
+
+(define (pipe:write-to pathname flags mode)
+  (open pathname flags mode))
+
+;;
+;; Monadic transformer support.
+;;
+
+(define (tr:do . commands)
+  (let loop ((tmpfiles '()) (source  #f) (cmds commands))
+    (if (null? cmds)
+       (for-each remove-temporary-file tmpfiles)
+       (let ((v ((car cmds) tmpfiles source)))
+         (loop (car v) (cadr v) (cdr cmds))))))
+
+(define (tr:open pathname)
+  (lambda (tmpfiles source)
+    (list tmpfiles pathname)))
+
+(define (tr:spawn input command)
+  (lambda (tmpfiles source)
+    (let* ((t (make-temporary-file))
+          (cmd (map (lambda (x)
+                      (cond
+                       ((equal? '**in** x) source)
+                       ((equal? '**out** x) t)
+                       (else x))) command)))
+      (call-popen cmd input)
+      (list (cons t tmpfiles) t))))
+
+(define (tr:write-to pathname)
+  (lambda (tmpfiles source)
+    (rename source pathname)
+    (list tmpfiles pathname)))
+
+(define (tr:pipe-do . commands)
+  (lambda (tmpfiles source)
+    (let ((t (make-temporary-file)))
+      (apply pipe:do
+        `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
+         ,@commands
+         ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
+      (list (cons t tmpfiles) t))))
+
+(define (tr:assert-identity reference)
+  (lambda (tmpfiles source)
+    (if (not (file=? source reference))
+       (error "mismatch"))
+    (list tmpfiles source)))
+
+(define (tr:assert-weak-identity reference)
+  (lambda (tmpfiles source)
+    (if (not (text-file=? source reference))
+       (error "mismatch"))
+    (list tmpfiles source)))
+
+(define (tr:call-with-content function)
+  (lambda (tmpfiles source)
+    (function (call-with-input-file source read-all))
+    (list tmpfiles source)))