dump-runlisp-image.c (finish_job): Prevent fresh images from junking!

[runlisp] / dump-runlisp-image.c

/* -*-c-*-
 *
 * Dump custom Lisp images for faster script execution
 *
 * (c) 2020 Mark Wooding
 */

/*----- Licensing notice --------------------------------------------------*
 *
 * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
 *
 * Runlisp 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.
 *
 * Runlisp 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 Runlisp.  If not, see <https://www.gnu.org/licenses/>.
 */

/*----- Header files ------------------------------------------------------*/

#include "config.h"

#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <signal.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>

#include <dirent.h>
#include <fcntl.h>
#include <unistd.h>

#include <sys/select.h>
#include <sys/stat.h>
#include <sys/time.h>
#include <sys/uio.h>
#include <sys/wait.h>

#include "common.h"
#include "lib.h"
#include "mdwopt.h"
#include "sha256.h"

/*----- Static data -------------------------------------------------------*/

/* The state required to break an output stream from a subprocess into lines
 * so we can prefix them appropriately.  Once our process starts, the `buf'
 * points to a buffer of `MAXLINE' bytes.  This is arranged as a circular
 * buffer, containing `len' bytes starting at offset `off', and wrapping
 * around to the start of the buffer if it runs off the end.
 *
 * The descriptor `fd' is reset to -1 after it's seen end-of-file.
 */
struct linebuf {
  int fd;				/* our file descriptor (or -1) */
  char *buf;				/* line buffer, or null */
  unsigned off, len;			/* offset */
};
#define MAXLINE 16384u			/* maximum acceptable line length */

/* Job-state constants. */
enum {
  JST_INTERN,				/* not that kind of job */
  JST_VERSION,				/* hashing the Lisp version number */
  JST_DUMP,				/* dumping the custom image */
  JST_NSTATE
};

/* The state associated with an image-dumping job. */
struct job {
  struct treap_node _node;		/* treap intrusion */
  struct job *next;			/* next job in whichever list */
  unsigned st;				/* job state (`JST_...') */
  struct config_section *sect;		/* the system-definition section */
  struct config_var *dumpvar;		/* the `dump-image' variable */
  struct argv av_version, av_dump;	/* argument vectors to execute */
  char *imgnew, *imghash, *imgnewlink, *imglink; /* link and final outputs */
  char *oldimg;				/* old image name */
  FILE *log;				/* log output file (`stdout'?) */
  pid_t kid;				/* process id of child (or -1) */
  int exit;				/* exit status from child */
  struct sha256_state h;		/* hash context for version */
  struct linebuf out, err;		/* line buffers for stdout, stderr */
};
#define JOB_NAME(job) TREAP_NODE_KEY(job)
#define JOB_NAMELEN(job) TREAP_NODE_KEYLEN(job)

static struct treap jobs = TREAP_INIT,	/* Lisp systems seen so far */
  good = TREAP_INIT;			/* files ok to be in image dir */
static struct job			/* lists of jobs */
  *job_ready, **job_ready_tail = &job_ready, /* queue of jobs to start */
  *job_delete, **job_delete_tail = &job_delete, /* queue of delete jobs */
  *job_run;				/* list of active jobs */
static unsigned nrun, maxrun = 1;	/* running and maximum job counts */
static int rc = 0;			/* code that we should return */
static int nullfd;			/* file descriptor for `/dev/null' */
static const char *tmpdir;		/* temporary directory path */

static int sig_pipe[2] = { -1, -1 };	/* pipe for reporting signals */
static sigset_t caught, pending;	/* signals we catch; have caught */
static int sigloss = -1;		/* signal that caused us to lose */

static unsigned flags = 0;		/* flags for the application */
#define AF_BOGUS 0x0001u		/*   invalid comand-line syntax */
#define AF_SETCONF 0x0002u		/*   explicit configuration */
#define AF_DRYRUN 0x0004u		/*   don't actually do it */
#define AF_ALL 0x0008u			/*   dump all known Lisps */
#define AF_FORCE 0x0010u		/*   dump even if images exist */
#define AF_CHECKINST 0x0020u		/*   check Lisp exists before dump */
#define AF_REMOVE 0x0040u		/*   remove selected Lisp images */
#define AF_CLEAN 0x0080u		/*   remove other Lisp images */
#define AF_JUNK 0x0100u			/*   remove unrecognized files */

/*----- Miscellany --------------------------------------------------------*/

/* Report a (printf(3)-style) message MSG, and remember to fail later. */
static PRINTF_LIKE(1, 2) void bad(const char *msg, ...)
  { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); rc = 127; }

/* Answer whether a string consists entirely of hex digits. */
static int hex_digits_p(const char *p, size_t sz)
{
  const char *l;

  for (l = p + sz; p < l; p++) if (!ISXDIGIT(*p)) return (0);
  return (1);
}

/*----- File utilities ----------------------------------------------------*/

/* Main recursive subroutine for `recursive_delete'.
 *
 * The string DD currently contains the pathname of a directory, without a
 * trailing `/' (though there is /space/ for a terminating zero or whatever).
 * Recursively delete all of the files and directories within it.  Appending
 * further text to DD is OK, but clobbering the characters which are there
 * already isn't allowed.
 */
static void recursive_delete_(struct dstr *dd)
{
  DIR *dir;
  struct dirent *d;
  size_t n = dd->len;

  /* Open the directory. */
  dd->p[n] = 0; dir = opendir(dd->p);
  if (!dir)
    lose("failed to open directory `%s' for cleanup: %s",
	 dd->p, strerror(errno));

  /* We'll need to build pathnames for the files inside the directory, so add
   * the separating `/' character.  Remember the length of this prefix
   * because this is the point we'll be rewinding to for each filename we
   * find.
   */
  dd->p[n++] = '/';

  /* Now go through each file in turn. */
  for (;;) {

    /* Get a filename.  If we've run out then we're done.  Skip the special
     * `.' and `..' entries.
     */
    d = readdir(dir); if (!d) break;
    if (d->d_name[0] == '.' && (!d->d_name[1] ||
				(d->d_name[1] == '.' && !d->d_name[2])))
      continue;

    /* Rewind the string offset and append the new filename. */
    dd->len = n; dstr_puts(dd, d->d_name);

    /* Try to delete it the usual way.  If it was actually a directory then
     * recursively delete it instead.  (We could lstat(2) it first, but this
     * should be at least as quick to identify a directory, and it'll save a
     * lstat(2) call in the (common) case that it's not a directory.
     */
    if (!unlink(dd->p));
    else if (errno == EISDIR) recursive_delete_(dd);
    else lose("failed to delete file `%s': %s", dd->p, strerror(errno));
  }

  /* We're done.  Try to delete the directory.  (It's possible that there was
   * some problem with enumerating the directory, but we'll ignore that: if
   * it matters then the directory won't be empty and the rmdir(2) will
   * fail.)
   */
  closedir(dir);
  dd->p[--n] = 0;
  if (rmdir(dd->p))
    lose("failed to delete directory `%s': %s", dd->p, strerror(errno));
}

/* Recursively delete the thing named PATH. */
static void recursive_delete(const char *path)
{
  struct dstr d = DSTR_INIT;
  dstr_puts(&d, path); recursive_delete_(&d); dstr_release(&d);
}

/* Configure a file descriptor FD.
 *
 * Set its nonblocking state to NONBLOCK and close-on-exec state to CLOEXEC.
 * In both cases, -1 means to leave it alone, zero means to turn it off, and
 * any other nonzero value means to turn it on.
 */
static int configure_fd(const char *what, int fd, int nonblock, int cloexec)
{
  int fl, nfl;

  if (nonblock != -1) {
    fl = fcntl(fd, F_GETFL); if (fl < 0) goto fail;
    if (nonblock) nfl = fl | O_NONBLOCK;
    else nfl = fl&~O_NONBLOCK;
    if (fl != nfl && fcntl(fd, F_SETFL, nfl)) goto fail;
  }

  if (cloexec != -1) {
    fl = fcntl(fd, F_GETFD); if (fl < 0) goto fail;
    if (cloexec) nfl = fl | FD_CLOEXEC;
    else nfl = fl&~FD_CLOEXEC;
    if (fl != nfl && fcntl(fd, F_SETFD, nfl)) goto fail;
  }

  return (0);

fail:
  bad("failed to configure %s descriptor: %s", what, strerror(errno));
  return (-1);
}

