diff --git a/ffi.c b/ffi.c index 57de286..0816067 100644 --- a/ffi.c +++ b/ffi.c @@ -1,1312 +1,1325 @@ /* 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 #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" 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); FFI_RETURN_ERR (sc, gnupg_setenv (name, value, overwrite)); } static pointer do_exit (scheme *sc, pointer args) { FFI_PROLOG (); int retcode; FFI_ARG_OR_RETURN (sc, int, retcode, number, args); FFI_ARGS_DONE_OR_RETURN (sc, args); exit (retcode); } /* XXX: use gnupgs variant b/c mode as string */ static pointer do_open (scheme *sc, pointer args) { FFI_PROLOG (); int fd; char *pathname; int flags; mode_t mode = 0; FFI_ARG_OR_RETURN (sc, char *, pathname, path, args); FFI_ARG_OR_RETURN (sc, int, flags, number, args); if (args != sc->NIL) FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args); FFI_ARGS_DONE_OR_RETURN (sc, args); fd = open (pathname, flags, mode); if (fd == -1) FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); FFI_RETURN_INT (sc, fd); } static pointer do_fdopen (scheme *sc, pointer args) { FFI_PROLOG (); FILE *stream; int fd; char *mode; int kind; FFI_ARG_OR_RETURN (sc, int, fd, number, args); FFI_ARG_OR_RETURN (sc, char *, mode, string, args); FFI_ARGS_DONE_OR_RETURN (sc, args); stream = fdopen (fd, mode); if (stream == NULL) FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); if (setvbuf (stream, NULL, _IONBF, 0) != 0) FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); kind = 0; if (strchr (mode, 'r')) kind |= port_input; if (strchr (mode, 'w')) kind |= port_output; FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind)); } static pointer do_close (scheme *sc, pointer args) { FFI_PROLOG (); int fd; FFI_ARG_OR_RETURN (sc, int, fd, number, args); FFI_ARGS_DONE_OR_RETURN (sc, args); FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ()); } static pointer do_mkdtemp (scheme *sc, pointer args) { FFI_PROLOG (); char *template; char buffer[128]; 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); +} + /* estream functions. */ struct es_object_box { estream_t stream; int closed; }; static void es_object_finalize (scheme *sc, void *data) { struct es_object_box *box = data; (void) sc; if (! box->closed) es_fclose (box->stream); xfree (box); } static void es_object_to_string (scheme *sc, char *out, size_t size, void *data) { struct es_object_box *box = data; (void) sc; snprintf (out, size, "#estream %p", box->stream); } static struct foreign_object_vtable es_object_vtable = { es_object_finalize, es_object_to_string, }; static pointer es_wrap (scheme *sc, estream_t stream) { struct es_object_box *box = xmalloc (sizeof *box); if (box == NULL) return sc->NIL; box->stream = stream; box->closed = 0; return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box); } static struct es_object_box * es_unwrap (scheme *sc, pointer object) { (void) sc; if (! is_foreign_object (object)) return NULL; if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable) return NULL; return sc->vptr->get_foreign_object_data (object); } #define CONVERSION_estream(SC, X) es_unwrap (SC, X) #define IS_A_estream(SC, X) es_unwrap (SC, X) static pointer do_es_fclose (scheme *sc, pointer args) { FFI_PROLOG (); struct es_object_box *box; FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); FFI_ARGS_DONE_OR_RETURN (sc, args); err = es_fclose (box->stream); if (! err) box->closed = 1; FFI_RETURN (sc); } static pointer do_es_read (scheme *sc, pointer args) { FFI_PROLOG (); struct es_object_box *box; size_t bytes_to_read; pointer result; void *buffer; size_t bytes_read; FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args); FFI_ARGS_DONE_OR_RETURN (sc, args); buffer = xtrymalloc (bytes_to_read); if (buffer == NULL) FFI_RETURN_ERR (sc, ENOMEM); err = es_read (box->stream, buffer, bytes_to_read, &bytes_read); if (err) FFI_RETURN_ERR (sc, err); result = sc->vptr->mk_counted_string (sc, buffer, bytes_read); xfree (buffer); FFI_RETURN_POINTER (sc, result); } static pointer do_es_feof (scheme *sc, pointer args) { FFI_PROLOG (); struct es_object_box *box; FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); FFI_ARGS_DONE_OR_RETURN (sc, args); FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F); } static pointer do_es_write (scheme *sc, pointer args) { FFI_PROLOG (); struct es_object_box *box; const char *buffer; size_t bytes_to_write, bytes_written; FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); /* XXX how to get the length of the string buffer? scheme strings may contain \0. */ FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args); FFI_ARGS_DONE_OR_RETURN (sc, args); bytes_to_write = strlen (buffer); while (bytes_to_write > 0) { err = es_write (box->stream, buffer, bytes_to_write, &bytes_written); if (err) break; bytes_to_write -= bytes_written; buffer += bytes_written; } FFI_RETURN (sc); } /* Process handling. */ static pointer do_spawn_process (scheme *sc, pointer args) { FFI_PROLOG (); pointer arguments; char **argv; size_t len; unsigned int flags; estream_t infp; estream_t outfp; estream_t errfp; pid_t pid; FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args); FFI_ARGS_DONE_OR_RETURN (sc, args); err = ffi_list2argv (sc, arguments, &argv, &len); if (err == gpg_error (GPG_ERR_INV_VALUE)) return ffi_sprintf (sc, "%luth element of first argument is " "neither string nor symbol", (unsigned long) len); if (err) FFI_RETURN_ERR (sc, err); if (verbose > 1) { char **p; fprintf (stderr, "Executing:"); for (p = argv; *p; p++) fprintf (stderr, " '%s'", *p); fprintf (stderr, "\n"); } err = gnupg_spawn_process (argv[0], (const char **) &argv[1], GPG_ERR_SOURCE_DEFAULT, NULL, flags, &infp, &outfp, &errfp, &pid); xfree (argv); #define IMC(A, B) \ _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) #define IMS(A, B) \ _cons (sc, es_wrap (sc, (A)), (B), 1) FFI_RETURN_POINTER (sc, IMS (infp, IMS (outfp, IMS (errfp, IMC (pid, sc->NIL))))); #undef IMS #undef IMC } static pointer do_spawn_process_fd (scheme *sc, pointer args) { FFI_PROLOG (); pointer arguments; char **argv; size_t len; int infd, outfd, errfd; pid_t pid; FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); FFI_ARG_OR_RETURN (sc, int, infd, number, args); FFI_ARG_OR_RETURN (sc, int, outfd, number, args); FFI_ARG_OR_RETURN (sc, int, errfd, number, args); FFI_ARGS_DONE_OR_RETURN (sc, args); err = ffi_list2argv (sc, arguments, &argv, &len); if (err == gpg_error (GPG_ERR_INV_VALUE)) return ffi_sprintf (sc, "%luth element of first argument is " "neither string nor symbol", (unsigned long) len); if (err) FFI_RETURN_ERR (sc, err); if (verbose > 1) { char **p; fprintf (stderr, "Executing:"); for (p = argv; *p; p++) fprintf (stderr, " '%s'", *p); fprintf (stderr, "\n"); } err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1], infd, outfd, errfd, &pid); xfree (argv); FFI_RETURN_INT (sc, pid); } static pointer do_wait_process (scheme *sc, pointer args) { FFI_PROLOG (); const char *name; pid_t pid; int hang; int retcode; FFI_ARG_OR_RETURN (sc, const char *, name, string, args); FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args); FFI_ARG_OR_RETURN (sc, int, hang, bool, args); FFI_ARGS_DONE_OR_RETURN (sc, args); err = gnupg_wait_process (name, pid, hang, &retcode); if (err == GPG_ERR_GENERAL) err = 0; /* Let the return code speak for itself. */ FFI_RETURN_INT (sc, retcode); } static pointer do_wait_processes (scheme *sc, pointer args) { FFI_PROLOG (); pointer list_names; char **names; pointer list_pids; size_t i, count; pid_t *pids; int hang; int *retcodes; pointer retcodes_list = sc->NIL; FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args); FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args); FFI_ARG_OR_RETURN (sc, int, hang, bool, args); FFI_ARGS_DONE_OR_RETURN (sc, args); if (sc->vptr->list_length (sc, list_names) != sc->vptr->list_length (sc, list_pids)) return sc->vptr->mk_string (sc, "length of first two arguments must match"); err = ffi_list2argv (sc, list_names, &names, &count); if (err == gpg_error (GPG_ERR_INV_VALUE)) return ffi_sprintf (sc, "%luth element of first argument is " "neither string nor symbol", (unsigned long) count); if (err) FFI_RETURN_ERR (sc, err); err = ffi_list2intv (sc, list_pids, (int **) &pids, &count); if (err == gpg_error (GPG_ERR_INV_VALUE)) return ffi_sprintf (sc, "%luth element of second argument is " "neither string nor symbol", (unsigned long) count); if (err) FFI_RETURN_ERR (sc, err); retcodes = xtrycalloc (sizeof *retcodes, count); if (retcodes == NULL) { xfree (names); xfree (pids); FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); } err = gnupg_wait_processes ((const char **) names, pids, count, hang, retcodes); if (err == GPG_ERR_GENERAL) err = 0; /* Let the return codes speak. */ for (i = 0; i < count; i++) retcodes_list = (sc->vptr->cons) (sc, sc->vptr->mk_integer (sc, (long) retcodes[count-1-i]), retcodes_list); 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; int sink; ssize_t len = -1; char buffer[1024]; ssize_t bytes_read; FFI_ARG_OR_RETURN (sc, int, source, number, args); FFI_ARG_OR_RETURN (sc, int, sink, number, args); if (args != sc->NIL) FFI_ARG_OR_RETURN (sc, ssize_t, len, number, args); FFI_ARGS_DONE_OR_RETURN (sc, args); while (len == -1 || len > 0) { size_t want = sizeof buffer; if (len > 0 && (ssize_t) want > len) want = (size_t) len; bytes_read = read (source, buffer, want); if (bytes_read == 0) break; if (bytes_read < 0) FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); if (write (sink, buffer, bytes_read) != bytes_read) FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); if (len != -1) len -= bytes_read; } FFI_RETURN (sc); } 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_glob (scheme *sc, pointer args) { FFI_PROLOG (); pointer result = sc->NIL; size_t i; char *pattern; glob_t pglob; FFI_ARG_OR_RETURN (sc, char *, pattern, string, args); FFI_ARGS_DONE_OR_RETURN (sc, args); switch (glob (pattern, 0, NULL, &pglob)) { case 0: for (i = 0; i < pglob.gl_pathc; i++) result = (sc->vptr->cons) (sc, sc->vptr->mk_string (sc, pglob.gl_pathv[i]), result); globfree (&pglob); break; case GLOB_NOMATCH: /* Return the empty list. */ break; case GLOB_NOSPACE: return ffi_sprintf (sc, "out of memory"); case GLOB_ABORTED: return ffi_sprintf (sc, "read error"); default: assert (! "not reached"); } FFI_RETURN_POINTER (sc, result); } 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, int argc, const char **argv) +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_function (sc, sleep); ffi_define_function (sc, usleep); ffi_define_function (sc, chdir); ffi_define_function (sc, strerror); ffi_define_function (sc, getenv); ffi_define_function (sc, setenv); ffi_define_function (sc, exit); ffi_define_function (sc, open); ffi_define_function (sc, fdopen); ffi_define_function (sc, close); ffi_define_function_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); /* 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); ffi_define_function (sc, glob); /* 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, "*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/ffi.h b/ffi.h index 02dd99d..9bd710f 100644 --- a/ffi.h +++ b/ffi.h @@ -1,30 +1,30 @@ /* FFI interface for TinySCHEME. * * Copyright (C) 2016 g10 code GmbH * * This file is part of GnuPG. * * GnuPG is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 3 of the License, or * (at your option) any later version. * * GnuPG is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, see . */ #ifndef GPGSCM_FFI_H #define GPGSCM_FFI_H #include #include "scheme.h" -gpg_error_t ffi_init (scheme *sc, const char *argv0, +gpg_error_t ffi_init (scheme *sc, const char *argv0, const char *scriptname, int argc, const char **argv); #endif /* GPGSCM_FFI_H */ diff --git a/main.c b/main.c index 02681ff..f7c6b0d 100644 --- a/main.c +++ b/main.c @@ -1,296 +1,297 @@ /* TinyScheme-based test driver. * * Copyright (C) 2016 g10 code GmbH * * This file is part of GnuPG. * * GnuPG is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 3 of the License, or * (at your option) any later version. * * GnuPG is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, see . */ #include #include #include #include #include #include #include #include #include #include #include "private.h" #include "scheme.h" #include "scheme-private.h" #include "ffi.h" #include "i18n.h" #include "../../common/argparse.h" #include "../../common/init.h" #include "../../common/logging.h" #include "../../common/strlist.h" #include "../../common/sysutils.h" #include "../../common/util.h" /* The TinyScheme banner. Unfortunately, it isn't in the header file. */ #define ts_banner "TinyScheme 1.41" int verbose; /* Constants to identify the commands and options. */ enum cmd_and_opt_values { aNull = 0, oVerbose = 'v', }; /* The list of commands and options. */ static ARGPARSE_OPTS opts[] = { ARGPARSE_s_n (oVerbose, "verbose", N_("verbose")), ARGPARSE_end (), }; char *scmpath = ""; size_t scmpath_len = 0; /* Command line parsing. */ static void parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts) { int no_more_options = 0; while (!no_more_options && optfile_parse (NULL, NULL, NULL, pargs, popts)) { switch (pargs->r_opt) { case oVerbose: verbose++; break; default: pargs->err = 2; break; } } } /* Print usage information and and provide strings for help. */ static const char * my_strusage( int level ) { const char *p; switch (level) { case 11: p = "gpgscm (@GNUPG@)"; break; case 13: p = VERSION; break; case 17: p = PRINTABLE_OS_NAME; break; case 19: p = _("Please report bugs to <@EMAIL@>.\n"); break; case 1: case 40: p = _("Usage: gpgscm [options] [file] (-h for help)"); break; case 41: p = _("Syntax: gpgscm [options] [file]\n" "Execute the given Scheme program, or spawn interactive shell.\n"); break; default: p = NULL; break; } return p; } /* Load the Scheme program from FILE_NAME. If FILE_NAME is not an absolute path, and LOOKUP_IN_PATH is given, then it is qualified with the values in scmpath until the file is found. */ static gpg_error_t load (scheme *sc, char *file_name, int lookup_in_cwd, int lookup_in_path) { gpg_error_t err = 0; size_t n; const char *directory; char *qualified_name = file_name; int use_path; FILE *h = NULL; use_path = lookup_in_path && ! (file_name[0] == '/' || scmpath_len == 0); if (file_name[0] == '/' || lookup_in_cwd || scmpath_len == 0) { h = fopen (file_name, "r"); if (! h) err = gpg_error_from_syserror (); } if (h == NULL && use_path) for (directory = scmpath, n = scmpath_len; n; directory += strlen (directory) + 1, n--) { if (asprintf (&qualified_name, "%s/%s", directory, file_name) < 0) return gpg_error_from_syserror (); h = fopen (qualified_name, "r"); if (h) break; if (n > 1) { free (qualified_name); continue; /* Try again! */ } err = gpg_error_from_syserror (); } if (h == NULL) { /* Failed and no more elements in scmpath to try. */ fprintf (stderr, "Could not read %s: %s.\n", qualified_name, gpg_strerror (err)); if (lookup_in_path) fprintf (stderr, "Consider using GPGSCM_PATH to specify the location " "of the Scheme library.\n"); return err; } if (verbose > 1) fprintf (stderr, "Loading %s...\n", qualified_name); scheme_load_named_file (sc, h, qualified_name); fclose (h); if (sc->retcode) { if (sc->nesting) fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name); return gpg_error (GPG_ERR_GENERAL); } if (file_name != qualified_name) free (qualified_name); return 0; } int main (int argc, char **argv) { gpg_error_t err; char *argv0; ARGPARSE_ARGS pargs; scheme *sc; char *p; #if _WIN32 char pathsep = ';'; #else char pathsep = ':'; #endif char *script = NULL; /* Save argv[0] so that we can re-exec. */ argv0 = argv[0]; /* Parse path. */ if (getenv ("GPGSCM_PATH")) scmpath = getenv ("GPGSCM_PATH"); p = scmpath = strdup (scmpath); if (p == NULL) return 2; if (*p) scmpath_len++; for (; *p; p++) if (*p == pathsep) *p = 0, scmpath_len++; set_strusage (my_strusage); log_set_prefix ("gpgscm", GPGRT_LOG_WITH_PREFIX); /* Make sure that our subsystems are ready. */ i18n_init (); init_common_subsystems (&argc, &argv); if (!gcry_check_version (NEED_LIBGCRYPT_VERSION)) { fputs ("libgcrypt version mismatch\n", stderr); exit (2); } /* Parse the command line. */ pargs.argc = &argc; pargs.argv = &argv; pargs.flags = 0; parse_arguments (&pargs, opts); if (log_get_errorcount (0)) exit (2); sc = scheme_init_new_custom_alloc (gcry_malloc, gcry_free); if (! sc) { fprintf (stderr, "Could not initialize TinyScheme!\n"); return 2; } scheme_set_input_port_file (sc, stdin); scheme_set_output_port_file (sc, stderr); if (argc) { script = argv[0]; argc--, argv++; } err = load (sc, "init.scm", 0, 1); if (! err) err = load (sc, "ffi.scm", 0, 1); if (! err) - err = ffi_init (sc, argv0, argc, (const char **) argv); + err = ffi_init (sc, argv0, script ? script : "interactive", + argc, (const char **) argv); if (! err) err = load (sc, "lib.scm", 0, 1); if (! err) err = load (sc, "repl.scm", 0, 1); if (! err) err = load (sc, "tests.scm", 0, 1); if (err) { fprintf (stderr, "Error initializing gpgscm: %s.\n", gpg_strerror (err)); exit (2); } if (script == NULL) { /* Interactive shell. */ fprintf (stderr, "gpgscm/"ts_banner".\n"); scheme_load_string (sc, "(interactive-repl)"); } else { err = load (sc, script, 1, 1); if (err) log_fatal ("%s: %s", script, gpg_strerror (err)); } scheme_deinit (sc); xfree (sc); return EXIT_SUCCESS; } diff --git a/tests.scm b/tests.scm index 8283eba..0738bc6 100644 --- a/tests.scm +++ b/tests.scm @@ -1,465 +1,468 @@ ;; 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 (error . 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) (for-each-p' msg proc (lambda (x) x) lst)) (define (for-each-p' msg proc fmt lst) (call-with-progress msg (lambda (progress) (for-each (lambda (a) (progress (fmt a)) (proc a)) lst)))) ;; Process management. (define CLOSED_FD -1) (define (call-with-fds what infd outfd errfd) (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t)) (define (call what) (call-with-fds what CLOSED_FD (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD) (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD))) ;; 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 (list 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")) (define (canonical-path path) (if (char=? #\/ (string-ref path 0)) path (string-append (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 (string-append (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 . (macro (letfd form) (let ((result-sym (gensym))) `((lambda (,(caaadr form)) (let ((,result-sym ,(if (= 1 (length (cadr form))) `(begin ,@(cddr form)) `(letfd ,(cdadr form) ,@(cddr form))))) (close ,(caaadr form)) ,result-sym)) ,@(cdaadr form)))) (macro (with-working-directory form) (let ((result-sym (gensym)) (cwd-sym (gensym))) `(let* ((,cwd-sym (getcwd)) (_ (if ,(cadr form) (chdir ,(cadr form)))) (,result-sym (begin ,@(cddr form)))) (chdir ,cwd-sym) ,result-sym))) ;; 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. (define (mkdtemp . components) (_mkdtemp (if (null? components) - (path-join (getenv "TMP") "gpgscm-XXXXXX") + (path-join (getenv "TMP") + (string-append "gpgscm-" (get-isotime) "-" + (basename-suffix *scriptname* ".scm") + "-XXXXXX")) (apply path-join components)))) (macro (with-temporary-working-directory form) (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym))) `(let* ((,cwd-sym (getcwd)) (,tmp-sym (mkdtemp)) (_ (chdir ,tmp-sym)) (,result-sym (begin ,@(cdr form)))) (chdir ,cwd-sym) (unlink-recursively ,tmp-sym) ,result-sym))) (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 . (macro (lettmp form) (let ((result-sym (gensym))) `((lambda (,(caadr form)) (let ((,result-sym ,(if (= 1 (length (cadr form))) `(begin ,@(cddr form)) `(lettmp ,(cdadr form) ,@(cddr form))))) (remove-temporary-file ,(caadr form)) ,result-sym)) (make-temporary-file ,(symbol->string (caadr form)))))) (define (check-execution source transformer) (lettmp (sink) (transformer source sink))) (define (check-identity source transformer) (lettmp (sink) (transformer source sink) (if (not (file=? source sink)) (error "mismatch")))) ;; ;; Monadic pipe support. ;; (define pipeM (package (define (new procs source sink producer) (package (define (dump) (write (list procs source sink producer)) (newline)) (define (add-proc command pid) (new (cons (list command pid) procs) source sink producer)) (define (commands) (map car procs)) (define (pids) (map cadr procs)) (define (set-source source') (new procs source' sink producer)) (define (set-sink sink') (new procs source sink' producer)) (define (set-producer producer') (if producer (throw "producer already set")) (new procs source sink producer')))))) (define (pipe:do . commands) (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands)) (if (null? cmds) (begin (if M::producer (M::producer)) (if (not (null? M::procs)) (let* ((retcodes (wait-processes (map stringify (M::commands)) (M::pids) #t)) (results (map (lambda (p r) (append p (list r))) M::procs retcodes)) (failed (filter (lambda (x) (not (= 0 (caddr x)))) results))) (if (not (null? failed)) (throw failed))))) ; xxx nicer reporting (if (and (= 2 (length cmds)) (number? (cadr cmds))) ;; hack: if it's an fd, use it as sink (let ((M' ((car cmds) (M::set-sink (cadr cmds))))) (if (> M::source 2) (close M::source)) (if (> (cadr cmds) 2) (close (cadr cmds))) (loop M' '())) (let ((M' ((car cmds) M))) (if (> M::source 2) (close M::source)) (loop M' (cdr cmds))))))) (define (pipe:open pathname flags) (lambda (M) (M::set-source (open pathname flags)))) (define (pipe:defer producer) (lambda (M) (let* ((p (outbound-pipe)) (M' (M::set-source (:read-end p)))) (M'::set-producer (lambda () (producer (:write-end p)) (close (:write-end p))))))) (define (pipe:echo data) (pipe:defer (lambda (sink) (display data (fdopen sink "wb"))))) (define (pipe:spawn command) (lambda (M) (define (do-spawn M new-source) (let ((pid (spawn-process-fd command M::source M::sink (if (> (*verbose*) 0) STDERR_FILENO CLOSED_FD))) (M' (M::set-source new-source))) (M'::add-proc command pid))) (if (= CLOSED_FD M::sink) (let* ((p (pipe)) (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p)))) (close (:write-end p)) (M'::set-sink CLOSED_FD)) (do-spawn M CLOSED_FD)))) (define (pipe:splice sink) (lambda (M) (splice M::source sink) (M::set-source CLOSED_FD))) (define (pipe:write-to pathname flags mode) (open pathname flags mode)) ;; ;; Monadic transformer support. ;; (define (tr:do . commands) (let loop ((tmpfiles '()) (source #f) (cmds commands)) (if (null? cmds) (for-each remove-temporary-file tmpfiles) (let* ((v ((car cmds) tmpfiles source)) (tmpfiles' (car v)) (sink (cadr v)) (error (caddr v))) (if error (begin (for-each remove-temporary-file tmpfiles') (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)) (error (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))) (error (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)) (error "mismatch")) (list tmpfiles source #f))) (define (tr:assert-weak-identity reference) (lambda (tmpfiles source) (if (not (text-file=? source reference)) (error "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)))