X-Git-Url: https://git.distorted.org.uk/~mdw/runlisp/blobdiff_plain/7b8ff279e7304e41b243459d78c3b6703bb8c3f5..e41cbc79e39d62f0343a48efc4d832ed99c83aaf:/dump-runlisp-image.c diff --git a/dump-runlisp-image.c b/dump-runlisp-image.c index 8e2d86f..7bd9eba 100644 --- a/dump-runlisp-image.c +++ b/dump-runlisp-image.c @@ -49,122 +49,170 @@ #include "common.h" #include "lib.h" #include "mdwopt.h" +#include "sha256.h" /*----- Static data -------------------------------------------------------*/ -#define MAXLINE 16384u +/* 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; - char *buf; - unsigned off, len; + 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_READY, - JST_RUN, - JST_DEAD, + 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; - struct job *next; - struct argv av; - unsigned st; - FILE *log; - pid_t kid; - int exit; - struct linebuf out, err; + 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; -static struct job *job_ready, *job_run, *job_dead; -static unsigned nrun, maxrun = 1; -static int rc = 0; -static int nullfd; - -static int sig_pipe[2] = { -1, -1 }; -static sigset_t caught, pending; -static int sigloss = -1; - -static unsigned flags = 0; -#define AF_BOGUS 0x0001u -#define AF_SETCONF 0x0002u -#define AF_DRYRUN 0x0004u -#define AF_ALL 0x0008u -#define AF_FORCE 0x0010u -#define AF_CHECKINST 0x0020u - -/*----- Main code ---------------------------------------------------------*/ - +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 = 2; } - -static const char *tmpdir; + { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); rc = 127; } -static void set_tmpdir(void) +/* Answer whether a string consists entirely of hex digits. */ +static int hex_digits_p(const char *p, size_t sz) { - struct dstr d = DSTR_INIT; - size_t n; - unsigned i; + const char *l; - dstr_putf(&d, "%s/runlisp.%d.", my_getenv("TMPDIR", "/tmp"), getpid()); - i = 0; n = d.len; - for (;;) { - d.len = n; dstr_putf(&d, "%d", rand()); - 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) { - dstr_puts(&d, "???"); - lose("failed to create temporary directory `%s': too many attempts", - d.p); - } - } - tmpdir = xstrndup(d.p, d.len); dstr_release(&d); + 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) { - size_t n = dd->len; DIR *dir; struct dirent *d; + size_t n = dd->len; - dd->p[n] = 0; - dir = opendir(dd->p); + /* 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); } -static void cleanup(void) - { if (tmpdir) { recursive_delete(tmpdir); tmpdir = 0; } } - +/* 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; @@ -190,103 +238,658 @@ fail: 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)); } -#define JF_QUIET 1u -static void add_job(struct job ***tail_inout, unsigned f, - const char *name, size_t len) +/* 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 job *job; + 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; - struct config_section *sect; - struct config_var *dump_var, *cmd_var; - struct dstr d = DSTR_INIT; - struct argv av = ARGV_INIT; + + 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; - job = treap_probe(&jobs, name, len, &path); + /* 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 (verbose >= 2) { + if ((f&JF_PICKY) && verbose >= 1) moan("ignoring duplicate Lisp `%s'", JOB_NAME(job)); - return; - } + goto end; } - sect = config_find_section_n(&config, 0, name, len); - if (!sect) lose("unknown Lisp implementation `%.*s'", (int)len, name); - name = CONFIG_SECTION_NAME(sect); - dump_var = config_find_var(&config, sect, 0, "dump-image"); - if (!dump_var) { - if (!(f&JF_QUIET)) - lose("don't know how to dump images for Lisp implementation `%s'", - name); + /* 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; } - cmd_var = config_find_var(&config, sect, 0, "command"); - if (!cmd_var) - lose("no `command' defined for Lisp implementation `%s'", name); - - config_subst_split_var(&config, sect, dump_var, &av); - if (!av.n) lose("empty command for Lisp implementation `%s'", name); - if (flags&AF_CHECKINST) { - dstr_reset(&d); - fef = (verbose >= 2 ? FEF_VERBOSE : 0); - config_subst_var(&config, sect, cmd_var, &d); - if (!found_in_path_p(d.p, fef) || - (STRCMP(d.p, !=, av.v[0]) && !found_in_path_p(av.v[0], fef))) { - if (verbose >= 2) moan("skipping Lisp implementation `%s'", name); + /* 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, xstrdup("?(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; } } - if (!(flags&AF_FORCE)) { - dstr_reset(&d); - config_subst_string(&config, sect, "", "${@IMAGE}", &d); - if (!access(d.p, F_OK)) { - if (verbose >= 2) - moan("image `%s' already exists: skipping `%s'", d.p, name); - goto end; + /* Collect the output image file names. */ + imglink = + config_subst_string_alloc(&config, sect, "", "${@image-link}"); + imgnewlink = + config_subst_string_alloc(&config, sect, + "", "${@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_READY; - job->kid = -1; + 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 = av; argv_init(&av); - treap_insert(&jobs, &path, &job->_node, name, len); - **tail_inout = job; *tail_inout = &job->next; + 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: - dstr_release(&d); argv_release(&av); + /* 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]; - size_t n; + 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)) @@ -311,196 +914,262 @@ static void finish_job(struct job *job) fprintf(job->log, "exited with incomprehensible status %06o\n", job->exit); - 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; - } - } + /* What happens next depends on the state of the job. This is the main + * place which advanced the job state machine. + */ + if (ok) switch (job->st) { - release_job(job); -} + case JST_VERSION: + /* We've retrieved the Lisp system's version string. */ -static int find_newline(struct linebuf *buf, size_t *linesz_out) -{ - char *nl; + /* 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, + "", "${@image-out}"); + job->imgnew = + config_subst_string_alloc(&config, job->sect, + "", "${@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; + } - if (buf->off + buf->len <= MAXLINE) { - nl = memchr(buf->buf + buf->off, '\n', buf->len); - if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); } - } else { - 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); -} + /* 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; + } -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); -} + /* 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 (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; + } + + /* 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 (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) && + 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)); + } -static void prefix_lines(struct job *job, struct linebuf *buf, char marker) -{ - struct iovec iov[2]; int niov; - ssize_t n; - size_t linesz; + /* I think we're all done. */ + break; - 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; + default: + assert(0); } - n = readv(buf->fd, iov, niov); - if (n < 0) { - if (errno == EAGAIN || errno == EWOULDBLOCK) return; - lose("failed to read job `%s' output stream: %s", - JOB_NAME(job), strerror(errno)); + /* 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; + } } - 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) - buf->off = 0; - else if (buf->len == MAXLINE) { - write_line(job, buf, MAXLINE, marker, " [...]\n"); - buf->off = buf->len = 0; - } + /* 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)); - if (!n) { - close(buf->fd); buf->fd = -1; - if (buf->len) - write_line(job, buf, buf->len, marker, " [missing final newline]\n"); - } + /* 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, **link; + 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; - for (link = &job_run; (job = *link); link = &job->next) + + /* 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; - moan("unexpected child process %d exited with status %06o", kid, st); continue; + found: - job->exit = st; job->st = JST_DEAD; job->kid = -1; nrun--; - *link = job->next; job->next = job_dead; job_dead = job; + /* 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)); } -static void check_signals(void) -{ - sigset_t old, pend; - char buf[32]; - ssize_t n; - - 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); - - 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(); -} - -#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)); -} - -static NORETURN void job_child(struct job *job) +/* Execute the handler for some JOB. */ +static NORETURN void job_child(struct job *job, struct argv *av) { - try_exec(&job->av, - !(flags&AF_CHECKINST) && verbose >= 2 ? TEF_VERBOSE : 0); - moan("failed to run `%s': %s", job->av.v[0], strerror(errno)); - _exit(2); + 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; - 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; + + /* 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 (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)); + + /* 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)); @@ -512,13 +1181,24 @@ static void start_jobs(void) 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; - dstr_reset(&d); argv_string(&d, &job->av); + + /* 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", @@ -531,29 +1211,114 @@ static void start_jobs(void) dup2(p_err[1], 2) < 0) lose("failed to juggle job `%s' file descriptors: %s", JOB_NAME(job), strerror(errno)); - job_child(job); + 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->st = JST_RUN; job->next = job_run; job_run = job; nrun++; + 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 [-afnqv] [-c CONF] [-o [SECT:]VAR=VAL]\n\ +usage: %s [-RUadfinqrv] [+RUdfinr] [-c CONF] [-o [SECT:]VAR=VAL]\n\ [-O FILE|DIR] [-j NJOBS] [LISP ...]\n", progname); } @@ -577,29 +1342,56 @@ Configuration:\n\ \n\ Image dumping:\n\ -O, --output=FILE|DIR Store image(s) in FILE or DIR.\n\ - -a, --all-configured Dump all implementations configured.\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\ + -d, --cleanup Delete images which are no longer wanted.\n\ -f, --force Dump images even if they already exist.\n\ - -i, --check-installed Check Lisp systems exist before invoking.\n\ - -j, --jobs=NJOBS Run up to NJOBS jobs in parallel.\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, **tail, **link, *next; + struct job *job; struct stat st; struct dstr d = DSTR_INIT; - int i, fd, nfd, first; - fd_set fd_in; + 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' }, @@ -608,55 +1400,74 @@ int main(int argc, char *argv[]) { "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(); + /* 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:ac:f+i+j:n+o:qv", opts, 0, 0, + i = mdwopt(argc - 1, argv + 1, "hVO:R+U+ac:d+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; - case 'f': flags |= AF_FORCE; break; - case 'f' | OPTF_NEGATED: flags &= ~AF_FORCE; break; - case 'i': flags |= AF_CHECKINST; break; - case 'i' | OPTF_NEGATED: flags &= ~AF_CHECKINST; break; + FLAGOPT('f', AF_FORCE); + FLAGOPT('i', AF_CHECKINST); case 'j': maxrun = parse_int("number of jobs", optarg, 1, 65535); break; - case 'n': flags |= AF_DRYRUN; break; - case 'n' | OPTF_NEGATED: flags &= ~AF_DRYRUN; 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(2); } + if (flags&AF_BOGUS) { usage(stderr); exit(127); } + /* Load default configuration if no explicit files were requested. */ if (!(flags&AF_SETCONF)) load_default_config(); - if (!out) - config_set_var(&config, builtin, 0, - "@IMAGE", "${@CONFIG:image-dir}/${image-file}"); - else if (stat(out, &st) || !S_ISDIR(st.st_mode)) - config_set_var(&config, builtin, CF_LITERAL, "@IMAGE", out); - else { - config_set_var(&config, builtin, CF_LITERAL, "@%OUTDIR", out); - config_set_var(&config, builtin, 0, - "@IMAGE", "${@BUILTIN:@%OUTDIR}/${image-file}"); + /* 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)); @@ -668,135 +1479,217 @@ int main(int argc, char *argv[]) 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, "@%TMPDIR", 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, - "@TMPDIR", "${@BUILTIN:@%TMPDIR}/${@NAME}"); + "@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(); - tail = &job_ready; - if (!(flags&AF_ALL)) - for (i = optind; i < argc; i++) - add_job(&tail, 0, argv[i], strlen(argv[i])); - else { - var = config_find_var(&config, toplevel, 0, "dump"); - if (!var) - for (config_start_section_iter(&config, &si); - (sect = config_next_section(&si)); ) - add_job(&tail, JF_QUIET, - CONFIG_SECTION_NAME(sect), - CONFIG_SECTION_NAMELEN(sect)); + /* 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 { - p = var->val; l = p + var->n; - for (;;) { - while (p < l && ISSPACE(*p)) p++; - if (p >= l) break; - q = p; - while (p < l && !ISSPACE(*p) && *p != ',') p++; - add_job(&tail, 0, q, p - q); - if (p < l) p++; + 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++; + } } } } - *tail = 0; - if (verbose >= 3) { - dstr_reset(&d); - first = 1; - for (job = job_ready; 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("dumping Lisps: %s", d.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); } - if (flags&AF_DRYRUN) { - for (job = job_ready; job; job = job->next) { - if (try_exec(&job->av, - TEF_DRYRUN | - (verbose >= 2 && !(flags&AF_CHECKINST) ? - TEF_VERBOSE : 0))) - rc = 2; - else if (verbose >= 2) - printf("%-13s > (not dumping `%s': dry run)\n", - JOB_NAME(job), JOB_NAME(job)); - } - return (rc); - } + /* Terminate the job queues. */ + *job_ready_tail = 0; + *job_delete_tail = 0; - 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; } + /* 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); } - configure_fd("null fd", nullfd, 0, 1); - - for (;;) { - start_jobs(); - if (!job_run && !job_dead) break; -#define SET_FD(dir, fd) do { \ - int _fd = (fd); \ - \ - FD_SET(_fd, &fd_##dir); \ - if (_fd >= nfd) nfd = _fd + 1; \ -} while (0) + /* 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"); - 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); - } - for (job = job_dead; 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); - } + /* Run the dumping jobs. */ + run_jobs(); -#undef SET_FD + /* 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); } - if (select(nfd, &fd_in, 0, 0, 0) < 0) { - if (errno == EINTR) continue; - else lose("select failed: %s", strerror(errno)); + /* 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' (dry run)", + 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)); } + } - if (FD_ISSET(sig_pipe[0], &fd_in)) { - check_signals(); - if (sigloss >= 0) { - 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); } - for (job = job_dead; job; job = next) - { next = job->next; release_job(job); } - break; + /* 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)); + } } } - - for (job = job_run; job; job = job->next) { - if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in)) - prefix_lines(job, &job->out, '|'); - if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in)) - prefix_lines(job, &job->err, '*'); - } - for (link = &job_dead, job = *link; job; job = next) { - next = job->next; - if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in)) - prefix_lines(job, &job->out, '|'); - if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in)) - prefix_lines(job, &job->err, '*'); - if (job->out.fd >= 0 || job->err.fd >= 0) link = &job->next; - else { *link = next; finish_job(job); } - } } - check_signals(); - if (sigloss) { cleanup(); signal(sigloss, SIG_DFL); raise(sigloss); } - + /* All done! */ return (rc); }