/* Create a temporary directory and remember where we put it. */
static void set_tmpdir(void)
{
  struct dstr d = DSTR_INIT;
  size_t n;
  unsigned i;

  /* Start building the path name.  Remember the length: we'll rewind to
   * here and try again if our first attempt doesn't work.
   */
  dstr_putf(&d, "%s/runlisp.%d.", my_getenv("TMPDIR", "/tmp"), getpid());
  i = 0; n = d.len;

  /* Keep trying until it works. */
  for (;;) {

    /* Build a complete name. */
    d.len = n; dstr_putf(&d, "%d", rand());

    /* Try to create the directory.  If it worked, we're done.  If it failed
     * with `EEXIST' then we'll try again for a while, but give up it it
     * doesn't look like we're making any progress.  If it failed for some
     * other reason then there's probably not much hope so give up.
     */
    if (!mkdir(d.p, 0700)) break;
    else if (errno != EEXIST)
      lose("failed to create temporary directory `%s': %s",
	   d.p, strerror(errno));
    else if (++i >= 32) {
      d.len = n; dstr_puts(&d, "???");
      lose("failed to create temporary directory `%s': too many attempts",
	   d.p);
    }
  }

  /* Remember the directory name. */
  tmpdir = xstrndup(d.p, d.len); dstr_release(&d);
}

/*----- Signal handling ---------------------------------------------------*/

/* Forward reference into job management. */
static void reap_children(void);

/* Clean things up on exit.
 *
 * Currently this just means to delete the temporary directory if we've made
 * one.
 */
static void cleanup(void)
  { if (tmpdir) { recursive_delete(tmpdir); tmpdir = 0; } }

/* Check to see whether any signals have arrived, and do the sensible thing
 * with them.
 */
static void check_signals(void)
{
  sigset_t old, pend;
  char buf[32];
  ssize_t n;

  /* Ensure exclusive access to the signal-handling machinery, drain the
   * signal pipe, and take a copy of the set of caught signals.
   */
  sigprocmask(SIG_BLOCK, &caught, &old);
  pend = pending; sigemptyset(&pending);
  for (;;) {
    n = read(sig_pipe[0], buf, sizeof(buf));
    if (!n) lose("(internal) signal pipe closed!");
    if (n < 0) break;
  }
  if (errno != EAGAIN && errno != EWOULDBLOCK)
    lose("failed to read signal pipe: %s", strerror(errno));
  sigprocmask(SIG_SETMASK, &old, 0);

  /* Check for each signal of interest to us.
   *
   * Interrupty signals just set `sigloss' -- the `run_jobs' loop will know
   * to unravel everything if this happens.  If `SIGCHLD' happened, then
   * check on job process status.
   */
  if (sigismember(&pend, SIGINT)) sigloss = SIGINT;
  else if (sigismember(&pend, SIGHUP)) sigloss = SIGHUP;
  else if (sigismember(&pend, SIGTERM)) sigloss = SIGTERM;
  if (sigismember(&pend, SIGCHLD)) reap_children();
}

/* The actual signal handler.
 *
 * Set the appropriate signal bit in `pending', and a byte (of any value)
 * down the signal pipe to wake up the select(2) loop.
 */
static void handle_signal(int sig)
{
  sigset_t old;
  char x = '!';

  /* Ensure exclusive access while we fiddle with the `caught' set. */
  sigprocmask(SIG_BLOCK, &caught, &old);
  sigaddset(&pending, sig);
  sigprocmask(SIG_SETMASK, &old, 0);

  /* Wake up the select(2) loop.  If this fails, there's not a lot we can do
   * about it.
   */
  DISCARD(write(sig_pipe[1], &x, 1));
}

/* Install our signal handler to catch SIG.
 *
 * If `SIGF_IGNOK' is set in F then don't trap the signal if it's currently
 * ignored.  (This is used for signals like `SIGINT', which usually should
 * interrupt us; but if the caller wants us to ignore them, we should do as
 * it wants.)
 *
 * WHAT describes the signal, for use in diagnostic messages.
 */
#define SIGF_IGNOK 1u
static void set_signal_handler(const char *what, int sig, unsigned f)
{
  struct sigaction sa, sa_old;

  sigaddset(&caught, sig);

  if (f&SIGF_IGNOK) {
    if (sigaction(sig, 0, &sa_old)) goto fail;
    if (sa_old.sa_handler == SIG_IGN) return;
  }

  sa.sa_handler = handle_signal;
  sigemptyset(&sa.sa_mask);
  sa.sa_flags = SA_NOCLDSTOP;
  if (sigaction(sig, &sa, 0)) goto fail;

  return;

fail:
  lose("failed to set %s signal handler: %s", what, strerror(errno));
}

/*----- Line buffering ----------------------------------------------------*/

/* Find the next newline in the line buffer BUF.
 *
 * The search starts at `BUF->off', and potentially covers the entire buffer
 * contents.  Set *LINESZ_OUT to the length of the line, in bytes.  (Callers
 * must beware that the text of the line may wrap around the ends of the
 * buffer.)  Return zero if we found a newline, or nonzero if the search
 * failed.
 */
static int find_newline(struct linebuf *buf, size_t *linesz_out)
{
  char *nl;

  if (buf->off + buf->len <= MAXLINE) {
    /* The buffer contents is in one piece.  Just search it. */

    nl = memchr(buf->buf + buf->off, '\n', buf->len);
    if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); }

  } else {
    /* The buffer contents is in two pieces.  We must search both of them. */

    nl = memchr(buf->buf + buf->off, '\n', MAXLINE - buf->off);
    if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); }
    nl = memchr(buf->buf, '\n', buf->len - (MAXLINE - buf->off));
    if (nl)
      { *linesz_out = (nl - buf->buf) + (MAXLINE - buf->off); return (0); }
  }

  return (-1);
}

/* Write a completed line out to the JOB's log file.
 *
 * The line starts at BUF->off, and continues for N bytes, not including the
 * newline (which, in fact, might not exist at all).  Precede the actual text
 * of the line with the JOB's name, and the MARKER character, and follow it
 * with the TAIL text (which should include an actual newline character).
 */
static void write_line(struct job *job, struct linebuf *buf,
		       size_t n, char marker, const char *tail)
{
  fprintf(job->log, "%-13s %c ", JOB_NAME(job), marker);
  if (buf->off + n <= MAXLINE)
    fwrite(buf->buf + buf->off, 1, n, job->log);
  else {
    fwrite(buf->buf + buf->off, 1, MAXLINE - buf->off, job->log);
    fwrite(buf->buf, 1, n - (MAXLINE - buf->off), job->log);
  }
  fputs(tail, job->log);
}

/* Hash N bytes freshly added to the buffer BUF. */
static void hash_input(struct linebuf *buf, size_t n, struct sha256_state *h)
{
  size_t start = (buf->off + buf->len)%MAXLINE;

  if (start + n <= MAXLINE)
    sha256_hash(h, buf->buf + start, n);
  else {
    sha256_hash(h, buf->buf + start, MAXLINE - start);
    sha256_hash(h, buf->buf, n - (MAXLINE - start));
  }
}

/* Collect output lines from JOB's process and write them to the log.
 *
 * Read data from BUF's file descriptor.  Output complete (or overlong) lines
 * usng `write_line'.  On end-of-file, output any final incomplete line in
 * the same way, close the descriptor, and set it to -1.
 *
 * As a rather unpleasant quirk, if the hash-state pointer H is not null,
 * then also feed all the data received into it.
 */
