diff options
Diffstat (limited to '')
| -rw-r--r-- | tests/gpgscm/ffi.c | 1470 |
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; +} |