diff --git a/ffi.c b/ffi.c index 34e573f..3af3328 100644 --- a/ffi.c +++ b/ffi.c @@ -1,1433 +1,1452 @@ /* 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 . */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #if HAVE_LIBREADLINE #define GNUPG_LIBREADLINE_H_INCLUDED #include #include #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. */ 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, "*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.scm b/tests.scm index 329a31a..a4339ca 100644 --- a/tests.scm +++ b/tests.scm @@ -1,685 +1,685 @@ ;; 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 . ;; 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 (echo . msg) (for-each (lambda (x) (display x) (display " ")) msg) (newline)) (define (info . msg) (apply echo msg) (flush-stdio)) (define (log . msg) (if (> (*verbose*) 0) (apply info msg))) (define (fail . msg) (apply info msg) (exit 1)) (define (skip . msg) (apply 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 . lsts) (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts))) (define (for-each-p' msg proc fmt lst . lsts) (call-with-progress msg (lambda (progress) (apply for-each `(,(lambda args (progress (apply fmt args)) (apply proc args)) ,lst ,@lsts))))) ;; 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))) ;; 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)) (if (> (*verbose*) 2) (begin (echo (stringify what) "returned:" result) (echo (stringify what) "wrote to stdout:" out) (echo (stringify what) "wrote to stderr:" err))) (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-check what) (let ((result (call-with-io what ""))) (if (= 0 (:retcode result)) (:stdout result) (throw (string-append (stringify what) " failed") (:stderr result))))) (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-exists? name) (call-with-input-file name (lambda (port) #t))) (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 (path-join . components) (let loop ((acc #f) (rest (filter (lambda (s) (not (string=? "" s))) components))) (if (null? rest) acc (loop (if (string? acc) (string-append acc "/" (car rest)) (car rest)) (cdr rest))))) (assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz")) (assert (string=? (path-join "" "bar" "baz") "bar/baz")) ;; Is PATH an absolute path? (define (absolute-path? path) (or (char=? #\/ (string-ref path 0)) (and *win32* (char=? #\\ (string-ref path 0))) (and *win32* (char-alphabetic? (string-ref path 0)) (char=? #\: (string-ref path 1)) (or (char=? #\/ (string-ref path 2)) (char=? #\\ (string-ref path 2)))))) ;; Make PATH absolute. (define (canonical-path path) (if (absolute-path? path) path (path-join (getcwd) path))) (define (in-srcdir . names) (canonical-path (apply path-join (cons (getenv "srcdir") names)))) ;; Try to find NAME in PATHS. Returns the full path name on success, ;; or raises an error. (define (path-expand name paths) (let loop ((path paths)) (if (null? path) (throw "Could not find" name "in" paths) (let* ((qualified-name (path-join (car path) name)) (file-exists (call-with-input-file qualified-name (lambda (x) #t)))) (if file-exists qualified-name (loop (cdr path))))))) ;; Expand NAME using the gpgscm load path. Use like this: ;; (load (with-path "library.scm")) (define (with-path name) (catch name (path-expand name (string-split (getenv "GPGSCM_PATH") *pathsep*)))) (define (basename path) (let ((i (string-index path #\/))) (if (equal? i #f) path (basename (substring path (+ 1 i) (string-length path)))))) (define (basename-suffix path suffix) (basename (if (string-suffix? path suffix) (substring path 0 (- (string-length path) (string-length suffix))) path))) ;; Helper for (pipe). (define :read-end car) (define :write-end cadr) ;; let-like macro that manages file descriptors. ;; ;; (letfd ) ;; ;; Bind all variables given in and initialize each of them ;; to the given initial value, and close them after evaluting . (define-macro (letfd bindings . body) (let bind ((bindings' bindings)) (if (null? bindings') `(begin ,@body) (let* ((binding (car bindings')) (name (car binding)) (initializer (cadr binding))) `(let ((,name ,initializer)) (finally (close ,name) ,(bind (cdr bindings')))))))) (define-macro (with-working-directory new-directory . expressions) (let ((new-dir (gensym)) (old-dir (gensym))) `(let* ((,new-dir ,new-directory) (,old-dir (getcwd))) (dynamic-wind (lambda () (if ,new-dir (chdir ,new-dir))) (lambda () ,@expressions) (lambda () (chdir ,old-dir)))))) ;; Make a temporary directory. If arguments are given, they are ;; joined using path-join, and must end in a component ending in ;; "XXXXXX". If no arguments are given, a suitable location and ;; generic name is used. Returns an absolute path. (define (mkdtemp . components) (canonical-path (_mkdtemp (if (null? components) (path-join - (if *win32* (getenv "Temp") "/tmp") + (get-temp-path) (string-append "gpgscm-" (get-isotime) "-" (basename-suffix *scriptname* ".scm") "-XXXXXX")) (apply path-join components))))) (define-macro (with-temporary-working-directory . expressions) (let ((tmp-sym (gensym))) `(let* ((,tmp-sym (mkdtemp))) (finally (unlink-recursively ,tmp-sym) (with-working-directory ,tmp-sym ,@expressions))))) (define (make-temporary-file . args) (canonical-path (path-join (mkdtemp) (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 ) ;; ;; Bind all variables given in , initialize each of them to ;; a string representing an unique path in the filesystem, and delete ;; them after evaluting . (define-macro (lettmp bindings . body) (let bind ((bindings' bindings)) (if (null? bindings') `(begin ,@body) (let ((name (car bindings')) (rest (cdr bindings'))) `(let ((,name (make-temporary-file ,(symbol->string name)))) (finally (remove-temporary-file ,name) ,(bind rest))))))) (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)) (fail "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)) (tmpfiles' (car v)) (sink (cadr v)) (error (caddr v))) (if error (begin (for-each remove-temporary-file tmpfiles') (apply throw error))) (loop tmpfiles' sink (cdr cmds)))))) (define (tr:open pathname) (lambda (tmpfiles source) (list tmpfiles pathname #f))) (define (tr:spawn input command) (lambda (tmpfiles source) (if (and (member '**in** command) (not source)) (fail (string-append (stringify cmd) " needs an input"))) (let* ((t (make-temporary-file)) (cmd (map (lambda (x) (cond ((equal? '**in** x) source) ((equal? '**out** x) t) (else x))) command))) (catch (list (cons t tmpfiles) t *error*) (call-popen cmd input) (if (and (member '**out** command) (not (file-exists? t))) (fail (string-append (stringify cmd) " did not produce '" t "'."))) (list (cons t tmpfiles) t #f))))) (define (tr:write-to pathname) (lambda (tmpfiles source) (rename source pathname) (list tmpfiles pathname #f))) (define (tr:pipe-do . commands) (lambda (tmpfiles source) (let ((t (make-temporary-file))) (apply pipe:do `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '()) ,@commands ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600))) (list (cons t tmpfiles) t #f)))) (define (tr:assert-identity reference) (lambda (tmpfiles source) (if (not (file=? source reference)) (fail "mismatch")) (list tmpfiles source #f))) (define (tr:assert-weak-identity reference) (lambda (tmpfiles source) (if (not (text-file=? source reference)) (fail "mismatch")) (list tmpfiles source #f))) (define (tr:call-with-content function . args) (lambda (tmpfiles source) (catch (list tmpfiles source *error*) (apply function `(,(call-with-input-file source read-all) ,@args))) (list tmpfiles source #f))) ;; ;; Developing and debugging tests. ;; ;; Spawn an os shell. (define (interactive-shell) (call-with-fds `(,(getenv "SHELL") -i) 0 1 2)) ;; ;; The main test framework. ;; ;; A pool of tests. (define test-pool (package (define (new procs) (package (define (add test) (new (cons test procs))) (define (wait) (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) (if (null? unfinished) (package) (let* ((names (map (lambda (t) t::name) unfinished)) (pids (map (lambda (t) t::pid) unfinished)) (results (map (lambda (pid retcode) (list pid retcode)) pids (wait-processes (map stringify names) pids #t)))) (new (map (lambda (t) (if t::retcode t (t::set-retcode (cadr (assoc t::pid results))))) procs)))))) (define (passed) (filter (lambda (p) (= 0 p::retcode)) procs)) (define (skipped) (filter (lambda (p) (= 77 p::retcode)) procs)) (define (hard-errored) (filter (lambda (p) (= 99 p::retcode)) procs)) (define (failed) (filter (lambda (p) (not (or (= 0 p::retcode) (= 77 p::retcode) (= 99 p::retcode)))) procs)) (define (report) (define (print-tests tests message) (unless (null? tests) (apply echo (cons message (map (lambda (t) t::name) tests))))) (let ((failed' (failed)) (skipped' (skipped))) (echo (length procs) "tests run," (length (passed)) "succeeded," (length failed') "failed," (length skipped') "skipped.") (print-tests failed' "Failed tests:") (print-tests skipped' "Skipped tests:") (length failed'))))))) (define (verbosity n) (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) (define (locate-test path) (if (absolute-path? path) path (in-srcdir path))) ;; A single test. (define test (package (define (scm setup name path . args) ;; Start the process. (define (spawn-scm args' in out err) (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*)) ,(locate-test path) ,@(if setup (force setup) '()) ,@args' ,@args) in out err)) (new name #f spawn-scm #f #f CLOSED_FD)) (define (binary setup name path . args) ;; Start the process. (define (spawn-binary args' in out err) (spawn-process-fd `(,path ,@(if setup (force setup) '()) ,@args' ,@args) in out err)) (new name #f spawn-binary #f #f CLOSED_FD)) (define (new name directory spawn pid retcode logfd) (package (define (set-directory x) (new name x spawn pid retcode logfd)) (define (set-retcode x) (new name directory spawn pid x logfd)) (define (set-pid x) (new name directory spawn x retcode logfd)) (define (set-logfd x) (new name directory spawn pid retcode x)) (define (open-log-file) (let ((filename (string-append (basename name) ".log"))) (catch '() (unlink filename)) (open filename (logior O_RDWR O_BINARY O_CREAT) #o600))) (define (run-sync . args) (letfd ((log (open-log-file))) (with-working-directory directory (let* ((p (inbound-pipe)) (pid (spawn args 0 (:write-end p) (:write-end p)))) (close (:write-end p)) (splice (:read-end p) STDERR_FILENO log) (close (:read-end p)) (let ((t' (set-retcode (wait-process name pid #t)))) (t'::report) t'))))) (define (run-sync-quiet . args) (with-working-directory directory (set-retcode (wait-process name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t)))) (define (run-async . args) (let ((log (open-log-file))) (with-working-directory directory (new name directory spawn (spawn args CLOSED_FD log log) retcode log)))) (define (status) (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR"))))) (if (not t) "FAIL" (cadr t)))) (define (report) (unless (= logfd CLOSED_FD) (seek logfd 0 SEEK_SET) (splice logfd STDERR_FILENO) (close logfd)) (echo (string-append (status) ":") name)))))) ;; Run the setup target to create an environment, then run all given ;; tests in parallel. (define (run-tests-parallel tests) (let loop ((pool (test-pool::new '())) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) (for-each (lambda (t) (catch (echo "Removing" t::directory "failed:" *error*) (unlink-recursively t::directory)) (t::report)) (reverse results::procs)) (exit (results::report))) (let* ((wd (mkdtemp)) (test (car tests')) (test' (test::set-directory wd))) (loop (pool::add (test'::run-async)) (cdr tests')))))) ;; Run the setup target to create an environment, then run all given ;; tests in sequence. (define (run-tests-sequential tests) (let loop ((pool (test-pool::new '())) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) (for-each (lambda (t) (catch (echo "Removing" t::directory "failed:" *error*) (unlink-recursively t::directory))) results::procs) (exit (results::report))) (let* ((wd (mkdtemp)) (test (car tests')) (test' (test::set-directory wd))) (loop (pool::add (test'::run-sync)) (cdr tests')))))) ;; Helper to create environment caches from test functions. SETUP ;; must be a test implementing the producer side cache protocol. ;; Returns a promise containing the arguments that must be passed to a ;; test implementing the consumer side of the cache protocol. (define (make-environment-cache setup) (delay (let* ((tarball (make-temporary-file "environment-cache"))) (atexit (lambda () (remove-temporary-file tarball))) (setup::run-sync '--create-tarball tarball) `(--unpack-tarball ,tarball)))) ;; Command line flag handling. Returns the elements following KEY in ;; ARGUMENTS up to the next argument, or #f if KEY is not in ;; ARGUMENTS. (define (flag key arguments) (cond ((null? arguments) #f) ((string=? key (car arguments)) (let loop ((acc '()) (args (cdr arguments))) (if (or (null? args) (string-prefix? (car args) "--")) (reverse acc) (loop (cons (car args) acc) (cdr args))))) ((string=? "--" (car arguments)) #f) (else (flag key (cdr arguments))))) (assert (equal? (flag "--xxx" '("--yyy")) #f)) (assert (equal? (flag "--xxx" '("--xxx")) '())) (assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy"))) (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz"))) (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz"))) (assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy"))) (assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))