static void prefix_lines(struct job *job, struct linebuf *buf, char marker,
			 struct sha256_state *h)
{
  struct iovec iov[2]; int niov;
  ssize_t n;
  size_t linesz;

  /* Read data into the buffer.  This fancy dance with readv(2) is probably
   * overkill.
   *
   * We can't have BUF->len = MAXLINE because we'd have flushed out a
   * maximum-length buffer as an incomplete line last time.
   */
  assert(buf->len < MAXLINE);
  if (!buf->off) {
    iov[0].iov_base = buf->buf + buf->len;
    iov[0].iov_len = MAXLINE - buf->len;
    niov = 1;
  } else if (buf->off + buf->len >= MAXLINE) {
    iov[0].iov_base = buf->buf + buf->off + buf->len - MAXLINE;
    iov[0].iov_len = MAXLINE - buf->len;
    niov = 1;
  } else {
    iov[0].iov_base = buf->buf + buf->off + buf->len;
    iov[0].iov_len = MAXLINE - (buf->off + buf->len);
    iov[1].iov_base = buf->buf;
    iov[1].iov_len = buf->off;
    niov = 1;
  }
  n = readv(buf->fd, iov, niov);

  if (n < 0) {
    /* An error occurred.  If there's no data to read after all then just
     * move on.  Otherwise we have a problem.
     */

    if (errno == EAGAIN || errno == EWOULDBLOCK) return;
    lose("failed to read job `%s' output stream: %s",
	 JOB_NAME(job), strerror(errno));
  } else if (!n) {
    /* We've hit end-of-file.  Close the stream, and write out any
     * unterminated partial line.
     */

    close(buf->fd); buf->fd = -1;
    if (buf->len)
      write_line(job, buf, buf->len, marker, " [missing final newline]\n");
  } else {
    /* We read some fresh data.  Output any new complete lines. */

    /* If we're supposed to hash data as it comes in then we should do that
     * now.
     */
    if (h) hash_input(buf, n, h);

    /* Include the new material in the buffer length, and write out any
     * complete lines we find.
     */
    buf->len += n;
    while (!find_newline(buf, &linesz)) {
      write_line(job, buf, linesz, marker, "\n");
      buf->len -= linesz + 1;
      buf->off += linesz + 1; if (buf->off >= MAXLINE) buf->off -= MAXLINE;
    }

    if (!buf->len)
      /* If there's nothing left then we might as well reset the buffer
       * offset to the start of the buffer.
       */
      buf->off = 0;
    else if (buf->len == MAXLINE) {
      /* We've filled the buffer with stuff that's not a whole line.  Flush
       * it out anyway.
       */
      write_line(job, buf, MAXLINE, marker, " [...]\n");
      buf->off = buf->len = 0;
    }
  }
}

/*----- Job management ----------------------------------------------------*/

/* Record the SZ-byte leafname at P as being legitimate, so that it doesn't
 * get junked.
 */
static void notice_filename(const char *p, size_t sz)
{
  struct treap_node *node;
  struct treap_path path;

  node = treap_probe(&good, p, sz, &path);
  if (!node) {
    node = xmalloc(sizeof(*node));
    treap_insert(&good, &path, node, p, sz);
  }
}

/* There are basically two kinds of jobs.
 *
 * An `internal' job -- state `JST_INTERN' -- can be handled entirely within
 * this process.  Internal jobs have trivial lifecycles: they're created, put
 * on a queue, executed, and thrown away.  Jobs are executed when some code
 * decides to walk the appropriate queue and do the work.  As a result, they
 * don't need to have distinctive states: `JST_INTERN' only exists to
 * distinguish internal jobs from active ones if they somehow manage to end
 * up in the external-job machinery.
 *
 * External jobs all work in basically the same way: we fork and exec a
 * sequence of subprocess to do the work.  The majority of handling external
 * jobs is in the care and feeding of these subprocesses, so they end up on
 * various lists primarily concerned with the state of the subprocesses, and
 * the progress of the job through its sequence of subprocesses is recorded
 * in the job's `st' field.
 *
 * External jobs have a comparatively complicated lifecycle.
 *
 *   * Initially, the job is on the `ready' queue by `add_job'.  It has no
 *     child process or log file.
 *
 *   * At some point, `start_jobs' decides to start this job up: a log file
 *     is created (if the job doesn't have one already), a child process is
 *     forked, and pipes are set up to capture the child's output.  It gets
 *     moved to the `run' list (which is not maintained in any particular
 *     order).  Jobs on the `run' list participate in the main select(2)
 *     loop.
 *
 *   * When the job's child process dies and the pipes capturing its output
 *     streams finally dry up, the job is considered finished.  What happens
 *     next depends on its state: either it gets updated somehow, and pushed
 *     back onto the end of the `ready' queue so that another child can be
 *     started, or the job is finished and dies.
 *
 * The counter `nrun' counts the number of actually running jobs, i.e., those
 * with living child processes.  This doesn't simply count the number of jobs
 * on the `run' list: remember that the latter also contains jobs whose child
 * has died, but whose output has not yet been collected.
 */

/* Consider a Lisp system description and maybe add a job to the right queue.
 *
 * The Lisp system is described by the configuration section SECT.  Most of
 * the function is spent on inspecting this section for suitability and
 * deciding what to do about it.
 *
 * The precise behaviour depends on F, which should be the bitwise-OR of a
 * `JQ_...' constant and zero or more flags, as follows.
 *
 *   * The bits covered by `JMASK_QUEUE' identify which queue the job should
 *     be added to if the section defines a cromulent Lisp system:
 *
 *       -- `JQ_NONE' -- don't actually make a job at all;
 *       -- `JQ_READY' -- add the Lisp to the `job_ready' queue, so we'll; or
 *       -- `JQ_DELETE' -- add the Lisp to the `job_delete' queue.
 *
 *   * `JF_PICKY': The user identified this Lisp system explicitly, so
 *     complain if the configuration section doesn't look right.  This is
 *     clear if the caller is just enumerating all of the configuration
 *     sections: without this feature, we'd be checking everything twice,
 *     which (a) is inefficient, and -- more importantly -- (b) could lead to
 *     problems if the two checks are inconsistent.
 *
 *   * `JF_CHECKINST': Ignore this Lisp if `AF_CHECKINST' is set and it's not
 *     actually installed.  (This is usually set for `JQ_READY' calls, so
 *     that we don't try to dump Lisps which aren't there, but clear for
 *     `JQ_DELETE' calls so that we clear out Lisps which have gone away.)
 *
 *   * `JF_CHECKEXIST': Ignore this Lisp if its image file already exists.
 *
 *   * `JF_NOTICE': Record the Lisp's image basename in the `good' treap so
 *     that we can identify everything else we find in the image directory as
 *     junk.
 */
#define JMASK_QUEUE 3u			/* which queue to add good Lisp to */
#define JQ_NONE 0u			/*   don't add to any queue */
#define JQ_READY 1u			/*   `job_ready' */
#define JQ_DELETE 2u			/*   `job_delete' */
#define JF_PICKY 4u			/* lose if section isn't Lisp defn */
#define JF_CHECKINST 8u			/* maybe check Lisp is installed */
#define JF_CHECKEXIST 16u		/* skip if image already exists */
#define JF_NOTICE 32u			/* record Lisp's image basename */

