[Pkg-gnupg-commit] [gnupg2] 17/160: tests/gpgscm: Add a TinySCHEME-based test driver.
Daniel Kahn Gillmor
dkg at fifthhorseman.net
Fri Jul 15 09:36:32 UTC 2016
This is an automated email from the git hooks/post-receive script.
dkg pushed a commit to branch upstream
in repository gnupg2.
commit d2ce3f9eee34e380536049c0c9d26ed66273f094
Author: Justus Winter <justus at g10code.com>
Date: Wed Jan 6 11:55:25 2016 +0100
tests/gpgscm: Add a TinySCHEME-based test driver.
* 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 at g10code.com>
---
configure.ac | 1 +
tests/Makefile.am | 2 +-
tests/gpgscm/Makefile.am | 57 +++
tests/gpgscm/ffi-private.h | 132 +++++
tests/gpgscm/ffi.c | 1167 ++++++++++++++++++++++++++++++++++++++++++
tests/gpgscm/ffi.h | 30 ++
tests/gpgscm/ffi.scm | 40 ++
tests/gpgscm/lib.scm | 163 ++++++
tests/gpgscm/main.c | 286 +++++++++++
tests/gpgscm/private.h | 26 +
tests/gpgscm/repl.scm | 50 ++
tests/gpgscm/scheme-config.h | 36 ++
tests/gpgscm/t-child.c | 66 +++
tests/gpgscm/t-child.scm | 93 ++++
tests/gpgscm/tests.scm | 402 +++++++++++++++
15 files changed, 2550 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index 9f3aeb3..bb925c5 100644
--- a/configure.ac
+++ b/configure.ac
@@ -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
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 307d829..e49c283 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -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
index 0000000..1fb9647
--- /dev/null
+++ b/tests/gpgscm/Makefile.am
@@ -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
index 0000000..5467dac
--- /dev/null
+++ b/tests/gpgscm/ffi-private.h
@@ -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
index 0000000..babf1e1
--- /dev/null
+++ b/tests/gpgscm/ffi.c
@@ -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"
+
+
+
+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;
+ 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);
+}
+
+
+
+/* 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],
+ 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
+}
+
+
+
+/* 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);
+}
+
+
+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;
+}
+
+
+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
index 0000000..02dd99d
--- /dev/null
+++ b/tests/gpgscm/ffi.h
@@ -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
index 0000000..d0b8a99
--- /dev/null
+++ b/tests/gpgscm/ffi.scm
@@ -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
index 0000000..871cc8f
--- /dev/null
+++ b/tests/gpgscm/lib.scm
@@ -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
index 0000000..3414e3d
--- /dev/null
+++ b/tests/gpgscm/main.c
@@ -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;
+
+
+
+/* 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;
+}
+
+
+/* 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;
+}
+
+
+
+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
index 0000000..efa0cb0
--- /dev/null
+++ b/tests/gpgscm/private.h
@@ -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
index 0000000..896554f
--- /dev/null
+++ b/tests/gpgscm/repl.scm
@@ -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
index 0000000..fe3d746
--- /dev/null
+++ b/tests/gpgscm/scheme-config.h
@@ -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
index 0000000..fe2e7b4
--- /dev/null
+++ b/tests/gpgscm/t-child.c
@@ -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
index 0000000..27928f6
--- /dev/null
+++ b/tests/gpgscm/t-child.scm
@@ -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
index 0000000..7e20c34
--- /dev/null
+++ b/tests/gpgscm/tests.scm
@@ -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))) '())
+ , at 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)))
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-gnupg/gnupg2.git
More information about the Pkg-gnupg-commit
mailing list