X-Git-Url: https://git.distorted.org.uk/~mdw/runlisp/blobdiff_plain/8996f767e047eefa8af4d01b1434b54f4c169b79..164c2063204d266072153bfaf499540d0df2c647:/dump-runlisp-image.c diff --git a/dump-runlisp-image.c b/dump-runlisp-image.c index 1c6cb55..7d1d88f 100644 --- a/dump-runlisp-image.c +++ b/dump-runlisp-image.c @@ -49,6 +49,7 @@ #include "common.h" #include "lib.h" #include "mdwopt.h" +#include "sha256.h" /*----- Static data -------------------------------------------------------*/ @@ -69,9 +70,9 @@ struct linebuf { /* Job-state constants. */ enum { - JST_READY, /* not yet started */ - JST_RUN, /* currently running */ - JST_DEAD, /* process exited */ + JST_INTERN, /* not that kind of job */ + JST_VERSION, /* hashing the Lisp version number */ + JST_DUMP, /* dumping the custom image */ JST_NSTATE }; @@ -79,19 +80,27 @@ enum { struct job { struct treap_node _node; /* treap intrusion */ struct job *next; /* next job in whichever list */ - struct argv av; /* argument vector to execute */ - char *imgnew, *imgout; /* staging and final output files */ 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 scheduled to dump */ -static struct job *job_ready, *job_run, *job_dead; /* list jobs by state */ +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' */ @@ -108,6 +117,9 @@ static unsigned flags = 0; /* flags for the application */ #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 --------------------------------------------------------*/ @@ -115,6 +127,15 @@ static unsigned flags = 0; /* flags for the application */ 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'. @@ -410,13 +431,30 @@ static void write_line(struct job *job, struct linebuf *buf, 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) +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; @@ -447,107 +485,226 @@ static void prefix_lines(struct job *job, struct linebuf *buf, char marker) n = readv(buf->fd, iov, niov); if (n < 0) { - /* If there's no data to read after all then just move on. Otherwise we - * have a problem. + /* 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)); - } - - /* 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; - } - - if (!n) { + } 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 ----------------------------------------------------*/ -/* Add a new job to the `ready' queue. +/* 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. * - * The job will be to dump the Lisp system with the given LEN-byte NAME. On - * entry, *TAIL_INOUT should point to the `next' link of the last node in the - * list (or the list head pointer), and will be updated on exit. + * External jobs have a comparatively complicated lifecycle. * - * This function reports (fatal) errors for most kinds of problems. If - * `JF_QUIET' is set in F then silently ignore a well-described Lisp system - * which nonetheless isn't suitable. (This is specifically intended for the - * case where we try to dump all known Lisp systems, but some don't have a - * `dump-image' command.) + * * 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. */ -#define JF_QUIET 1u -static void add_job(struct job ***tail_inout, unsigned f, - const char *name, size_t len) + +/* 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) { - struct job *job; - struct treap_path path; - struct config_section *sect; - struct config_var *dumpvar, *cmdvar, *imgvar; - struct dstr d = DSTR_INIT; - struct argv av = ARGV_INIT; - char *imgnew = 0, *imgout = 0; - size_t i; + 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; - /* Check to see whether this Lisp system is already queued up. */ - 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; } - /* Find the configuration for this Lisp system and check that it can be - * dumped. + /* 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. */ - sect = config_find_section_n(&config, 0, name, len); - if (!sect) lose("unknown Lisp implementation `%.*s'", (int)len, name); - name = CONFIG_SECTION_NAME(sect); - dumpvar = config_find_var(&config, sect, 0, "dump-image"); - if (!dumpvar) { - if (!(f&JF_QUIET)) - lose("don't know how to dump images for Lisp implementation `%s'", - name); + 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. */ - imgvar = config_find_var(&config, sect, 0, "image-file"); - if (!imgvar) lose("variable `image-file' not defined for Lisp `%s'", name); - cmdvar = config_find_var(&config, sect, 0, "command"); - if (!cmdvar) lose("variable `command' not defined for Lisp `%s'", name); - - /* Build the job's command line. */ - config_subst_split_var(&config, sect, dumpvar, &av); - if (!av.n) + 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 @@ -557,53 +714,138 @@ static void add_job(struct job ***tail_inout, unsigned f, * because that would cause us to spam the user with redundant * diagnostics.) */ - if (flags&AF_CHECKINST) { - dstr_reset(&d); - fef = (verbose >= 2 ? FEF_VERBOSE : 0); - config_subst_var(&config, sect, cmdvar, &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); + 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. */ - imgnew = - config_subst_string_alloc(&config, sect, "", "${@image-new}"); - imgout = - config_subst_string_alloc(&config, sect, "", "${@image-out}"); + 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); - /* If we're supposed to check whether the image file exists, then we should - * do that. + /* Inspect the existing image link if there is one, and record its + * destination. */ - if (!(flags&AF_FORCE)) { - if (!access(imgout, F_OK)) { - if (verbose >= 2) - moan("image `%s' already exists: skipping `%s'", d.p, name); - goto end; + 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); - job->imgnew = imgnew; job->imgout = imgout; imgnew = imgout = 0; - 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: /* All done. Cleanup time. */ - for (i = 0; i < av.n; i++) free(av.v[i]); - free(imgnew); free(imgout); - dstr_release(&d); argv_release(&av); + 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. @@ -613,25 +855,34 @@ end: 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->imgout); - for (i = 0; i < job->av.n; i++) free(job->av.v[i]); - argv_release(&job->av); + 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 freed (using `release_job'). + * 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. @@ -663,16 +914,125 @@ static void finish_job(struct job *job) fprintf(job->log, "exited with incomprehensible status %06o\n", job->exit); - /* If it succeeded, then try to rename the completed image file into place. - * - * If that caused trouble then mark the job as failed after all. + /* What happens next depends on the state of the job. This is the main + * place which advanced the job state machine. */ - if (ok && rename(job->imgnew, job->imgout)) { - fprintf(job->log, "%-13s > failed to rename Lisp `%s' " - "output image `%s' to `%s': %s", - JOB_NAME(job), JOB_NAME(job), - job->imgnew, job->imgout, strerror(errno)); - ok = 0; + 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, + "", "${@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; + } + + /* 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; + } + + /* 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 @@ -693,13 +1053,14 @@ static void finish_job(struct job *job) if (!ok) bad("failed to dump Lisp `%s'", JOB_NAME(job)); /* Finally free the job control block. */ - release_job(job); + 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; @@ -714,16 +1075,13 @@ static void reap_children(void) /* Try to find a matching job. If we can't, then we should just ignore * it. */ - for (link = &job_run; (job = *link); link = &job->next) + for (job = job_run; job; job = job->next) if (job->kid == kid) goto found; continue; found: - /* Mark the job as dead, save its exit status, and move it into the dead - * list. - */ - 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. */ @@ -732,11 +1090,10 @@ static void reap_children(void) } /* Execute the handler for some JOB. */ -static NORETURN void job_child(struct job *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)); + try_exec(av, 0); + moan("failed to run `%s': %s", av->v[0], strerror(errno)); _exit(127); } @@ -748,6 +1105,7 @@ 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 @@ -759,28 +1117,64 @@ static void start_jobs(void) * 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; - /* 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; + /* 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); } - /* 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 we're not actually going to do anything, now is the time to not do + * that. We should do the version-hashing step unconditionally. */ - 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)); + 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 @@ -798,14 +1192,15 @@ static void start_jobs(void) configure_fd("log file", fileno(job->log), 1, 1)) goto fail; - /* Initialize the line-buffer structures ready for use. */ + /* 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 @@ -826,15 +1221,14 @@ 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: @@ -868,8 +1262,7 @@ static void run_jobs(void) * `job_ready' here: `start_jobs' would have started them if `job_run' * was empty. */ - if (!job_run && !job_dead) break; - + if (!job_run) break; /* Prepare for the select(2) call: watch for the signal pipe and all of * the job pipes. @@ -886,10 +1279,6 @@ static void run_jobs(void) 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); - } #undef SET_FD @@ -908,27 +1297,24 @@ static void run_jobs(void) { 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; } } - /* Log any new output from the running jobs. */ - for (job = job_run; job; job = job->next) { + /* 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, '|'); + 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, '*'); - } - - /* Finally, clear away any dead jobs once we've collected all their - * output. - */ - for (link = &job_dead, job = *link; job; job = next) { + prefix_lines(job, &job->err, '*', 0); next = job->next; - if (job->out.fd >= 0 || job->err.fd >= 0) link = &job->next; - else { *link = next; finish_job(job); } + if (job->kid > 0 || job->out.fd >= 0 || job->err.fd >= 0) + link = &job->next; + else + { *link = next; finish_job(job); } } } } @@ -942,7 +1328,7 @@ static void version(FILE *fp) static void usage(FILE *fp) { fprintf(fp, "\ -usage: %s [-afnqv] [-c CONF] [-o [SECT:]VAR=VAL]\n\ +usage: %s [-RUafinqrv] [+RUfinr] [-c CONF] [-o [SECT:]VAR=VAL]\n\ [-O FILE|DIR] [-j NJOBS] [LISP ...]\n", progname); } @@ -966,13 +1352,32 @@ 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\ -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[]) { @@ -980,16 +1385,22 @@ int main(int argc, char *argv[]) struct config_section *sect; struct config_var *var; const char *out = 0, *p, *q, *l; - struct job *job, **tail; + struct job *job; struct stat st; struct dstr d = DSTR_INIT; - int i, fd, first; + 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' }, @@ -998,6 +1409,7 @@ 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 } }; @@ -1005,33 +1417,45 @@ int main(int argc, char *argv[]) /* 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:ac:f+i+j:n+o:qv", opts, 0, 0, + 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; - 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; @@ -1075,101 +1499,206 @@ int main(int argc, char *argv[]) * option then we use the main `image-dir'. Otherwise what happens depends * on whether this is a file or a directory. */ - if (!out) + if (!out) { config_set_var(&config, builtin, 0, - "@image-out", "${@image-dir}/${image-file}"); - else if (!stat(out, &st) && S_ISDIR(st.st_mode)) { + "@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-out", "${@BUILTIN:@%out-dir}/${image-file}"); + "@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-out", out); + config_set_var(&config, builtin, CF_LITERAL, "@image-link", out); - /* Set the staging file. */ + /* 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(); - /* Create jobs for the Lisp systems we're supposed to be dumping. */ - tail = &job_ready; - if (!(flags&AF_ALL)) - for (i = optind; i < argc; i++) - add_job(&tail, 0, argv[i], strlen(argv[i])); - else { - /* So we're supposed to dump `all' of them. If there's a `dump' + /* 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. */ - var = config_find_var(&config, toplevel, 0, "dump"); - if (!var) { - /* No setting. Just do all of the Lisps which look available. */ - - flags |= AF_CHECKINST; - 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)); - } else { - /* Parse the `dump' list. */ - - 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); - while (p < l && ISSPACE(*p)) p++; - if (p < l && *p == ',') p++; + 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++; + } } } } - *tail = 0; + + /* 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) { - 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); + show_job_list("dumping Lisp images", job_ready); + show_job_list("deleting Lisp images", job_delete); } - /* If we're not actually going to do anything after all then now's the time - * to, err, not do that. - */ - 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); - } + /* 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 jobs. */ + /* Run the dumping jobs. */ run_jobs(); - /* Finally, 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 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); }