#define JADD_NAMED (JQ_READY | JF_PICKY | JF_CHECKINST)
#define JADD_DEFAULT (JQ_READY | JF_CHECKINST)
#define JADD_CLEANUP (JQ_DELETE)
#define JADD_NOTICE (JQ_NONE)
static void add_job(unsigned f, struct config_section *sect)
{
  const char *name;
  struct job *job, ***tail;
  struct treap_path jobpath;
  struct config_var *dumpvar, *runvar, *imgvar;
  struct dstr d = DSTR_INIT, dd = DSTR_INIT;
  struct argv av_version = ARGV_INIT, av_dump = ARGV_INIT;
  struct stat st;
  char *imgnewlink = 0, *imglink = 0, *oldimg = 0, *p;
  unsigned jst;
  size_t i, len;
  ssize_t n;
  unsigned fef;

  /* We'll want the section's name for all sorts of things. */
  name = CONFIG_SECTION_NAME(sect);
  len = CONFIG_SECTION_NAMELEN(sect);

  /* Check to see whether this Lisp system is already queued up.
   *
   * We'll get around to adding the new job node to the treap right at the
   * end, so use a separate path object to keep track of where to put it.
   */
  job = treap_probe(&jobs, name, len, &jobpath);
  if (job) {
    if ((f&JF_PICKY) && verbose >= 1)
      moan("ignoring duplicate Lisp `%s'", JOB_NAME(job));
    goto end;
  }

  /* Check that the section defines a Lisp, and that it can be dumped.
   *
   * It's not obvious that this is right.  Maybe there should be some
   * additional flag so that we don't check dumpability if we're planning to
   * delete the image.  But it /is/ right: since the thing which tells us
   * whether we can dump is that the section tells us the image's name, if
   * it can't be dumped then we won't know what file to delete!  So we have
   * no choice.
   */
  runvar = config_find_var(&config, sect, CF_INHERIT, "run-script");
  if (!runvar) {
    if (f&JF_PICKY) lose("unknown Lisp implementation `%s'", name);
    else if (verbose >= 3) moan("skipping non-Lisp section `%s'", name);
    goto end;
  }
  imgvar = config_find_var(&config, sect, CF_INHERIT, "image-file");
  if (!imgvar) {
    if (f&JF_PICKY)
      lose("Lisp implementation `%s' doesn't use custom images", name);
    else if (verbose >= 3)
      moan("skipping Lisp `%s': no custom image support", name);
    goto end;
  }

  /* Check that the other necessary variables are present. */
  dumpvar = config_find_var(&config, sect, CF_INHERIT, "dump-image");
  if (!dumpvar)
    lose("variable `dump-image' not defined for Lisp `%s'", name);

  /* Build the job's command lines. */
  config_subst_split_var(&config, sect, runvar, &av_version);
  if (!av_version.n)
    lose("empty `run-script' command for Lisp implementation `%s'", name);
  argv_append(&av_version,
	      config_subst_string_alloc
		(&config, sect, "<internal>",
		 "?${lisp-version?(lisp-implementation-version)}"));
  config_subst_split_var(&config, sect, dumpvar, &av_dump);
  if (!av_dump.n)
    lose("empty `dump-image' command for Lisp implementation `%s'", name);

  /* If we're supposed to check that the Lisp exists before proceeding then
   * do that.  There are /two/ commands to check: the basic Lisp command,
   * /and/ the command to actually do the dumping, which might not be the
   * same thing.  (Be careful not to check the same command twice, though,
   * because that would cause us to spam the user with redundant
   * diagnostics.)
   */
  if ((f&JF_CHECKINST) && (flags&AF_CHECKINST)) {
    fef = (verbose >= 3 ? FEF_VERBOSE : 0);
    if (!found_in_path_p(av_version.v[0], fef)) {
      if (verbose >= 3)
	moan("skipping Lisp `%s': can't find Lisp command `%s'",
	     name, av_version.v[0]);
      goto end;
    }
    if (STRCMP(av_version.v[0], !=, av_dump.v[0]) &&
	!found_in_path_p(av_dump.v[0], fef)) {
      if (verbose >= 3)
	moan("skipping Lisp `%s': can't find dump command `%s'",
	     av_dump.v[0], d.p);
      goto end;
    }
  }

  /* Collect the output image file names. */
  imglink =
    config_subst_string_alloc(&config, sect, "<internal>", "${@image-link}");
  imgnewlink =
    config_subst_string_alloc(&config, sect,
			      "<internal>", "${@image-newlink}");

  /* Determine the image link basename.  If necessary, record it so that it
   * doesn't get junked.
   */
  dstr_reset(&dd); config_subst_var(&config, sect, imgvar, &dd);
  if (f&JF_NOTICE) notice_filename(dd.p, dd.len);

  /* Fill in the directory name for the output image. */
  dstr_reset(&d);
  p = strrchr(imglink, '/');
  if (p) dstr_putm(&d, imglink, p + 1 - imglink);

  /* Inspect the existing image link if there is one, and record its
   * destination.
   */
  for (;;) {

    /* Read the link destination.  The `lstat'/`readlink' two-step is
     * suggested by the POSIX specification.
     */
    if (lstat(imglink, &st)) {
      if (verbose >= (errno == ENOENT ? 3 : 1))
	moan("failed to read metadata for Lisp `%s' image link `%s': %s",
	     name, imglink, strerror(errno));
      break;
    }
    if (!S_ISLNK(st.st_mode)) {
      if (verbose >= 1)
	moan("Lisp `%s' image link `%s' isn't a symbolic link",
	     name, imglink);
      break;
    }
    dstr_ensure(&d, st.st_size + 1);
    n = readlink(imglink, d.p + d.len, d.sz - d.len);
    if (n < 0) {
	moan("failed to read Lisp `%s' image link `%s': %s",
	     name, imglink, strerror(errno));
      break;
    }
    if (n == d.sz - d.len) continue;

    /* Check that the link has the right form.  (We don't want to delete the
     * referent if it's not actually our image.)
     *
     * We expect the referent to look like ${image-file} followed by a hyphen
     * and some hex digits.
     */
    if (n <= dd.len ||
	STRNCMP(d.p + d.len, !=, dd.p, dd.len) ||
	d.p[d.len + dd.len] != '-' ||
	!hex_digits_p(d.p + (d.len + dd.len + 1), n - (dd.len + 1))) {
      if (verbose >= 1)
	moan("Lisp `%s' image link `%s' has unexpected referent `%s'",
	     name, imglink, d.p);
      break;
    }

    /* OK, so it looks legit.  Protect it from being junked. */
    if (f&JF_NOTICE) notice_filename(d.p + d.len, n);
    d.p[d.len + n] = 0; d.len += n;
    oldimg = xstrndup(d.p, d.len);
    break;
  }

  /* All preflight checks complete.  Build the job and hook it onto the end
   * of the list.  (Steal the command-line vector so that we don't try to
   * free it during cleanup.)
   */
  switch (f&JMASK_QUEUE) {
    case JQ_NONE: jst = JST_INTERN; tail = 0; break;
    case JQ_READY: jst = JST_VERSION; tail = &job_ready_tail; break;
    case JQ_DELETE: jst = JST_INTERN; tail = &job_delete_tail; break;
    default: assert(0);
  }
  job = xmalloc(sizeof(*job));
  job->st = jst; job->sect = sect; job->dumpvar = dumpvar;
  job->kid = -1; job->log = 0;
  job->out.fd = -1; job->out.buf = 0;
  job->err.fd = -1; job->err.buf = 0;
  job->av_version = av_version; argv_init(&av_version);
  argv_init(&job->av_dump);
  job->imgnew = 0; job->imghash = 0;
  job->imgnewlink = imgnewlink; imgnewlink = 0;
  job->imglink = imglink; imglink = 0;
  job->oldimg = oldimg; oldimg = 0;
  treap_insert(&jobs, &jobpath, &job->_node, name, len);
  if (tail) { **tail = job; *tail = &job->next; }

end:
  /* All done.  Cleanup time. */
  for (i = 0; i < av_version.n; i++) free(av_version.v[i]);
  for (i = 0; i < av_dump.n; i++) free(av_dump.v[i]);
  free(imgnewlink); free(imglink); free(oldimg);
  dstr_release(&d); dstr_release(&dd);
  argv_release(&av_version); argv_release(&av_dump);
}

/* As `add_job' above, but look the Lisp implementation up by name.
 *
 * The flags passed to `add_job' are augmented with `JF_PICKY' because this
 * is an explicitly-named Lisp implementation.
 */
static void add_named_job(unsigned f, const char *name, size_t len)
{
  struct config_section *sect;

  sect = config_find_section_n(&config, 0, name, len);
  if (!sect) lose("unknown Lisp implementation `%.*s'", (int)len, name);
  add_job(f | JF_PICKY, sect);
}

