summaryrefslogtreecommitdiffstats
path: root/tests/gpgscm/ffi.c
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--tests/gpgscm/ffi.c1470
1 files changed, 1470 insertions, 0 deletions
diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c
new file mode 100644
index 0000000..dde5b52
--- /dev/null
+++ b/tests/gpgscm/ffi.c
@@ -0,0 +1,1470 @@
+/* FFI interface for TinySCHEME.
+ *
+ * Copyright (C) 2016 g10 code GmbH
+ *
+ * This file is part of GnuPG.
+ *
+ * GnuPG is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * GnuPG is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, see <https://www.gnu.org/licenses/>.
+ */
+
+#include <config.h>
+
+#include <assert.h>
+#include <ctype.h>
+#include <dirent.h>
+#include <errno.h>
+#include <fcntl.h>
+#include <gpg-error.h>
+#include <limits.h>
+#include <stdarg.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#if HAVE_LIBREADLINE
+#define GNUPG_LIBREADLINE_H_INCLUDED
+#include <readline/readline.h>
+#include <readline/history.h>
+#endif
+
+#include "../../common/util.h"
+#include "../../common/exechelp.h"
+#include "../../common/sysutils.h"
+
+#include "private.h"
+#include "ffi.h"
+#include "ffi-private.h"
+
+/* For use in nice error messages. */
+static const char *
+ordinal_suffix (int n)
+{
+ switch (n)
+ {
+ case 1: return "st";
+ case 2: return "nd";
+ case 3: return "rd";
+ default: return "th";
+ }
+ assert (! "reached");
+}
+
+
+
+int
+ffi_bool_value (scheme *sc, pointer p)
+{
+ return ! (p == sc->F);
+}
+
+
+
+static pointer
+do_logand (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int v, acc = ~0;
+ while (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
+ acc &= v;
+ }
+ FFI_RETURN_INT (sc, acc);
+}
+
+static pointer
+do_logior (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int v, acc = 0;
+ while (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
+ acc |= v;
+ }
+ FFI_RETURN_INT (sc, acc);
+}
+
+static pointer
+do_logxor (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int v, acc = 0;
+ while (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
+ acc ^= v;
+ }
+ FFI_RETURN_INT (sc, acc);
+}
+
+static pointer
+do_lognot (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int v;
+ FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, ~v);
+}
+
+/* User interface. */
+
+static pointer
+do_flush_stdio (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ fflush (stdout);
+ fflush (stderr);
+ FFI_RETURN (sc);
+}
+
+
+int use_libreadline;
+
+/* Read a string, and return a pointer to it. Returns NULL on EOF. */
+char *
+rl_gets (const char *prompt)
+{
+ static char *line = NULL;
+ char *p;
+ xfree (line);
+
+#if HAVE_LIBREADLINE
+ {
+ line = readline (prompt);
+ if (line && *line)
+ add_history (line);
+ }
+#else
+ {
+ size_t max_size = 0xff;
+ printf ("%s", prompt);
+ fflush (stdout);
+ line = xtrymalloc (max_size);
+ if (line != NULL)
+ fgets (line, max_size, stdin);
+ }
+#endif
+
+ /* Strip trailing whitespace. */
+ if (line && strlen (line) > 0)
+ for (p = &line[strlen (line) - 1]; isspace (*p); p--)
+ *p = 0;
+
+ return line;
+}
+
+static pointer
+do_prompt (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ const char *prompt;
+ const char *line;
+ FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ line = rl_gets (prompt);
+ if (! line)
+ FFI_RETURN_POINTER (sc, sc->EOF_OBJ);
+
+ FFI_RETURN_STRING (sc, line);
+}
+
+static pointer
+do_sleep (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int seconds;
+ FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ sleep (seconds);
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_usleep (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ useconds_t microseconds;
+ FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ usleep (microseconds);
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_chdir (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, name, path, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (chdir (name))
+ FFI_RETURN_ERR (sc, errno);
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_strerror (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int error;
+ FFI_ARG_OR_RETURN (sc, int, error, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_STRING (sc, gpg_strerror (error));
+}
+
+static pointer
+do_getenv (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ char *value;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ value = getenv (name);
+ FFI_RETURN_STRING (sc, value ? value : "");
+}
+
+static pointer
+do_setenv (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ char *value;
+ int overwrite;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, value, string, args);
+ FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (gnupg_setenv (name, value, overwrite))
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_exit (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int retcode;
+ FFI_ARG_OR_RETURN (sc, int, retcode, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ exit (retcode);
+}
+
+/* XXX: use gnupgs variant b/c mode as string */
+static pointer
+do_open (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int fd;
+ char *pathname;
+ int flags;
+ mode_t mode = 0;
+ FFI_ARG_OR_RETURN (sc, char *, pathname, path, args);
+ FFI_ARG_OR_RETURN (sc, int, flags, number, args);
+ if (args != sc->NIL)
+ FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ fd = open (pathname, flags, mode);
+ if (fd == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN_INT (sc, fd);
+}
+
+static pointer
+do_fdopen (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FILE *stream;
+ int fd;
+ char *mode;
+ int kind;
+ FFI_ARG_OR_RETURN (sc, int, fd, number, args);
+ FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ stream = fdopen (fd, mode);
+ if (stream == NULL)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+
+ if (setvbuf (stream, NULL, _IONBF, 0) != 0)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+
+ kind = 0;
+ if (strchr (mode, 'r'))
+ kind |= port_input;
+ if (strchr (mode, 'w'))
+ kind |= port_output;
+
+ FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind));
+}
+
+static pointer
+do_close (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int fd;
+ FFI_ARG_OR_RETURN (sc, int, fd, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ());
+}
+
+static pointer
+do_seek (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int fd;
+ off_t offset;
+ int whence;
+ FFI_ARG_OR_RETURN (sc, int, fd, number, args);
+ FFI_ARG_OR_RETURN (sc, off_t, offset, number, args);
+ FFI_ARG_OR_RETURN (sc, int, whence, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_ERR (sc, lseek (fd, offset, whence) == (off_t) -1
+ ? gpg_error_from_syserror () : 0);
+}
+
+static pointer
+do_get_temp_path (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+#ifdef HAVE_W32_SYSTEM
+ char buffer[MAX_PATH+1];
+#endif
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+#ifdef HAVE_W32_SYSTEM
+ if (GetTempPath (MAX_PATH+1, buffer) == 0)
+ FFI_RETURN_STRING (sc, "/temp");
+ FFI_RETURN_STRING (sc, buffer);
+#else
+ FFI_RETURN_STRING (sc, "/tmp");
+#endif
+}
+
+static pointer
+do_mkdtemp (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *template;
+#ifdef PATH_MAX
+ char buffer[PATH_MAX];
+#else
+ char buffer[1024];
+#endif
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, template, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ if (strlen (template) > sizeof buffer - 1)
+ FFI_RETURN_ERR (sc, EINVAL);
+ strncpy (buffer, template, sizeof buffer);
+
+ name = gnupg_mkdtemp (buffer);
+ if (name == NULL)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN_STRING (sc, name);
+}
+
+static pointer
+do_unlink (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (unlink (name) == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static gpg_error_t
+unlink_recursively (const char *name)
+{
+ gpg_error_t err = 0;
+ struct stat st;
+
+ if (stat (name, &st) == -1)
+ return gpg_error_from_syserror ();
+
+ if (S_ISDIR (st.st_mode))
+ {
+ DIR *dir;
+ struct dirent *dent;
+
+ dir = opendir (name);
+ if (dir == NULL)
+ return gpg_error_from_syserror ();
+
+ while ((dent = readdir (dir)))
+ {
+ char *child;
+
+ if (strcmp (dent->d_name, ".") == 0
+ || strcmp (dent->d_name, "..") == 0)
+ continue;
+
+ child = xtryasprintf ("%s/%s", name, dent->d_name);
+ if (child == NULL)
+ {
+ err = gpg_error_from_syserror ();
+ goto leave;
+ }
+
+ err = unlink_recursively (child);
+ xfree (child);
+ if (err == gpg_error_from_errno (ENOENT))
+ err = 0;
+ if (err)
+ goto leave;
+ }
+
+ leave:
+ closedir (dir);
+ if (! err)
+ rmdir (name);
+ return err;
+ }
+ else
+ if (unlink (name) == -1)
+ return gpg_error_from_syserror ();
+ return 0;
+}
+
+static pointer
+do_unlink_recursively (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = unlink_recursively (name);
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_rename (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *old;
+ char *new;
+ FFI_ARG_OR_RETURN (sc, char *, old, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, new, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (rename (old, new) == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_getcwd (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer result;
+ char *cwd;
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ cwd = gnupg_getcwd ();
+ if (cwd == NULL)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ result = sc->vptr->mk_string (sc, cwd);
+ xfree (cwd);
+ FFI_RETURN_POINTER (sc, result);
+}
+
+static pointer
+do_mkdir (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ char *mode;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (gnupg_mkdir (name, mode) == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_rmdir (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (rmdir (name) == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_get_isotime (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ gnupg_isotime_t timebuf;
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ gnupg_get_isotime (timebuf);
+ FFI_RETURN_STRING (sc, timebuf);
+}
+
+static pointer
+do_get_time (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, gnupg_get_time ());
+}
+
+static pointer
+do_getpid (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, getpid ());
+}
+
+static pointer
+do_srandom (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int seed;
+ FFI_ARG_OR_RETURN (sc, int, seed, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ srand (seed);
+ FFI_RETURN (sc);
+}
+
+static int
+random_scaled (int scale)
+{
+ int v;
+#ifdef HAVE_RAND
+ v = rand ();
+#else
+ v = random ();
+#endif
+
+#ifndef RAND_MAX /* for SunOS */
+#define RAND_MAX 32767
+#endif
+
+ return ((int) (1 + (int) ((float) scale * v / (RAND_MAX + 1.0))) - 1);
+}
+
+static pointer
+do_random (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int scale;
+ FFI_ARG_OR_RETURN (sc, int, scale, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, random_scaled (scale));
+}
+
+static pointer
+do_make_random_string (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int size;
+ pointer chunk;
+ char *p;
+ FFI_ARG_OR_RETURN (sc, int, size, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (size < 0)
+ return ffi_sprintf (sc, "size must be positive");
+
+ chunk = sc->vptr->mk_counted_string (sc, NULL, size);
+ if (sc->no_memory)
+ FFI_RETURN_ERR (sc, ENOMEM);
+
+ for (p = sc->vptr->string_value (chunk); size; p++, size--)
+ *p = (char) random_scaled (256);
+ FFI_RETURN_POINTER (sc, chunk);
+}
+
+
+
+/* estream functions. */
+
+struct es_object_box
+{
+ estream_t stream;
+ int closed;
+};
+
+static void
+es_object_finalize (scheme *sc, void *data)
+{
+ struct es_object_box *box = data;
+ (void) sc;
+
+ if (! box->closed)
+ es_fclose (box->stream);
+ xfree (box);
+}
+
+static void
+es_object_to_string (scheme *sc, char *out, size_t size, void *data)
+{
+ struct es_object_box *box = data;
+ (void) sc;
+
+ snprintf (out, size, "#estream %p", box->stream);
+}
+
+static struct foreign_object_vtable es_object_vtable =
+ {
+ es_object_finalize,
+ es_object_to_string,
+ };
+
+static pointer
+es_wrap (scheme *sc, estream_t stream)
+{
+ struct es_object_box *box = xmalloc (sizeof *box);
+ if (box == NULL)
+ return sc->NIL;
+
+ box->stream = stream;
+ box->closed = 0;
+ return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box);
+}
+
+static struct es_object_box *
+es_unwrap (scheme *sc, pointer object)
+{
+ (void) sc;
+
+ if (! is_foreign_object (object))
+ return NULL;
+
+ if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable)
+ return NULL;
+
+ return sc->vptr->get_foreign_object_data (object);
+}
+
+#define CONVERSION_estream(SC, X) es_unwrap (SC, X)
+#define IS_A_estream(SC, X) es_unwrap (SC, X)
+
+static pointer
+do_es_fclose (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ struct es_object_box *box;
+ FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = es_fclose (box->stream);
+ if (! err)
+ box->closed = 1;
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_es_read (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ struct es_object_box *box;
+ size_t bytes_to_read;
+
+ pointer result;
+ void *buffer;
+ size_t bytes_read;
+
+ FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
+ FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ buffer = xtrymalloc (bytes_to_read);
+ if (buffer == NULL)
+ FFI_RETURN_ERR (sc, ENOMEM);
+
+ err = es_read (box->stream, buffer, bytes_to_read, &bytes_read);
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ result = sc->vptr->mk_counted_string (sc, buffer, bytes_read);
+ xfree (buffer);
+ FFI_RETURN_POINTER (sc, result);
+}
+
+static pointer
+do_es_feof (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ struct es_object_box *box;
+ FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F);
+}
+
+static pointer
+do_es_write (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ struct es_object_box *box;
+ const char *buffer;
+ size_t bytes_to_write, bytes_written;
+
+ FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
+ /* XXX how to get the length of the string buffer? scheme strings
+ may contain \0. */
+ FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ bytes_to_write = strlen (buffer);
+ while (bytes_to_write > 0)
+ {
+ err = es_write (box->stream, buffer, bytes_to_write, &bytes_written);
+ if (err)
+ break;
+ bytes_to_write -= bytes_written;
+ buffer += bytes_written;
+ }
+
+ FFI_RETURN (sc);
+}
+
+
+
+/* Process handling. */
+
+static pointer
+do_spawn_process (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer arguments;
+ char **argv;
+ size_t len;
+ unsigned int flags;
+
+ estream_t infp;
+ estream_t outfp;
+ estream_t errfp;
+ pid_t pid;
+
+ FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
+ FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ err = ffi_list2argv (sc, arguments, &argv, &len);
+ if (err == gpg_error (GPG_ERR_INV_VALUE))
+ return ffi_sprintf (sc, "%luth element of first argument is "
+ "neither string nor symbol",
+ (unsigned long) len);
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ if (verbose > 1)
+ {
+ char **p;
+ fprintf (stderr, "Executing:");
+ for (p = argv; *p; p++)
+ fprintf (stderr, " '%s'", *p);
+ fprintf (stderr, "\n");
+ }
+
+ err = gnupg_spawn_process (argv[0], (const char **) &argv[1],
+ NULL,
+ NULL,
+ flags,
+ &infp, &outfp, &errfp, &pid);
+ xfree (argv);
+#define IMC(A, B) \
+ _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
+#define IMS(A, B) \
+ _cons (sc, es_wrap (sc, (A)), (B), 1)
+ FFI_RETURN_POINTER (sc, IMS (infp,
+ IMS (outfp,
+ IMS (errfp,
+ IMC (pid, sc->NIL)))));
+#undef IMS
+#undef IMC
+}
+
+static pointer
+do_spawn_process_fd (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer arguments;
+ char **argv;
+ size_t len;
+ int infd, outfd, errfd;
+
+ pid_t pid;
+
+ FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
+ FFI_ARG_OR_RETURN (sc, int, infd, number, args);
+ FFI_ARG_OR_RETURN (sc, int, outfd, number, args);
+ FFI_ARG_OR_RETURN (sc, int, errfd, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ err = ffi_list2argv (sc, arguments, &argv, &len);
+ if (err == gpg_error (GPG_ERR_INV_VALUE))
+ return ffi_sprintf (sc, "%luth element of first argument is "
+ "neither string nor symbol",
+ (unsigned long) len);
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ if (verbose > 1)
+ {
+ char **p;
+ fprintf (stderr, "Executing:");
+ for (p = argv; *p; p++)
+ fprintf (stderr, " '%s'", *p);
+ fprintf (stderr, "\n");
+ }
+
+ err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1],
+ infd, outfd, errfd, &pid);
+ xfree (argv);
+ FFI_RETURN_INT (sc, pid);
+}
+
+static pointer
+do_wait_process (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ const char *name;
+ pid_t pid;
+ int hang;
+
+ int retcode;
+
+ FFI_ARG_OR_RETURN (sc, const char *, name, string, args);
+ FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args);
+ FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = gnupg_wait_process (name, pid, hang, &retcode);
+ if (err == GPG_ERR_GENERAL)
+ err = 0; /* Let the return code speak for itself. */
+
+ FFI_RETURN_INT (sc, retcode);
+}
+
+
+static pointer
+do_wait_processes (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer list_names;
+ char **names;
+ pointer list_pids;
+ size_t i, count;
+ pid_t *pids;
+ int hang;
+ int *retcodes;
+ pointer retcodes_list = sc->NIL;
+
+ FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args);
+ FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args);
+ FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ if (sc->vptr->list_length (sc, list_names)
+ != sc->vptr->list_length (sc, list_pids))
+ return
+ sc->vptr->mk_string (sc, "length of first two arguments must match");
+
+ err = ffi_list2argv (sc, list_names, &names, &count);
+ if (err == gpg_error (GPG_ERR_INV_VALUE))
+ return ffi_sprintf (sc, "%lu%s element of first argument is "
+ "neither string nor symbol",
+ (unsigned long) count,
+ ordinal_suffix ((int) count));
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ err = ffi_list2intv (sc, list_pids, (int **) &pids, &count);
+ if (err == gpg_error (GPG_ERR_INV_VALUE))
+ return ffi_sprintf (sc, "%lu%s element of second argument is "
+ "not a number",
+ (unsigned long) count,
+ ordinal_suffix ((int) count));
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ retcodes = xtrycalloc (sizeof *retcodes, count);
+ if (retcodes == NULL)
+ {
+ xfree (names);
+ xfree (pids);
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ }
+
+ err = gnupg_wait_processes ((const char **) names, pids, count, hang,
+ retcodes);
+ if (err == GPG_ERR_GENERAL)
+ err = 0; /* Let the return codes speak. */
+ if (err == GPG_ERR_TIMEOUT)
+ err = 0; /* We may have got some results. */
+
+ for (i = 0; i < count; i++)
+ retcodes_list =
+ (sc->vptr->cons) (sc,
+ sc->vptr->mk_integer (sc,
+ (long) retcodes[count-1-i]),
+ retcodes_list);
+
+ xfree (names);
+ xfree (pids);
+ xfree (retcodes);
+ FFI_RETURN_POINTER (sc, retcodes_list);
+}
+
+
+static pointer
+do_pipe (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int filedes[2];
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = gnupg_create_pipe (filedes);
+#define IMC(A, B) \
+ _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
+ FFI_RETURN_POINTER (sc, IMC (filedes[0],
+ IMC (filedes[1], sc->NIL)));
+#undef IMC
+}
+
+static pointer
+do_inbound_pipe (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int filedes[2];
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = gnupg_create_inbound_pipe (filedes, NULL, 0);
+#define IMC(A, B) \
+ _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
+ FFI_RETURN_POINTER (sc, IMC (filedes[0],
+ IMC (filedes[1], sc->NIL)));
+#undef IMC
+}
+
+static pointer
+do_outbound_pipe (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int filedes[2];
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = gnupg_create_outbound_pipe (filedes, NULL, 0);
+#define IMC(A, B) \
+ _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
+ FFI_RETURN_POINTER (sc, IMC (filedes[0],
+ IMC (filedes[1], sc->NIL)));
+#undef IMC
+}
+
+
+
+/* Test helper functions. */
+static pointer
+do_file_equal (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer result = sc->F;
+ char *a_name, *b_name;
+ int binary;
+ const char *mode;
+ FILE *a_stream = NULL, *b_stream = NULL;
+ struct stat a_stat, b_stat;
+#define BUFFER_SIZE 1024
+ char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE];
+#undef BUFFER_SIZE
+ size_t chunk;
+
+ FFI_ARG_OR_RETURN (sc, char *, a_name, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, b_name, string, args);
+ FFI_ARG_OR_RETURN (sc, int, binary, bool, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ mode = binary ? "rb" : "r";
+ a_stream = fopen (a_name, mode);
+ if (a_stream == NULL)
+ goto errout;
+
+ b_stream = fopen (b_name, mode);
+ if (b_stream == NULL)
+ goto errout;
+
+ if (fstat (fileno (a_stream), &a_stat) < 0)
+ goto errout;
+
+ if (fstat (fileno (b_stream), &b_stat) < 0)
+ goto errout;
+
+ if (binary && a_stat.st_size != b_stat.st_size)
+ {
+ if (verbose)
+ fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n",
+ a_name, b_name, (unsigned long) a_stat.st_size,
+ (unsigned long) b_stat.st_size);
+
+ goto out;
+ }
+
+ while (! feof (a_stream))
+ {
+ chunk = sizeof a_buf;
+
+ chunk = fread (a_buf, 1, chunk, a_stream);
+ if (chunk == 0 && ferror (a_stream))
+ goto errout; /* some error */
+
+ if (fread (b_buf, 1, chunk, b_stream) < chunk)
+ {
+ if (feof (b_stream))
+ goto out; /* short read */
+ goto errout; /* some error */
+ }
+
+ if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0)
+ goto out;
+ }
+
+ fread (b_buf, 1, 1, b_stream);
+ if (! feof (b_stream))
+ goto out; /* b is longer */
+
+ /* They match. */
+ result = sc->T;
+
+ out:
+ if (a_stream)
+ fclose (a_stream);
+ if (b_stream)
+ fclose (b_stream);
+ FFI_RETURN_POINTER (sc, result);
+ errout:
+ err = gpg_error_from_syserror ();
+ goto out;
+}
+
+static pointer
+do_splice (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int source;
+ char buffer[1024];
+ ssize_t bytes_read;
+ pointer sinks, sink;
+ FFI_ARG_OR_RETURN (sc, int, source, number, args);
+ sinks = args;
+ if (sinks == sc->NIL)
+ return ffi_sprintf (sc, "need at least one sink");
+ for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink), ffi_arg_index++)
+ if (! sc->vptr->is_number (pair_car (sink)))
+ return ffi_sprintf (sc, "%d%s argument is not a number",
+ ffi_arg_index, ordinal_suffix (ffi_arg_index));
+
+ while (1)
+ {
+ bytes_read = read (source, buffer, sizeof buffer);
+ if (bytes_read == 0)
+ break;
+ if (bytes_read < 0)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+
+ for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink))
+ {
+ int fd = sc->vptr->ivalue (pair_car (sink));
+ char *p = buffer;
+ ssize_t left = bytes_read;
+
+ while (left)
+ {
+ ssize_t written = write (fd, p, left);
+ if (written < 0)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ assert (written <= left);
+ left -= written;
+ p += written;
+ }
+ }
+ }
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_string_index (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *haystack;
+ char needle;
+ ssize_t offset = 0;
+ char *position;
+ FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+ FFI_ARG_OR_RETURN (sc, char, needle, character, args);
+ if (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
+ if (offset < 0)
+ return ffi_sprintf (sc, "offset must be positive");
+ if (offset > strlen (haystack))
+ return ffi_sprintf (sc, "offset exceeds haystack");
+ }
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ position = strchr (haystack+offset, needle);
+ if (position)
+ FFI_RETURN_INT (sc, position - haystack);
+ else
+ FFI_RETURN_POINTER (sc, sc->F);
+}
+
+static pointer
+do_string_rindex (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *haystack;
+ char needle;
+ ssize_t offset = 0;
+ char *position;
+ FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+ FFI_ARG_OR_RETURN (sc, char, needle, character, args);
+ if (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
+ if (offset < 0)
+ return ffi_sprintf (sc, "offset must be positive");
+ if (offset > strlen (haystack))
+ return ffi_sprintf (sc, "offset exceeds haystack");
+ }
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ position = strrchr (haystack+offset, needle);
+ if (position)
+ FFI_RETURN_INT (sc, position - haystack);
+ else
+ FFI_RETURN_POINTER (sc, sc->F);
+}
+
+static pointer
+do_string_contains (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *haystack;
+ char *needle;
+ FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, needle, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F);
+}
+
+
+
+static pointer
+do_get_verbose (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, verbose);
+}
+
+static pointer
+do_set_verbose (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int new_verbosity, old;
+ FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ old = verbose;
+ verbose = new_verbosity;
+
+ FFI_RETURN_INT (sc, old);
+}
+
+
+gpg_error_t
+ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len)
+{
+ int i;
+
+ *len = sc->vptr->list_length (sc, list);
+ *argv = xtrycalloc (*len + 1, sizeof **argv);
+ if (*argv == NULL)
+ return gpg_error_from_syserror ();
+
+ for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
+ {
+ if (sc->vptr->is_string (sc->vptr->pair_car (list)))
+ (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list));
+ else if (sc->vptr->is_symbol (sc->vptr->pair_car (list)))
+ (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list));
+ else
+ {
+ xfree (*argv);
+ *argv = NULL;
+ *len = i;
+ return gpg_error (GPG_ERR_INV_VALUE);
+ }
+ }
+ (*argv)[i] = NULL;
+ return 0;
+}
+
+gpg_error_t
+ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len)
+{
+ int i;
+
+ *len = sc->vptr->list_length (sc, list);
+ *intv = xtrycalloc (*len, sizeof **intv);
+ if (*intv == NULL)
+ return gpg_error_from_syserror ();
+
+ for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
+ {
+ if (sc->vptr->is_number (sc->vptr->pair_car (list)))
+ (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list));
+ else
+ {
+ xfree (*intv);
+ *intv = NULL;
+ *len = i;
+ return gpg_error (GPG_ERR_INV_VALUE);
+ }
+ }
+
+ return 0;
+}
+
+
+char *
+ffi_schemify_name (const char *s, int macro)
+{
+ /* Fixme: We should use xtrystrdup and return NULL. However, this
+ * requires a lot more changes. Simply returning S as done
+ * originally is not an option. */
+ char *n = xstrdup (s), *p;
+ /* if (n == NULL) */
+ /* return s; */
+
+ for (p = n; *p; p++)
+ {
+ *p = (char) tolower (*p);
+ /* We convert _ to - in identifiers. We allow, however, for
+ function names to start with a leading _. The functions in
+ this namespace are not yet finalized and might change or
+ vanish without warning. Use them with care. */
+ if (! macro
+ && p != n
+ && *p == '_')
+ *p = '-';
+ }
+ return n;
+}
+
+pointer
+ffi_sprintf (scheme *sc, const char *format, ...)
+{
+ pointer result;
+ va_list listp;
+ char *expression;
+ int size, written;
+
+ va_start (listp, format);
+ size = vsnprintf (NULL, 0, format, listp);
+ va_end (listp);
+
+ expression = xtrymalloc (size + 1);
+ if (expression == NULL)
+ return NULL;
+
+ va_start (listp, format);
+ written = vsnprintf (expression, size + 1, format, listp);
+ va_end (listp);
+
+ assert (size == written);
+
+ result = sc->vptr->mk_string (sc, expression);
+ xfree (expression);
+ return result;
+}
+
+void
+ffi_scheme_eval (scheme *sc, const char *format, ...)
+{
+ va_list listp;
+ char *expression;
+ int size, written;
+
+ va_start (listp, format);
+ size = vsnprintf (NULL, 0, format, listp);
+ va_end (listp);
+
+ expression = xtrymalloc (size + 1);
+ if (expression == NULL)
+ return;
+
+ va_start (listp, format);
+ written = vsnprintf (expression, size + 1, format, listp);
+ va_end (listp);
+
+ assert (size == written);
+
+ sc->vptr->load_string (sc, expression);
+ xfree (expression);
+}
+
+gpg_error_t
+ffi_init (scheme *sc, const char *argv0, const char *scriptname,
+ int argc, const char **argv)
+{
+ int i;
+ pointer args = sc->NIL;
+
+ /* bitwise arithmetic */
+ ffi_define_function (sc, logand);
+ ffi_define_function (sc, logior);
+ ffi_define_function (sc, logxor);
+ ffi_define_function (sc, lognot);
+
+ /* libc. */
+ ffi_define_constant (sc, O_RDONLY);
+ ffi_define_constant (sc, O_WRONLY);
+ ffi_define_constant (sc, O_RDWR);
+ ffi_define_constant (sc, O_CREAT);
+ ffi_define_constant (sc, O_APPEND);
+#ifndef O_BINARY
+# define O_BINARY 0
+#endif
+#ifndef O_TEXT
+# define O_TEXT 0
+#endif
+ ffi_define_constant (sc, O_BINARY);
+ ffi_define_constant (sc, O_TEXT);
+ ffi_define_constant (sc, STDIN_FILENO);
+ ffi_define_constant (sc, STDOUT_FILENO);
+ ffi_define_constant (sc, STDERR_FILENO);
+ ffi_define_constant (sc, SEEK_SET);
+ ffi_define_constant (sc, SEEK_CUR);
+ ffi_define_constant (sc, SEEK_END);
+
+ ffi_define_function (sc, sleep);
+ ffi_define_function (sc, usleep);
+ ffi_define_function (sc, chdir);
+ ffi_define_function (sc, strerror);
+ ffi_define_function (sc, getenv);
+ ffi_define_function (sc, setenv);
+ ffi_define_function_name (sc, "_exit", exit);
+ ffi_define_function (sc, open);
+ ffi_define_function (sc, fdopen);
+ ffi_define_function (sc, close);
+ ffi_define_function (sc, seek);
+ ffi_define_function (sc, get_temp_path);
+ ffi_define_function_name (sc, "_mkdtemp", mkdtemp);
+ ffi_define_function (sc, unlink);
+ ffi_define_function (sc, unlink_recursively);
+ ffi_define_function (sc, rename);
+ ffi_define_function (sc, getcwd);
+ ffi_define_function (sc, mkdir);
+ ffi_define_function (sc, rmdir);
+ ffi_define_function (sc, get_isotime);
+ ffi_define_function (sc, get_time);
+ ffi_define_function (sc, getpid);
+
+ /* Random numbers. */
+ ffi_define_function (sc, srandom);
+ ffi_define_function (sc, random);
+ ffi_define_function (sc, make_random_string);
+
+ /* Process management. */
+ ffi_define_function (sc, spawn_process);
+ ffi_define_function (sc, spawn_process_fd);
+ ffi_define_function (sc, wait_process);
+ ffi_define_function (sc, wait_processes);
+ ffi_define_function (sc, pipe);
+ ffi_define_function (sc, inbound_pipe);
+ ffi_define_function (sc, outbound_pipe);
+
+ /* estream functions. */
+ ffi_define_function_name (sc, "es-fclose", es_fclose);
+ ffi_define_function_name (sc, "es-read", es_read);
+ ffi_define_function_name (sc, "es-feof", es_feof);
+ ffi_define_function_name (sc, "es-write", es_write);
+
+ /* Test helper functions. */
+ ffi_define_function (sc, file_equal);
+ ffi_define_function (sc, splice);
+ ffi_define_function (sc, string_index);
+ ffi_define_function (sc, string_rindex);
+ ffi_define_function_name (sc, "string-contains?", string_contains);
+
+ /* User interface. */
+ ffi_define_function (sc, flush_stdio);
+ ffi_define_function (sc, prompt);
+
+ /* Configuration. */
+ ffi_define_function_name (sc, "*verbose*", get_verbose);
+ ffi_define_function_name (sc, "*set-verbose!*", set_verbose);
+
+ ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0));
+ ffi_define (sc, "*scriptname*", sc->vptr->mk_string (sc, scriptname));
+ for (i = argc - 1; i >= 0; i--)
+ {
+ pointer value = sc->vptr->mk_string (sc, argv[i]);
+ args = (sc->vptr->cons) (sc, value, args);
+ }
+ ffi_define (sc, "*args*", args);
+
+#if _WIN32
+ ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';'));
+#else
+ ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':'));
+#endif
+
+ ffi_define (sc, "*win32*",
+#if _WIN32
+ sc->T
+#else
+ sc->F
+#endif
+ );
+
+ ffi_define (sc, "*maintainer-mode*",
+#if MAINTAINER_MODE
+ sc->T
+#else
+ sc->F
+#endif
+ );
+
+ ffi_define (sc, "*run-all-tests*",
+#if RUN_ALL_TESTS
+ sc->T
+#else
+ sc->F
+#endif
+ );
+
+
+ ffi_define (sc, "*stdin*",
+ sc->vptr->mk_port_from_file (sc, stdin, port_input));
+ ffi_define (sc, "*stdout*",
+ sc->vptr->mk_port_from_file (sc, stdout, port_output));
+ ffi_define (sc, "*stderr*",
+ sc->vptr->mk_port_from_file (sc, stderr, port_output));
+
+ return 0;
+}