/* Free the JOB and all the resources it holds.
 *
 * Close the pipes; kill the child process.  Everything must go.
 */
static void release_job(struct job *job)
{
  size_t i;
  struct job *j;

  if (job->kid > 0) kill(job->kid, SIGKILL); /* ?? */
  if (job->log && job->log != stdout) fclose(job->log);
  free(job->imgnew); free(job->imghash);
  free(job->imglink); free(job->imgnewlink);
  free(job->oldimg);
  for (i = 0; i < job->av_version.n; i++) free(job->av_version.v[i]);
  for (i = 0; i < job->av_dump.n; i++) free(job->av_dump.v[i]);
  argv_release(&job->av_version); argv_release(&job->av_dump);
  free(job->out.buf); if (job->out.fd >= 0) close(job->out.fd);
  free(job->err.buf); if (job->err.fd >= 0) close(job->err.fd);
  j = treap_remove(&jobs, JOB_NAME(job), JOB_NAMELEN(job)); assert(j == job);
  free(job);
}

/* Do all the necessary things when JOB finishes (successfully or not).
 *
 * Eventually the job is either freed (using `release_job'), or updated and
 * stuffed back into the `job_run' queue.  The caller is expected to have
 * already unlinked the job from its current list.
 */
static void finish_job(struct job *job)
{
  char buf[16483], *p;
  unsigned char *hbuf;
  struct dstr d = DSTR_INIT;
  size_t i, n;
  int ok = 0;

  /* Start a final line to the job log describing its eventual fate.
   *
   * This is where we actually pick apart the exit status.  Set `ok' if it
   * actually succeeded, because that's all anything else cares about.
   */
  fprintf(job->log, "%-13s > ", JOB_NAME(job));
  if (WIFEXITED(job->exit)) {
    if (!WEXITSTATUS(job->exit))
      { fputs("completed successfully\n", job->log); ok = 1; }
    else
      fprintf(job->log, "failed with exit status %d\n",
	      WEXITSTATUS(job->exit));
  } else if (WIFSIGNALED(job->exit))
    fprintf(job->log, "killed by signal %d (%s%s)", WTERMSIG(job->exit),
#if defined(HAVE_STRSIGNAL)
	strsignal(WTERMSIG(job->exit)),
#elif defined(HAVE_DECL_SYS_SIGLIST)
	sys_siglist[WTERMSIG(job->exit)],
#else
	"unknown signal",
#endif
#ifdef WCOREDUMP
	WCOREDUMP(job->exit) ? "; core dumped" :
#endif
	"");
  else
    fprintf(job->log, "exited with incomprehensible status %06o\n",
	    job->exit);

  /* What happens next depends on the state of the job.  This is the main
   * place which advances the job state machine.
   */
  if (ok) switch (job->st) {

    case JST_VERSION:
      /* We've retrieved the Lisp system's version string. */

      /* Complete the hashing and convert to hex. */
      hbuf = (unsigned char *)buf + 32; sha256_done(&job->h, hbuf);
      for (i = 0; i < 8; i++) sprintf(buf + 2*i, "%02x", hbuf[i]);
      if (verbose >= 2)
	moan("Lisp `%s' version hash = %s", JOB_NAME(job), buf);

      /* Determine the final version-qualified name for the image. */
      config_set_var(&config, job->sect, CF_LITERAL, "@hash", buf);
      job->imghash =
	config_subst_string_alloc(&config, job->sect,
				  "<internal>", "${@image-out}");
      job->imgnew =
	config_subst_string_alloc(&config, job->sect,
				  "<internal>", "${@image-new}");

      /* Determine the basename of the final image. */
      p = strrchr(job->imghash, '/'); if (p) p++; else p = job->imghash;

      /* Inspect the current link pointer to see if we have the right
       * version.
       */
      if (!(flags&AF_FORCE) &&
	  job->oldimg &&
	  STRCMP(job->oldimg, ==, job->imghash) &&
	  !access(job->oldimg, F_OK)) {
	if (verbose >= 2)
	  moan("Lisp `%s' image `%s' already up-to-date",
	       JOB_NAME(job), job->imghash);
	break;
      }

      /* Make sure that there's a clear space for the new image to be
       * written.
       */
      if (!(flags&AF_DRYRUN) && unlink(job->imgnew) && errno != ENOENT) {
	bad("failed to clear Lisp `%s' image staging path `%s': %s",
	    JOB_NAME(job), job->imgnew, strerror(errno));
	break;
      }

      /* If we're still here then we've decided to dump a new image.  Update
       * the job state, and put it back on the run queue.
       */
      config_subst_split_var(&config, job->sect,
			     job->dumpvar, &job->av_dump);
      assert(job->av_dump.n);
      job->st = JST_DUMP;
      *job_ready_tail = job; job_ready_tail = &job->next; job->next = 0;
      job = 0;
      break;

    case JST_DUMP:
      /* We've finished dumping a custom image.  It's time to apply the
       * finishing touches.
       */

      /* Rename the image into place.  If this fails, blame it on the dump
       * job, because the chances are good that it failed to produce the
       * image properly.
       */
      if (verbose >= 3)
	moan("rename completed Lisp `%s' image `%s' to `%s'",
	     JOB_NAME(job), job->imgnew, job->imghash);
      if (rename(job->imgnew, job->imghash)) {
	fprintf(job->log, "%-13s > failed to rename Lisp `%s' "
			  "output image `%s' to `%s': %s",
		JOB_NAME(job), JOB_NAME(job),
		job->imgnew, job->imghash, strerror(errno));
	ok = 0; break;
      }

      /* Notice the image so that it doesn't get junked. */
      if (flags&AF_JUNK) {
	p = strrchr(job->imghash, '/'); if (p) p++; else p = job->imghash;
	notice_filename(p, strlen(p));
      }

      /* Determine the basename of the final image. */
      p = strrchr(job->imghash, '/'); if (p) p++; else p = job->imghash;

      /* Build the symlink.  Start by setting the link in the staging path,
       * and then rename, in order to ensure continuity.
       */
      if (unlink(job->imgnewlink) && errno != ENOENT) {
	bad("failed to clear Lisp `%s' link staging path `%s': %s",
	    JOB_NAME(job), job->imgnewlink, strerror(errno));
	break;
      }
      if (verbose >= 3)
	moan("establish Lisp `%s' image link `%s' referring to `%s'",
	     JOB_NAME(job), job->imglink, job->imghash);
      if (symlink(p, job->imgnewlink)) {
	bad("failed to create Lisp `%s' image link `%s': %s",
	    JOB_NAME(job), job->imgnewlink, strerror(errno));
	break;
      }
      if (rename(job->imgnewlink, job->imglink)) {
	bad("failed to rename Lisp `%s' image link `%s' to `%s': %s",
	    JOB_NAME(job), job->imgnewlink, job->imglink, strerror(errno));
	break;
      }
      if (job->oldimg && STRCMP(job->oldimg, !=, job->imghash)) {
	if (verbose >= 3)
	  moan("remove old Lisp `%s' image `%s'",
	       JOB_NAME(job), job->oldimg);
	if (unlink(job->oldimg) && errno != ENOENT) {
	  if (verbose >= 1)
	    moan("failed to delete old Lisp `%s' image `%s': %s",
		 JOB_NAME(job), job->oldimg, strerror(errno));
	}
      }

      /* I think we're all done. */
      break;

    default:
      assert(0);
  }

  /* If the job failed and we're being quiet then write out the log that we
   * made.
   */
  if (!ok && verbose < 2) {
    rewind(job->log);
    for (;;) {
      n = fread(buf, 1, sizeof(buf), job->log);
      if (n) fwrite(buf, 1, n, stdout);
      if (n < sizeof(buf)) break;
    }
  }

  /* Also make a node to stderr about what happened.  (Just to make sure
   * that we've gotten someone's attention.)
   */
  if (!ok) bad("failed to dump Lisp `%s'", JOB_NAME(job));

  /* Finally free the job control block. */
  if (job) release_job(job);
  dstr_release(&d);
}

/* Called after `SIGCHLD': collect exit statuses and mark jobs as dead. */
static void reap_children(void)
{
  struct job *job;
  pid_t kid;
  int st;

  for (;;) {

    /* Collect a child exit status.  If there aren't any more then we're
     * done.
     */
    kid = waitpid(0, &st, WNOHANG);
    if (kid <= 0) break;

    /* Try to find a matching job.  If we can't, then we should just ignore
     * it.
     */
    for (job = job_run; job; job = job->next)
      if (job->kid == kid) goto found;
    continue;

  found:
    /* Mark the job as dead, and save its exit status. */
    job->exit = st; job->kid = -1; nrun--;
  }

  /* If there was a problem with waitpid(2) then report it. */
  if (kid < 0 && errno != ECHILD)
    lose("failed to collect child process exit status: %s", strerror(errno));
}

/* Execute the handler for some JOB. */
static NORETURN void job_child(struct job *job, struct argv *av)
{
  try_exec(av, 0);
  moan("failed to run `%s': %s", av->v[0], strerror(errno));
  _exit(127);
}

/* Start up jobs while there are (a) jobs to run and (b) slots to run them
 * in.
 */
static void start_jobs(void)
{
  struct dstr d = DSTR_INIT;
  int p_out[2], p_err[2];
  struct job *job;
  struct argv *av;
  pid_t kid;

  /* Keep going until either we run out of jobs, or we've got enough running
   * already.
   */
  while (job_ready && nrun < maxrun) {

    /* Set things up ready.  If things go wrong, we need to know what stuff
     * needs to be cleaned up.
     */
    job = job_ready; job_ready = job->next;
    if (!job_ready) job_ready_tail = &job_ready;
    p_out[0] = p_out[1] = p_err[0] = p_err[1] = -1;

    /* Figure out what to do. */
    switch (job->st) {
      case JST_VERSION: av = &job->av_version; break;
      case JST_DUMP: av = &job->av_dump; break;
      default: assert(0);
    }

    /* If we're not actually going to do anything, now is the time to not do
     * that.  We should do the version-hashing step unconditionally.
     */
    switch (job->st) {
      case JST_VERSION:
	break;
      case JST_DUMP:
	if (flags&AF_DRYRUN) {
	  if (try_exec(av,
		       TEF_DRYRUN |
		       (verbose >= 2 && !(flags&AF_CHECKINST)
			  ? TEF_VERBOSE : 0)))
	      rc = 127;
	    else if (verbose >= 2)
	      printf("%-13s > not dumping `%s' (dry run)\n",
		     JOB_NAME(job), JOB_NAME(job));
	  release_job(job);
	  continue;
	}
	break;
      default:
	assert(0);
    }

    /* Do one-time setup for external jobs. */
    if (!job->log) {

      /* Make a temporary subdirectory for this job to use. */
      dstr_reset(&d); dstr_putf(&d, "%s/%s", tmpdir, JOB_NAME(job));
      if (mkdir(d.p, 0700)) {
	bad("failed to create working directory for job `%s': %s",
	    JOB_NAME(job), strerror(errno));
	goto fail;
      }

      /* Create the job's log file.  If we're being verbose then that's just
       * our normal standard output -- /not/ stderr: it's likely that users
       * will want to pipe this stuff through a pager or something, and
       * that'll be easier if we use stdout.  Otherwise, make a file in the
       * temporary directory.
       */
      if (verbose >= 2)
	job->log = stdout;
      else {
	dstr_puts(&d, "/log"); job->log = fopen(d.p, "w+");
	if (!job->log)
	  lose("failed to open log file `%s': %s", d.p, strerror(errno));
      }
    }

    /* Make the pipes to capture the child process's standard output and
     * error streams.
     */
    if (pipe(p_out) || pipe(p_err)) {
      bad("failed to create pipes for job `%s': %s",
	  JOB_NAME(job), strerror(errno));
      goto fail;
    }
    if (configure_fd("job stdout pipe", p_out[0], 1, 1) ||
	configure_fd("job stdout pipe", p_out[1], 0, 1) ||
	configure_fd("job stderr pipe", p_err[0], 1, 1) ||
	configure_fd("job stderr pipe", p_err[1], 0, 1) ||
	configure_fd("log file", fileno(job->log), 1, 1))
      goto fail;

    /* Initialize the output-processing structures ready for use. */
    if (job->st == JST_VERSION) sha256_init(&job->h);
    job->out.buf = xmalloc(MAXLINE); job->out.off = job->out.len = 0;
    job->out.fd = p_out[0]; p_out[0] = -1;
    job->err.buf = xmalloc(MAXLINE); job->err.off = job->err.len = 0;
    job->err.fd = p_err[0]; p_err[0] = -1;

    /* Print a note to the top of the log. */
    dstr_reset(&d); argv_string(&d, av);
    fprintf(job->log, "%-13s > starting %s\n", JOB_NAME(job), d.p);

    /* Flush the standard output stream.  (Otherwise the child might try to
     * flush it too.)
     */
    fflush(stdout);

    /* Spin up the child process. */
    kid = fork();
    if (kid < 0) {
      bad("failed to fork process for job `%s': %s",
	  JOB_NAME(job), strerror(errno));
      goto fail;
    }
    if (!kid) {
      if (dup2(nullfd, 0) < 0 ||
	  dup2(p_out[1], 1) < 0 ||
	  dup2(p_err[1], 2) < 0)
	lose("failed to juggle job `%s' file descriptors: %s",
	     JOB_NAME(job), strerror(errno));
      job_child(job, av);
    }

    /* Close the ends of the pipes that we don't need.  Move the job into
     * the running list.
     */
    close(p_out[1]); close(p_err[1]);
    job->kid = kid; job->next = job_run; job_run = job; nrun++;
    continue;

  fail:
    /* Clean up the wreckage if it didn't work. */
    if (p_out[0] >= 0) close(p_out[0]);
    if (p_out[1] >= 0) close(p_out[1]);
    if (p_err[0] >= 0) close(p_err[0]);
    if (p_err[1] >= 0) close(p_err[1]);
    release_job(job);
  }

  /* All done except for some final tidying up. */
  dstr_release(&d);
}

/* Take care of all of the jobs until they're all done. */
static void run_jobs(void)
{
  struct job *job, *next, **link;
  int nfd;
  fd_set fd_in;

  for (;;) {

    /* If there are jobs still to be started and we have slots to spare then
     * start some more up.
     */
    start_jobs();

    /* If the queues are now all empty then we're done.  (No need to check
     * `job_ready' here: `start_jobs' would have started them if `job_run'
     * was empty.
     */
    if (!job_run) break;

    /* Prepare for the select(2) call: watch for the signal pipe and all of
     * the job pipes.
     */
#define SET_FD(dir, fd) do {						\
  int _fd = (fd);							\
  FD_SET(_fd, &fd_##dir);						\
  if (_fd >= nfd) nfd = _fd + 1;					\
} while (0)

    FD_ZERO(&fd_in); nfd = 0;
    SET_FD(in, sig_pipe[0]);
    for (job = job_run; job; job = job->next) {
      if (job->out.fd >= 0) SET_FD(in, job->out.fd);
      if (job->err.fd >= 0) SET_FD(in, job->err.fd);
    }

#undef SET_FD

    /* Find out what's going on. */
    if (select(nfd, &fd_in, 0, 0, 0) < 0) {
      if (errno == EINTR) continue;
      else lose("select failed: %s", strerror(errno));
    }

    /* If there were any signals then handle them. */
    if (FD_ISSET(sig_pipe[0], &fd_in)) {
      check_signals();
      if (sigloss >= 0) {
	/* We hit a fatal signal.  Kill off the remaining jobs and abort. */
	for (job = job_ready; job; job = next)
	  { next = job->next; release_job(job); }
	for (job = job_run; job; job = next)
	  { next = job->next; release_job(job); }
	break;
      }
    }

    /* Collect output from running jobs, and clear away any dead jobs once
     * we've collected all their output.
     */
    for (link = &job_run, job = *link; job; job = next) {
      if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in))
	prefix_lines(job, &job->out, '|',
		     job->st == JST_VERSION ? &job->h : 0);
      if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in))
	prefix_lines(job, &job->err, '*', 0);
      next = job->next;
      if (job->kid > 0 || job->out.fd >= 0 || job->err.fd >= 0)
	link = &job->next;
      else
	{ *link = next; finish_job(job); }
    }
  }
}

/*----- Main program ------------------------------------------------------*/

/* Help and related functions. */
static void version(FILE *fp)
  { fprintf(fp, "%s, runlisp version %s\n", progname, PACKAGE_VERSION); }

static void usage(FILE *fp)
{
  fprintf(fp, "\
usage: %s [-RUafinqrv] [+RUfinr] [-c CONF] [-o [SECT:]VAR=VAL]\n\
	[-O FILE|DIR] [-j NJOBS] [LISP ...]\n",
	  progname);
}

static void help(FILE *fp)
{
  version(fp); fputc('\n', fp); usage(fp);
  fputs("\n\
Help options:\n\
  -h, --help			Show this help text and exit successfully.\n\
  -V, --version			Show version number and exit successfully.\n\
\n\
Diagnostics:\n\
  -n, --dry-run			Don't run run anything (useful with `-v').\n\
  -q, --quiet			Don't print warning messages.\n\
  -v, --verbose			Print informational messages (repeatable).\n\
\n\
Configuration:\n\
  -c, --config-file=CONF	Read configuration from CONF (repeatable).\n\
  -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
\n\
Image dumping:\n\
  -O, --output=FILE|DIR		Store image(s) in FILE or DIR.\n\
  -R, --remove-other		Delete image files for other Lisp systems.\n\
  -U, --remove-unknown		Delete unrecognized files in image dir.\n\
  -a, --all-configured		Select all configured implementations.\n\
  -f, --force			Dump images even if they already exist.\n\
  -i, --check-installed		Check Lisp systems exist before dumping.\n\
  -j, --jobs=NJOBS		Run up to NJOBS jobs in parallel.\n\
  -r, --remove-image		Delete image files, instead of creating.\n",
	fp);
}

static void show_job_list(const char *what, struct job *job)
{
  struct dstr d = DSTR_INIT;
  int first;

  first = 1;
  for (; job; job = job->next) {
    if (first) first = 0;
    else dstr_puts(&d, ", ");
    dstr_putf(&d, "`%s'", JOB_NAME(job));
  }
  if (first) dstr_puts(&d, "(none)");
  dstr_putz(&d);
  moan("%s: %s", what, d.p);
}

/* Main program. */
int main(int argc, char *argv[])
{
  struct config_section_iter si;
  struct config_section *sect;
  struct config_var *var;
  const char *out = 0, *p, *q, *l;
  struct job *job;
  struct stat st;
  struct dstr d = DSTR_INIT;
  DIR *dir;
  struct dirent *de;
  int i, fd;
  size_t n, o;
  unsigned f;

  /* Command-line options. */
  static const struct option opts[] = {
    { "help",			0,		0,	'h' },
    { "version",		0,		0,	'V' },
    { "output",			OPTF_ARGREQ,	0,	'O' },
    { "remove-other",		OPTF_NEGATE,	0,	'R' },
    { "remove-unknown",		OPTF_NEGATE,	0,	'U' },
    { "all-configured",		0,		0,	'a' },
    { "config-file",		OPTF_ARGREQ,	0,	'c' },
    { "force",			OPTF_NEGATE,	0,	'f' },
    { "check-installed",	OPTF_NEGATE,	0,	'i' },
    { "jobs",			OPTF_ARGREQ,	0,	'j' },
    { "dry-run",		OPTF_NEGATE,	0,	'n' },
    { "set-option",		OPTF_ARGREQ,	0,	'o' },
    { "quiet",			0,		0,	'q' },
    { "remove-image",		OPTF_NEGATE,	0,	'r' },
    { "verbose",		0,		0,	'v' },
    { 0,			0,		0,	0 }
  };

  /* Initial setup. */
  set_progname(argv[0]);
  init_config();
  srand(time(0));

  /* Parse the options. */
  optprog = (/*unconst*/ char *)progname;

#define FLAGOPT(ch, f)							\
  case ch:								\
    flags |= f;								\
    break;								\
  case ch | OPTF_NEGATED:						\
    flags &= ~f;							\
    break

  for (;;) {
    i = mdwopt(argc - 1, argv + 1, "hVO:R+U+ac:f+i+j:n+o:qr+v", opts, 0, 0,
	       OPTF_NEGATION | OPTF_NOPROGNAME);
    if (i < 0) break;
    switch (i) {
      case 'h': help(stdout); exit(0);
      case 'V': version(stdout); exit(0);
      case 'O': out = optarg; break;
      FLAGOPT('R', AF_CLEAN);
      FLAGOPT('U', AF_JUNK);
      case 'a': flags |= AF_ALL; break;
      case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break;
      FLAGOPT('f', AF_FORCE);
      FLAGOPT('i', AF_CHECKINST);
      case 'j': maxrun = parse_int("number of jobs", optarg, 1, 65535); break;
      FLAGOPT('n', AF_DRYRUN);
      case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break;
      case 'q': if (verbose) verbose--; break;
      FLAGOPT('r', AF_REMOVE);
      case 'v': verbose++; break;
      default: flags |= AF_BOGUS; break;
    }
  }

#undef FLAGOPT

  /* CHeck that everything worked. */
  optind++;
  if ((flags&AF_ALL) ? optind < argc : optind >= argc) flags |= AF_BOGUS;
  if (flags&AF_BOGUS) { usage(stderr); exit(127); }

  /* Load default configuration if no explicit files were requested. */
  if (!(flags&AF_SETCONF)) load_default_config();

  /* OK, so we've probably got some work to do.  Let's set things up ready.
   * It'll be annoying if our standard descriptors aren't actually set up
   * properly, so we'll make sure those slots are populated.  We'll need a
   * `/dev/null' descriptor anyway (to be stdin for the jobs).  We'll also
   * need a temporary directory, and it'll be less temporary if we don't
   * arrange to delete it when we're done.  And finally we'll need to know
   * when a child process exits.
   */
  for (;;) {
    fd = open("/dev/null", O_RDWR);
    if (fd < 0) lose("failed to open `/dev/null': %s", strerror(errno));
    if (fd > 2) { nullfd = fd; break; }
  }
  configure_fd("null fd", nullfd, 0, 1);
  atexit(cleanup);
  if (pipe(sig_pipe))
    lose("failed to create signal pipe: %s", strerror(errno));
  configure_fd("signal pipe (read end)", sig_pipe[0], 1, 1);
  configure_fd("signal pipe (write end)", sig_pipe[1], 1, 1);
  sigemptyset(&caught); sigemptyset(&pending);
  set_signal_handler("SIGTERM", SIGTERM, SIGF_IGNOK);
  set_signal_handler("SIGINT", SIGINT, SIGF_IGNOK);
  set_signal_handler("SIGHUP", SIGHUP, SIGF_IGNOK);
  set_signal_handler("SIGCHLD", SIGCHLD, 0);

  /* Create the temporary directory and export it into the configuration. */
  set_tmpdir();
  config_set_var(&config, builtin, CF_LITERAL, "@%tmp-dir", tmpdir);
  config_set_var(&config, builtin, 0,
		 "@tmp-dir", "${@BUILTIN:@%tmp-dir}/${@name}");

  /* Work out where the image files are going to go.  If there's no `-O'
   * option then we use the main `image-dir'.  Otherwise what happens depends
   * on whether this is a file or a directory.
   */
  if (!out) {
    config_set_var(&config, builtin, 0,
		   "@image-link", "${@image-dir}/${image-file}");
    var = config_find_var(&config, builtin, CF_INHERIT, "@image-dir");
    assert(var); out = config_subst_var_alloc(&config, builtin, var);
  } else if (!stat(out, &st) && S_ISDIR(st.st_mode))  {
    config_set_var(&config, builtin, CF_LITERAL, "@%out-dir", out);
    config_set_var(&config, builtin, 0,
		   "@image-link", "${@BUILTIN:@%out-dir}/${image-file}");
  } else if (argc - optind != 1)
    lose("can't dump multiple Lisps to a single output file");
  else if (flags&AF_JUNK)
    lose("can't clear junk in a single output file");
  else if (flags&AF_CLEAN)
    lose("can't clean other images with a single output file");
  else
    config_set_var(&config, builtin, CF_LITERAL, "@image-link", out);

  /* Set the staging and versioned filenames. */
  config_set_var(&config, builtin, 0,
		 "@image-out", "${@image-link}-${@hash}");
  config_set_var(&config, builtin, 0, "@image-new", "${@image-out}.new");
  config_set_var(&config, builtin, 0,
		 "@image-newlink", "${@image-link}.new");

  config_set_var(&config, builtin, 0, "@script",
		 "${@ENV:RUNLISP_EVAL?"
		   "${@CONFIG:eval-script?"
		     "${@data-dir}/eval.lisp}}");

  /* Configure an initial value for `@hash'.  This is necessary so that
   * `add_job' can expand `dump-image' to check that the command exists.
   */
  config_set_var(&config, builtin, CF_LITERAL, "@hash", "!!!unset!!!");

  /* Dump the final configuration if we're being very verbose. */
  if (verbose >= 5) dump_config();

  /* There are a number of different strategies we might employ, depending on
   * the exact request.
   *
   *				queue		queue		clear
   *	REMOVE	CLEAN	JUNK	selected	others		junk?
   *
   *	*	nil	nil	ready/delete	--		no
   *	*	nil	t	ready/delete	none		yes
   *	nil	t	nil	ready		delete		no
   *	nil	t	t	ready		--		yes
   *	t	t	nil	--		delete		no
   *	t	t	t	--		--		yes
   */

  /* First step: if `AF_REMOVE' and `AF_CLEAN' are not both set, then scan
   * the selected Lisp systems and add them to the appropriate queue.
   *
   * Bit-hack: if they are not both set, then their complements are not both
   * clear.
   */
  if (~flags&(AF_REMOVE | AF_CLEAN)) {

    /* Determine the flags for `add_job' when we select the Lisp systems.  If
     * we intend to clear junk then we must notice the image names we
     * encounter.  If we're supposed to check that Lisps exist before dumping
     * then do that -- but it doesn't make any sense for deletion.
     */
    f = flags&AF_REMOVE ? JQ_DELETE : JQ_READY;
    if (flags&AF_JUNK) f |= JF_NOTICE;
    if (flags&AF_CHECKINST) f |= JF_CHECKINST;
    if (!(flags&(AF_FORCE | AF_REMOVE))) f |= JF_CHECKEXIST;

    /* If we have named Lisps, then process them. */
    if (!(flags&AF_ALL))
      for (i = optind; i < argc; i++)
	add_named_job(f, argv[i], strlen(argv[i]));

    /* Otherwise we're supposed to dump `all' of them.  If there's a `dump'
     * configuration setting then we need to parse that.  Otherwise we just
     * try all of them.
     */
    else {
      var = config_find_var(&config, toplevel, CF_INHERIT, "dump");
      if (!var) {
	/* No setting.  Just do all of the Lisps which look available. */

	f |= JF_CHECKINST;
	for (config_start_section_iter(&config, &si);
	     (sect = config_next_section(&si)); )
	  add_job(f, sect);
      } else {
	/* Parse the `dump' list. */

	dstr_reset(&d); config_subst_var(&config, toplevel, var, &d);
	p = d.p; l = p + d.len;
	for (;;) {
	  while (p < l && ISSPACE(*p)) p++;
	  if (p >= l) break;
	  q = p;
	  while (p < l && !ISSPACE(*p) && *p != ',') p++;
	  add_named_job(f, q, p - q);
	  while (p < l && ISSPACE(*p)) p++;
	  if (p < l && *p == ',') p++;
	}
      }
    }
  }

  /* Second step: if exactly one of `AF_CLEAN' and `AF_JUNK' is set, then we
   * need to scan all of the remaining Lisps and add them to the `delete'
   * queue.
   */
  if (!(flags&AF_CLEAN) != !(flags&AF_JUNK)) {

    /* Determine the flag settings.  If we're junking, then we're not
     * cleaning -- we just want to mark images belonging to other Lisps as
     * off-limits to the junking scan.
     */
    f = flags&AF_CLEAN ? JQ_DELETE : JQ_NONE | JF_NOTICE;

    /* Now scan the Lisp systems. */
    for (config_start_section_iter(&config, &si);
	     (sect = config_next_section(&si)); )
      add_job(f, sect);
  }

  /* Terminate the job queues. */
  *job_ready_tail = 0;
  *job_delete_tail = 0;

  /* Report on what it is we're about to do. */
  if (verbose >= 3) {
    show_job_list("dumping Lisp images", job_ready);
    show_job_list("deleting Lisp images", job_delete);
  }

  /* If there turns out to be nothing to do, then mention this. */
  if (!(flags&AF_REMOVE) && verbose >= 2 && !job_ready)
    moan("no Lisp images to dump");

  /* Run the dumping jobs. */
  run_jobs();

  /* Check for any last signals.  If we hit any fatal signals then we should
   * kill ourselves so that the exit status will be right.
   */
  check_signals();
  if (sigloss) { cleanup(); signal(sigloss, SIG_DFL); raise(sigloss); }

  /* Now delete Lisps which need deleting. */
  while (job_delete) {
    job = job_delete; job_delete = job->next;
    if (flags&AF_DRYRUN) {
      if (verbose >= 2)
	moan("not deleting `%s' image link `%s' (dry run)",
	     JOB_NAME(job), job->imglink);
      if (job->oldimg && verbose >= 2)
	moan("not deleting `%s' image `%s' (dry run)",
	     JOB_NAME(job), job->oldimg);
    } else {
      if (verbose >= 2)
	moan("deleting `%s' image `%s'",
	     JOB_NAME(job), job->imglink);
      if (unlink(job->imglink) && errno != ENOENT)
	bad("failed to delete `%s' image link `%s': %s",
	    JOB_NAME(job), job->imglink, strerror(errno));
      if (job->oldimg && unlink(job->oldimg) && errno != ENOENT)
	bad("failed to delete `%s' image `%s': %s",
	    JOB_NAME(job), job->oldimg, strerror(errno));
    }
  }

  /* Finally, maybe delete all of the junk files in the image directory. */
  if (flags&AF_JUNK) {
    dir = opendir(out);
    if (!dir)
      lose("failed to open image directory `%s': %s", out, strerror(errno));
    dstr_reset(&d);
    dstr_puts(&d, out); dstr_putc(&d, '/'); o = d.len;
    if (verbose >= 2)
      moan("cleaning up junk in image directory `%s'", out);
    for (;;) {
      de = readdir(dir); if (!de) break;
      if (de->d_name[0] == '.' &&
	  (!de->d_name[1] || (de->d_name[1] == '.' && !de->d_name[2])))
	continue;
      n = strlen(de->d_name);
      d.len = o; dstr_putm(&d, de->d_name, n + 1);
      if (!treap_lookup(&good, de->d_name, n)) {
	if (flags&AF_DRYRUN) {
	  if (verbose >= 2)
	    moan("not deleting junk file `%s' (dry run)", d.p);
	} else {
	  if (verbose >= 2)
	    moan("deleting junk file `%s'", d.p);
	  if (unlink(d.p) && errno != ENOENT)
	    bad("failed to delete junk file `%s': %s", d.p, strerror(errno));
	}
      }
    }
  }

  /* All done! */
  return (rc);
}

/*----- That's all, folks -------------------------------------------------*/